Require Import Rel.Definitions.
Require Import Rel.BasicFacts.
Require Import Rel.Compat_sub.
Require Import Rel.Compat_map.
Require Import Util.Subset.
Require Import Lang.Static.
Require Import Lang.BindingsFacts.
Require Import Lang.StaticFacts.
Set Implicit Arguments.

Section section_compat_val_up.

Context (EV HV V : Set).
Context (Ξ : XEnv EV HV).
Context (P : HV → F).
Context (Γ : V → ty EV HV ∅).
Context (𝔽 : F).
Context (h₁ h₂ : hd EV HV V ∅).
Context (ℓ : lbl HV ∅).
Context (H_lbl₁ : lbl_hd h₁ = ℓ).
Context (H_lbl₂ : lbl_hd h₂ = ℓ).
Context (𝓔 : eff EV HV ∅).
Context (H𝓔 : 𝓔 = [ef_lbl ℓ]).
Context (Wf_Ξ : wf_XEnv Ξ).
Hint Resolve st_reflexive.

Lemma compat_val_up n :
n ⊨ ⟦ Ξ P Γ ⊢ h₁ ≼ˡᵒᵍₕ h₂ : 𝔽 # ℓ ⟧ →
n ⊨ ⟦ Ξ P Γ ⊢ (⇧ h₁) ≼ˡᵒᵍᵥ (⇧ h₂) :
      ty_fun
      (HV_open_ty (EV_open_ty (fst (Σ 𝔽))))
      (HV_open_ty (EV_open_ty (snd (Σ 𝔽))))
      𝓔 ⟧.
Proof.
specialize (Wf_Σ 𝔽) as Wf_Σ.
intro Hh.
iintro ξ₁ ; iintro ξ₂ ; iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ; iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro cl_δ ; iintro cl_ρ₁ρ₂ ; iintro Hρ ; iintro Hγ.
simpl.
iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂' ;
iintro v₁ ; iintro v₂ ; iintro Hv.

iespecialize Hh.
repeat (ispecialize Hh ; [ eassumption | ]).

bind_hole.
eapply 𝓦_in_𝓣.
destruct ℓ as [ p | [ | X ] ] ; [ | auto | ] ; simpl in Hh |- *.
+ idestruct Hh as r₁ Hh ; idestruct Hh as r₂ Hh ;
  idestruct Hh as X₁ Hh ; idestruct Hh as X₂ Hh ;
  idestruct Hh as Hh₁h₂ Hh ; idestruct Hh as Hρ₁ρ₂ Hr.
  iexists (λ ξ₁'' ξ₂'' t₁ t₂,
    match t₁, t₂ with
    | tm_val v₁, tm_val v₂ =>
      ▷ 𝓥⟦ Ξ ⊢ HV_open_ty (EV_open_ty (snd (Σ 𝔽))) ⟧
        δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁'' ξ₂'' v₁ v₂
    | _, _ => (False)ᵢ
    end
  ).
  repeat ieexists ; repeat isplit.
  - subst 𝓔 ; simpl.
    ileft ; repeat ieexists ; repeat isplit.
    * eassumption.
    * auto.
    * auto 9.
    * repeat ieexists ; repeat isplit ; [ eassumption | eassumption | ].
      later_shift.
      eapply 𝓗_Fun'_monotone ; eauto.
    * clear - Hv Wf_Ξ Wf_Σ.
      iintro_later ; apply 𝓥_roll.
      erewrite I_iff_elim_M ; [ | apply closed_weaken_𝓥 ; crush ] ; eauto.
    * clear - Wf_Ξ Wf_Σ.
      iintro ξ₁ ; iintro ξ₂ ; iintro t₁ ; iintro t₂.
      isplit ; iintro H ; later_shift.
      { idestruct H as v₁ H ; idestruct H as v₂ H ; idestruct H as Ht₁t₂ Hv.
        ielim_prop Ht₁t₂ ; destruct Ht₁t₂ ; subst.
        apply 𝓥_unroll in Hv.
        erewrite <- I_iff_elim_M ; [ | apply closed_weaken_𝓥 ] ; crush.
      }
      { repeat ieexists ; isplit ; [ crush | ].
        apply 𝓥_roll.
        erewrite I_iff_elim_M ; [ | apply closed_weaken_𝓥 ; crush ] ; eauto.
      }
  - iintro_prop ; crush.
  - clear.
    iintro ξ₁'' ; iintro ξ₂'' ; iintro t₁ ; iintro t₂ ; iintro Hξ₁'' ; iintro Hξ₂''.
    iintro H ; destruct t₁, t₂ ; try icontradict H.
    later_shift.
    eapply 𝓥_in_𝓣 in H.
    apply 𝓣_roll ; exact H.

+ idestruct Hh as r₁ Hh ; idestruct Hh as r₂ Hh ; idestruct Hh as Hh₁h₂ Hh ;
  idestruct Hh as T Hh ; idestruct Hh as 𝓕 Hh ; idestruct Hh as BindsX Hr.
  iexists (λ ξ₁'' ξ₂'' t₁ t₂,
    match t₁, t₂ with
    | tm_val v₁, tm_val v₂ =>
      ▷ 𝓥⟦ Ξ ⊢ HV_open_ty (EV_open_ty (snd (Σ 𝔽))) ⟧
        δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁'' ξ₂'' v₁ v₂
    | _, _ => (False)ᵢ
    end
  ).
  repeat ieexists ; repeat isplit.
  - subst 𝓔 ; simpl.
    ileft ; repeat ieexists ; repeat isplit.
    * auto 9.
    * auto.
    * auto 9.
    * repeat ieexists ; repeat isplit ; [ eassumption | ].
      repeat ieexists ; isplit ; [ eassumption | ].
      later_shift.
      eapply 𝓗_Fun'_monotone ; eauto.
    * clear - Hv Wf_Ξ Wf_Σ.
      iintro_later ; apply 𝓥_roll.
      erewrite I_iff_elim_M ; [ | apply closed_weaken_𝓥 ; crush ] ; eauto.
    * clear - Wf_Ξ Wf_Σ.
      iintro ξ₁ ; iintro ξ₂ ; iintro t₁ ; iintro t₂.
      isplit ; iintro H ; later_shift.
      { idestruct H as v₁ H ; idestruct H as v₂ H ; idestruct H as Ht₁t₂ Hv.
        ielim_prop Ht₁t₂ ; destruct Ht₁t₂ ; subst.
        apply 𝓥_unroll in Hv.
        erewrite <- I_iff_elim_M ; [ | apply closed_weaken_𝓥 ] ; crush.
      }
      { repeat ieexists ; isplit ; [ crush | ].
        apply 𝓥_roll.
        erewrite I_iff_elim_M ; [ | apply closed_weaken_𝓥 ; crush ] ; eauto.
      }
  - iintro_prop ; crush.
  - clear.
    iintro ξ₁'' ; iintro ξ₂'' ; iintro t₁ ; iintro t₂ ; iintro Hξ₁'' ; iintro Hξ₂''.
    iintro H ; destruct t₁, t₂ ; try icontradict H.
    later_shift.
    eapply 𝓥_in_𝓣 in H.
    apply 𝓣_roll ; exact H.
Qed.

End section_compat_val_up.


Require Import Classical Peano_dec Setoid PeanoNat.
From hahn Require Import Hahn.
Require Import Lia.

Require Import Events.
Require Import Execution.
Require Import Execution_eco.
Require Import imm_bob.
Require Import imm_s.
Require Import imm_s_ppo.
Require Import imm_s_rfppo.
Require Import AuxDef.
Require Import SetSize.
Require Import FairExecution.
Require Import ImmFair.
Require Import AuxRel2.
Require Import CountabilityHelpers.
Require Import CombRelations.
Import ListNotations.
From imm Require Import imm_s.
From imm Require Import imm_s_hb.
Require Import FairExecution.
Require Import AuxRel2.
Require Import FinThreads.

Section HbFsupp.
  Variable (G: execution) (sc: relation actid).
  Hypothesis (WF: Wf G) (IMMCON: imm_consistent G sc).
  Hypothesis (FAIR: mem_fair G) (FSUPP_SC: fsupp sc).
  Hypothesis (TB: fin_threads G).

  Lemma fsupp_rs : fsupp (⦗set_compl is_init⦘ ⨾ rs G).
  Proof using WF IMMCON FAIR.
    assert (sc_per_loc G) as SCPL.
    { apply coherence_sc_per_loc, IMMCON. }
    unfold imm_s_hb.rs.
    rewrite <- !seqA.
    apply fsupp_seq.
    2: { rewrite rf_rmw_in_co; auto.
         rewrite rt_of_trans; [| apply co_trans; auto].
         apply fsupp_cr. apply FAIR. }
    rewrite inclusion_seq_eqv_r, seqA, inclusion_seq_eqv_l with (dom := is_w _).
    rewrite inclusion_inter_l1. rewrite crE. relsf.
    apply fsupp_union; auto using fsupp_eqv, fsupp_sb.
  Qed.

  Lemma fsupp_release : fsupp (release G).
  Proof using WF IMMCON FAIR.
    rewrite no_release_from_init; auto.
    unfold imm_s_hb.release.
    rewrite inclusion_seq_eqv_l with (dom := is_rel _).
    eapply fsupp_mori.
    2: { apply fsupp_seq with (r1 := ⦗set_compl is_init⦘ ⨾ (sb G)^?).
         2: { apply fsupp_rs. }
         rewrite crE. relsf. apply fsupp_union; auto using fsupp_sb, fsupp_eqv. }
    red. rewrite no_sb_to_init at 1. basic_solver 10.
  Qed.

  Lemma fsupp_sw : fsupp (sw G).
  Proof using WF IMMCON FAIR.
    unfold imm_s_hb.sw.
    rewrite (no_rf_to_init WF).
    rewrite !seqA. rewrite <- seqA with (r2 := rf G).
    apply fsupp_seq.
    2: { rewrite !inclusion_seq_eqv_r.
         rewrite crE. relsf. apply fsupp_union; auto using fsupp_sb, fsupp_eqv. }
    apply fsupp_seq; auto using fsupp_rf, fsupp_release.
  Qed.

  Lemma fsupp_hb : fsupp (⦗set_compl is_init⦘ ⨾ hb G).
  Proof using TB WF IMMCON FAIR.
    rewrite (dom_l (wf_hbE WF)), <- !seqA.
    rewrite <- id_inter, set_interC, <- set_minusE.
    unfold imm_s_hb.hb.
    rewrite clos_trans_domb_l_strong.
    2: { rewrite no_sb_to_init, no_sw_to_init, wf_sbE, wf_swE; basic_solver. }
    rewrite inclusion_seq_eqv_r.
    arewrite (acts_set G \₁ is_init ⊆₁ set_compl is_init); [basic_solver| ].
    rewrite seq_union_r.
    eapply fsupp_ct with (s := acts_set G \₁ is_init), fsupp_union; ins; eauto.
    { rewrite 2!inclusion_seq_eqv_l.
      cdes IMMCON. red in Cint.
      generalize Cint. unfold acyclic, hb. basic_solver 10. }
    { rewrite (dom_l (@wf_sbE G)), (dom_l (wf_swE WF)); basic_solver 10. }
    { rewrite <- inclusion_union_r1.
      eapply (@has_finite_antichains_sb G); eauto. }
    { apply fsupp_sb; auto. }
    eapply fsupp_mori; [| apply fsupp_sw]. red. basic_solver 10.
  Qed.

  Lemma fsupp_furr:
    fsupp (⦗set_compl is_init⦘ ⨾ furr G sc).
  Proof using WF IMMCON FSUPP_SC TB FAIR.
    assert (wf_sc G sc) as WFSC by (apply IMMCON).
    rewrite furr_alt; auto.
    rewrite !crE, !seq_union_l, !seq_union_r.
    rewrite !seq_id_l, !seq_id_r.
    arewrite (hb G ⨾ hb G ⊆ hb G).
    rewrite <- !seqA.
    arewrite ((⦗set_compl (is_init)⦘ ;; ⦗is_w (lab G)⦘) ⨾ rf G ⊆ rf G) by basic_solver 10.
    assert (⦗is_w (lab G)⦘ ⨾ sc ⊆ ∅₂) as AA.
    { rewrite (wf_scD WFSC); type_solver. }
    arewrite (⦗is_w (lab G)⦘ ⨾ sc ⊆ ∅₂); auto.
    arewrite (⦗set_compl (is_init)⦘ ;; ⦗is_w (lab G)⦘ ⨾ sc ⊆ ∅₂).
    { rewrite AA. basic_solver. }
    rewrite <- !seqA.
    arewrite (rf G ⨾ sc ⊆ ∅₂).
    { rewrite (wf_scD WFSC), wf_rfD; auto. type_solver. }
    rewrite seq_false_r, seq_false_l, union_false_l, union_false_r.
    rewrite <- !seqA.
    arewrite ((⦗set_compl is_init⦘ ⨾ ⦗is_w (lab G)⦘) ⨾ hb G ⊆ ⦗set_compl (is_init)⦘ ;; hb G)
      by basic_solver 10.
    assert (fsupp (rf G ⨾ hb G)) as CC.
    { rewrite no_rf_to_init, seqA; auto.
      apply fsupp_seq; auto using fsupp_hb, fsupp_rf. }
    assert (fsupp (sc ⨾ hb G)) as DD.
    { rewrite (no_sc_to_init WF WFSC). rewrite seqA; auto.
      apply fsupp_seq; auto using fsupp_hb. }
    rewrite <- id_inter.
    repeat apply fsupp_union; try by auto using fsupp_rf, fsupp_hb, fsupp_eqv.
    all: try rewrite <- seqA.
    all: apply fsupp_seq; auto using fsupp_rf, fsupp_hb, fsupp_eqv.
  Qed.

End HbFsupp.


Require Import VST.floyd.proofauto.
Require Import malloc.
Require Import malloc_lemmas.
Require Import malloc_sep.
Require Import VSU_malloc_definitions.
Local Open Scope logic.
(*
Definition Gprog : funspecs := external_specs ++ private_specs.
*)

Lemma body_fill_bin: semax_body MF_Vprog MF_Gprog f_fill_bin fill_bin_spec.
Proof.
start_function.
forward_call b.  (*! s = bin2size(b) !*)
set (s:=bin2sizeZ b).
assert (WORD <= s <= bin2sizeZ(BINS-1)) by (pose proof (bin2size_range b); rep_lia).
forward_call BIGBLOCK.  (*! *p = mmap0(BIGBLOCK ...) !*)
(*{ rep_lia. }*)
Intros p.
if_tac in H1. (* split cases on mmap post *)
- (* case p = nullval *)
  forward_if. (*! if p == NULL, case true  !*)
  forward. (*! return NULL !*)
  Exists nullval. Exists 1.
  entailer!. contradiction.
- (* case p <> nullval *)
  assert_PROP (isptr p) by entailer!.
  destruct p; try contradiction.
  rename b0 into pblk; rename i into poff. (* p as blk+ofs *)
  assert_PROP (Ptrofs.unsigned poff + BIGBLOCK < Ptrofs.modulus) by entailer!.
  forward_if; try contradiction. (*! if p == NULL, case false *)
  forward_call((s,(Vptr pblk poff),nullval,0%nat,b)).  (*! t3 = list_from_block(s,p,null) *)
  { unfold mmlist. entailer!. }
  Intro q.
  forward. (*! return t3 *)
  Exists q. Exists (chunks_from_block (size2binZ s)).
  if_tac.
  { (* q = null - contradiction *)
    pose proof (chunks_from_block_pos b H).
    assert (q<>nullval).
    { apply (proj1 H7) in H8.
      rewrite Nat.add_0_r in H8.
      rewrite <- Z2Nat.inj_0 in H8.
      apply Z2Nat.inj in H8; try rep_lia.
      subst s.
      rewrite bin2size2bin_id in *; try rep_lia.
      apply chunks_from_block_nonneg.
    }
    contradiction.
  }
  entailer!.
  assert (Hbs: 0 <= s <= bin2sizeZ(BINS-1)) by rep_lia.
  pose proof (size2bin_range s Hbs) as Hs.
  pose proof (chunks_from_block_pos (size2binZ s) Hs).
  rep_lia.
  rewrite Nat.add_0_r. (* ugh *)
  subst s.
  cancel.
Qed.

(*Definition module := [mk_body body_fill_bin].*)


Require Import SpecCert.Address.
Require Import SpecCert.Cache.
Require Import SpecCert.Formalism.
Require Import SpecCert.Memory.
Require Import SpecCert.Smm.Delta.Behavior.
Require Import SpecCert.Smm.Software.
Require Import SpecCert.x86.

Definition invariant := Architecture Software -> Prop.

Definition smramc_inv
           (a: Architecture Software) :=
  smramc_is_locked (memory_controller a).

Definition smram_code_inv
           (a:    Architecture Software) :=
  forall (addr: PhysicalAddress),
  forall (val:  Value),
  forall (s:    Software),
    is_inside_smram addr
    -> find_memory_content a (dram addr) = (val, s)
    -> s = smm.

Definition smrr_inv
           (a: Architecture Software) :=
  forall (pa: PhysicalAddress),
  is_inside_smram pa
  -> is_inside_smrr (proc a) pa.

Definition cache_clean_inv
           (a:   Architecture Software) :=
  forall (pa:  PhysicalAddress),
  forall (val: Value),
  forall (s:    Software),
    is_inside_smram pa
    -> cache_hit (cache a) pa
    -> find_cache_content a pa = Some (val, s)
    -> s = smm.

Definition ip_inv
           (a: Architecture Software) :=
  smm_context a = smm
  -> is_inside_smram (ip (proc a)).

Definition smbase_inv
           (a: Architecture Software) :=
  is_inside_smram (smbase (proc a)).

Definition inv :=
  fun (a: Architecture Software) =>
    smramc_inv a
    /\ smram_code_inv a
    /\ smrr_inv a
    /\ cache_clean_inv a
    /\ ip_inv a
    /\ smbase_inv a.

Definition partial_preserve
           (ev:   x86Event)
           (prop: Architecture Software -> Prop)
           (i:    Architecture Software -> Prop) :=
  forall h h': Architecture Software,
    inv h
    -> prop h
    -> x86_precondition h ev
    -> x86_postcondition smm_context h ev h'
    -> i h'.

Program Definition software_partial_preserve
        (ev:   { e: x86Event | x86_software e})
        (prop: Architecture Software -> Prop)
        (i:    Architecture Software -> Prop) :=
  forall h h': Architecture Software,
    inv h
    -> prop h
    -> smm_behavior h ev
    -> x86_precondition h ev
    -> x86_postcondition smm_context h ev h'
    -> i h'.

Definition preserve
           (ev: x86Event)
           (i:  Architecture Software -> Prop) :=
  forall h h': Architecture Software,
    inv h
    -> x86_precondition h ev
    -> x86_postcondition smm_context h ev h'
    -> i h'.

Program Definition software_preserve
        (ev: { e: x86Event | x86_software e})
        (i:  Architecture Software -> Prop) :=
  forall h h': Architecture Software,
    inv h
    -> smm_behavior h ev
    -> x86_precondition h ev
    -> x86_postcondition smm_context h ev h'
    -> i h'.

Definition preserve_inv
           (ev: x86Event) :=
  forall h h': Architecture Software,
    inv h
    -> x86_precondition h ev
    -> x86_postcondition smm_context h ev h'
    -> inv h'.

Program Definition software_preserve_inv
        (ev: { e: x86Event | x86_software e}) :=
  forall h h': Architecture Software,
    inv h
    -> smm_behavior h ev
    -> x86_precondition h ev
    -> x86_postcondition smm_context h ev h'
    -> inv h'.

Definition partial_preserve_inv
           (ev:    x86Event)
           (prop:  Architecture Software -> Prop)
  := forall h h': Architecture Software,
    inv h
    -> prop h
    -> x86_precondition h ev
    -> x86_postcondition smm_context h ev h'
    -> inv h'.

Program Definition software_partial_preserve_inv
        (ev:   { e: x86Event | x86_software e})
        (prop: Architecture Software -> Prop)
  := forall h h',
    inv h
    -> prop h
    -> smm_behavior h ev
    -> x86_precondition h ev
    -> x86_postcondition smm_context h ev h'
    -> inv h'.

Ltac intros_preserve :=
  let a := fresh "a" in
  let a' := fresh "a'" in
  let Hsmramc := fresh "Hsmramc" in
  let Hsmram := fresh "Hsmram" in
  let Hsmrr := fresh "Hsmrr" in
  let Hclean := fresh "Hclean" in
  let Hip := fresh "Hip" in
  let Hsmbase := fresh "Hsmbase" in
  let Hpre := fresh "Hpre" in
  let Hpost := fresh "Hpost" in
  intros a a' [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]] Hpre Hpost.

Ltac intros_soft_preserve :=
  let a := fresh "a" in
  let a' := fresh "a'" in
  let Hsmramc := fresh "Hsmramc" in
  let Hsmram := fresh "Hsmram" in
  let Hsmrr := fresh "Hsmrr" in
  let Hclean := fresh "Hclean" in
  let Hip := fresh "Hip" in
  let Hsmbase := fresh "Hsmbase" in
  let Hsmm := fresh "Hsmm" in
  let Hpre := fresh "Hpre" in
  let Hpost := fresh "Hpost" in
  intros a a' [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]] Hsmm Hpre Hpost.

Ltac unfold_inv :=
  unfold inv;
  unfold smramc_inv, smram_code_inv, smrr_inv, cache_clean_inv.

Ltac bully_preserve f1 f2 :=
  unfold preserve_inv;
  unfold_inv;
  intros a a' [Hsmramc [Hsmram [Hsmrr Hclean]]] Hpre Hpost;
  unfold x86_postcondition in Hpost;
  unfold f1 in Hpost;
  unfold f2 in Hpost;
  rewrite Hpost;
  simpl;
  do 3 (try split); trivial.


Require Import Poulet4.P4light.Syntax.P4defs.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import ProD3.core.Core.
Require Import ProD3.core.Tofino.
Require Import ProD3.examples.sbf.p4ast.
Require Import ProD3.examples.sbf.ConFilter.
Require Import ProD3.examples.sbf.common.
Require Import ProD3.examples.sbf.FilterRepr.
Require Import ProD3.examples.sbf.verif_Win1.
Require Import ProD3.examples.sbf.verif_Win2.
Require Import ProD3.examples.sbf.verif_Win3.
Require Import ProD3.examples.sbf.verif_Win4.
Require Import ProD3.examples.sbf.verif_Filter.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_1_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_2_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_3_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_clear_index_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_clear_window_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_1_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_2_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_3_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_4_body) : func_specs.

Definition P4_bf2_win_md_t_insert (f cf if' : Z) (new_clear_index : Sval) (is : list Sval) :=
  if f=? cf then
    P4_bf2_win_md_t (P4Bit 8 CLEAR) (Zrepeat new_clear_index 3)
  else if f=? if' then
    P4_bf2_win_md_t (P4Bit 8 INSERT) is
  else
    P4_bf2_win_md_t (P4Bit 8 NOOP) is.

Definition tbl_set_win_insert_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"];
               ["act_set_clear_win_1"; "api_1"];
               ["act_set_clear_win_1"; "api_2"];
               ["act_set_clear_win_1"; "api_3"];
               ["act_set_clear_win_1"; "api_4"];
               ["act_set_clear_win_2"; "api_1"];
               ["act_set_clear_win_2"; "api_2"];
               ["act_set_clear_win_2"; "api_3"];
               ["act_set_clear_win_2"; "api_4"];
               ["act_set_clear_win_3"; "api_1"];
               ["act_set_clear_win_3"; "api_2"];
               ["act_set_clear_win_3"; "api_3"];
               ["act_set_clear_win_3"; "api_4"];
               ["act_set_clear_win_2"; "api_1"];
               ["act_set_clear_win_4"; "api_1"];
               ["act_set_clear_win_4"; "api_2"];
               ["act_set_clear_win_4"; "api_3"];
               ["act_set_clear_win_4"; "api_4"]]) []
    WITH (timer : Z * bool) (clear_index_1 hash_index_1 hash_index_2 hash_index_3: Sval)
      (H_timer : 0 <= fst timer < frame_tick_tocks * num_frames),
      PRE
        (ARG []
        (MEM [(["api"], P4Bit 8 INSERT);
              (["ds_md"], ValBaseStruct
                 [("clear_window", P4Bit 16 (fst timer));
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("win_1", P4_bf2_win_md_t_);
                  ("win_2", P4_bf2_win_md_t_);
                  ("win_3", P4_bf2_win_md_t_);
                  ("win_4", P4_bf2_win_md_t_)])]
        (EXT [])))
      POST
        (EX retv,
        (ARG_RET [] retv
        (let cf := get_clear_frame timer in
        let if' := get_insert_frame cf in
        (MEM [(["ds_md"], ValBaseStruct
                 [("clear_window", P4Bit 16 (fst timer));
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("win_1", P4_bf2_win_md_t_insert 0 cf if' clear_index_1
                        [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_2", P4_bf2_win_md_t_insert 1 cf if' clear_index_1
                        [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_3", P4_bf2_win_md_t_insert 2 cf if' clear_index_1
                        [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_4", P4_bf2_win_md_t_insert 3 cf if' clear_index_1
                        [hash_index_1; hash_index_2; hash_index_3])])]
        (EXT [])))))%arg_ret_assr.

Lemma tbl_set_win_insert_body :
  func_sound ge tbl_set_win_fd nil tbl_set_win_insert_spec.
Proof.
  start_function; elim_trivial_cases.
  - replace (get_clear_frame timer) with 0. 2 : {
      symmetry; eapply Z_div_squeeze'; eauto.
    }
    table_action act_set_clear_win_1_body.
    { entailer. }
    { entailer. }
  - replace (get_clear_frame timer) with 1. 2 : {
      symmetry; eapply Z_div_squeeze'; eauto.
    }
    table_action act_set_clear_win_2_body.
    { entailer. }
    { entailer. }
  - replace (get_clear_frame timer) with 2. 2 : {
      symmetry; eapply Z_div_squeeze'; eauto.
    }
    table_action act_set_clear_win_3_body.
    { entailer. }
    { entailer. }
  - replace (get_clear_frame timer) with 3. 2 : {
      symmetry; eapply Z_div_squeeze'; eauto.
    }
    table_action act_set_clear_win_4_body.
    { entailer. }
    { entailer. }
  - lia.
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_set_win_insert_body) : func_specs.

Definition filter_insert := @filter_insert num_frames num_rows num_slots H_num_frames H_num_rows H_num_slots
  frame_tick_tocks.

Definition Filter_insert_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD None [p]
    WITH (key : Val) (tstamp : Z) (cf : filter num_frames num_rows num_slots),
      PRE
        (ARG [eval_val_to_sval key; P4Bit 8 INSERT; P4Bit 48 tstamp; P4Bit 8 1]
        (MEM []
        (EXT [filter_repr p index_w panes rows cf])))
      POST
        (ARG_RET [P4Bit 8 1] ValBaseNull
        (MEM []
        (EXT [filter_repr p index_w panes rows (filter_insert cf (Z.odd (tstamp/2097152)) (hashes key))]))).

Lemma Filter_insert_body :
  func_sound ge Filter_fd nil Filter_insert_spec.
Proof.
  Time start_function.
  destruct cf as [[ps ?H] ? ?].
  unfold filter_repr.
  cbn [proj1_sig] in *.
  destruct_list ps.
  normalize_EXT.
  Time step.
  Time step_call tbl_hash_index_1_body.
  { entailer. }
  Intros _.
  step_call tbl_hash_index_2_body.
  { entailer. }
  Time simpl_assertion.
  Intros _.
  step_call tbl_hash_index_3_body.
  { entailer. }
  Time simpl_assertion.
  Intros _.
  set (is := (exist _ [hash1 key; hash2 key; hash3 key] eq_refl : listn Z 3)).
  set (clear_is := (exist _ (Zrepeat fil_clear_index 3) eq_refl : listn Z 3)).
  assert (Forall (fun i : Z => 0 <= i < num_slots) (`is)). {
    repeat first [apply Forall_cons | apply Forall_nil].
    all : unfold hash1, hash2, hash3;
      apply Z.mod_pos_bound; lia.
  }
  P4assert (0 <= fil_clear_index < num_slots). {
    unfold fil_clear_index_repr.
    Intros i'.
    normalize_EXT.
    Intros_prop.
    apply ext_implies_prop_intro.
    subst.
    apply Z.mod_pos_bound.
    lia.
  }
  assert (Forall (fun i : Z => 0 <= i < num_slots) (`clear_is)). {
    repeat first [
      assumption
    | constructor
    ].
  }
  step_call tbl_clear_index_body.
  { entailer. }
  Time simpl_assertion.
  Intros _.
  step_call tbl_clear_window_body.
  { entailer. }
  Intros _.
  set (new_timer := update_timer fil_timer (Z.odd (tstamp / 2097152))).
  (* We need assert_Prop. *)
  P4assert (0 <= fst new_timer < num_frames * frame_tick_tocks).
  { unfold timer_repr.
    normalize_EXT.
    Intros_prop.
    apply ext_implies_prop_intro.
    auto.
  }
  step_call tbl_set_win_insert_body.
  { entailer. }
  { auto. }
  Intros _.
  (* unfold and fold in the post condition *)
  unfold filter_insert, ConFilter.filter_insert.
  unfold proj1_sig.
  fold new_timer.
  replace (exist (fun i : list Z => Zlength i = num_rows) (Zrepeat fil_clear_index num_rows) _) with clear_is. 2 : {
    apply subset_eq_compat. auto.
  }
  assert (0 <= get_clear_frame new_timer < num_frames). {
    unfold ConFilter.get_clear_frame.
    split.
    - apply Z.div_le_lower_bound; lia.
    - apply Z.div_lt_upper_bound; lia.
  }
  destruct (get_clear_frame new_timer =? 0) eqn:?.
  { replace (get_clear_frame new_timer) with 0 by lia.
    step_call verif_Win1.Win_body _ _ clear_is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win2.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win3.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win4.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    simpl Z.eqb. cbn match.
    step_into.
    { hoare_func_table_nondet; elim_trivial_cases.
      table_action NoAction_body.
      { entailer. }
      { apply arg_ret_implies_refl. }
    }
    { reflexivity. }
    { reflexivity. }
    simpl_assertion.
    entailer.
  }
  destruct (get_clear_frame new_timer =? 1) eqn:?.
  { replace (get_clear_frame new_timer) with 1 by lia.
    step_call verif_Win1.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win2.Win_body _ _ clear_is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win3.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win4.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    simpl Z.eqb. cbn match.
    step_into.
    { hoare_func_table_nondet; elim_trivial_cases.
      table_action NoAction_body.
      { entailer. }
      { apply arg_ret_implies_refl. }
    }
    { reflexivity. }
    { reflexivity. }
    simpl_assertion.
    entailer.
  }
  destruct (get_clear_frame new_timer =? 2) eqn:?.
  { replace (get_clear_frame new_timer) with 2 by lia.
    step_call verif_Win1.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win2.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win3.Win_body _ _ clear_is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win4.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    simpl Z.eqb. cbn match.
    step_into.
    { hoare_func_table_nondet; elim_trivial_cases.
      table_action NoAction_body.
      { entailer. }
      { apply arg_ret_implies_refl. }
    }
    { reflexivity. }
    { reflexivity. }
    simpl_assertion.
    entailer.
  }
  destruct (get_clear_frame new_timer =? 3) eqn:?.
  { replace (get_clear_frame new_timer) with 3 by lia.
    step_call verif_Win1.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win2.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win3.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win4.Win_body _ _ clear_is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    simpl Z.eqb. cbn match.
    step_into.
    { hoare_func_table_nondet; elim_trivial_cases.
      table_action NoAction_body.
      { entailer. }
      { apply arg_ret_implies_refl. }
    }
    { reflexivity. }
    { reflexivity. }
    simpl_assertion.
    entailer.
  }
  lia.
Time Qed.


Require Import MetaProp.
Require Import SyntaxProp.
Require Import DynamicProp.
Require Import TypesProp.
Require Import WellFormednessProp.
Require Import Shared.
Require Import Locking.

Hint Constructors is_econtext.
Hint Constructors cfg_blocked.

Tactic Notation "preservation_context_tactic" integer(n) :=
  solve[
      intuition;
         match goal with
           | [IH : forall cfg', _ / ?cfg ==> cfg' -> ?P,
                Hstep : _ / ?cfg ==> _ |- _] =>
             eapply IH in Hstep as (Gamma' & wfCfg' & Hsub);
               eauto;
               inverts wfCfg' as Hfresh' wfH' wfV' wfT';
               inversion wfT'; inversion Hsub;
               exists Gamma'; split; try(eassumption)
         end;
         repeat (econstructor;
                 simpl;
                 eauto n using hasType_subsumption,
                               hasType_subsumption_extend
                          with env); try(omega)
    | eexists; split; eauto with env].

Hint Immediate lt_0_Sn.

Lemma single_threaded_preservation :
  forall P t' Gamma H V n Ls e cfg' t,
    wfProgram P t' ->
    wfConfiguration P Gamma (H, V, n, T_Thread Ls e) t ->
    P / (H, V, n, T_Thread Ls e) ==> cfg' ->
    exists Gamma',
      wfConfiguration P Gamma' cfg' t /\
      wfSubsumption Gamma Gamma'.
Proof with eauto using subtypeOf with env.
  introv wfP wfCfg Hstep.
  inverts wfCfg as Hfresh wfH wfV wfT wfL.
  inverts wfT as Hfree hasType.
  gen cfg'.
  hasType_cases(induction hasType) Case; intros;
  (* Some trivial cases can be discarded*)
  try(inv Hstep; malformed_context);

  (* All variables must be dynamic *)
  match goal with
    | [Hfree : freeVars _ = nil |- _] =>
      simpl in Hfree;
        repeat
        match goal with
          | [Hfree : freeVars _ ++ _ ++ _ = nil |- _] =>
            simpl in Hfree;
              apply app_eq_nil in Hfree as (Hfree1 & Hfree2);
              apply app_eq_nil in Hfree2 as (Hfree2 & Hfree3)
          | [Hfree : freeVars _ ++ _ = nil |- _] =>
            simpl in Hfree;
              apply app_eq_nil in Hfree as (Hfree1 & Hfree2)
          | [x : var |- _] =>
            destruct x; try(congruence)
        end
    | _ => idtac
  end;

  (* Unfold the resulting configuation *)
  destruct cfg' as [[[H' V'] n'] T'];

  (* Assert that the fresh symbols grow monotonically *)
  assert (Hmono: n <= n')
    by eauto using step_n_monotonic;
  try(
  assert (wfL': wfLocking H' T')
    by (eapply wfLocking_preservation in Hstep; eauto)
    ).
  + Case "T_Var".
    inverts Hstep; try malformed_context...
    wfEnvLookup. rewrite_and_invert.
    eexists...
  + Case "T_New".
    inv Hstep; try malformed_context.
    exists (extend Gamma (env_loc (length H)) (TClass c)).
    assert (wfEnv P (extend Gamma (env_loc (length H)) (TClass c)))...
    assert (fresh Gamma (env_loc (length H)))...
    split...
    apply wfConfiguration_substitution
    with (ENew c); eauto using subtypeOf, wfLocking_heapExtend.
    eapply wfConfiguration_heapExtend;
      eauto using wfFields_declsToFields.
  + Case "T_Call".
    assert (wfL'': wfLocking H (T_Thread Ls e))
      by eauto 3 using wfLocking_econtext.
    inv Hstep;
      try(malformed_context); try(inv_eq);
      try(preservation_context_tactic 2).
    - SCase "EvalCall". clear IHhasType2.
      inv hasType1.
      assert(Hsub: subtypeOf P (TClass c) t1)
      by (wfEnvLookup; rewrite_and_invert;
          inv hasType; wfEnvLookup;
          assert (c0 = c) by crush; subst; eauto).
      assert (wfC: wfType P (TClass c))...
      assert (cLookup: classLookup P c <> None)
        by (inv wfC; assumption).
      apply classLookup_not_none in cLookup as (i & fs & ms & cLookup).
      assert (wfCls: wfClassDecl P (Cls c i fs ms))
        by (inv wfP; lookup_forall as wfCls; eauto)...
      assert (mtds = ms)
        by (simpls; destruct classLookup; eauto; inv_eq; inv_eq).
      subst.
      inverts wfCls as Hsigs wfFlds wfMtds.

      assert (wfT2: wfType P t2)...
      assert (sigLookup: methodSigLookup (extractSigs ms) m = Some (MethodSig m (y, t2) t))
        by eauto using methodSigs_sub.
      apply extractSigs_sound in sigLookup as [e mLookup].
      rewrite_and_invert.
      exists (extend
                (extend
                   Gamma (env_var (DV (DVar n))) (TClass c))
                (env_var (DV (DVar (S n)))) t2).
      assert (fresh Gamma (env_var (DV (DVar n))))...
      assert (n <= S n)...
      assert (fresh Gamma (env_var (DV (DVar (S n)))))...
      split...
      * { econstructor; auto.
          + eapply wfHeap_invariance
            with (Gamma := Gamma); eauto 3 with env.
          + eapply wfVars_extend; eauto 2 with env.
            - eapply wfVars_extend...
              apply wfVars_ge with n...
            - eapply hasType_subsumption
              with (Gamma := Gamma);
              eauto 2 using wfSubsumption_fresh with env.
          + lookup_forall as wfMtd.
            inv wfMtd. simpls.
            econstructor...
            - autorewrite with freeVars...
            - eapply hasType_subst; eauto 3 with env.
              eapply hasType_flip...
              eapply hasType_subst; eauto 3 with env.
              eapply hasType_subsumption
              with (Gamma := (extend
                                (extend empty (env_var (SV y)) t2)
                                 (env_var (SV this)) (TClass c)));
                eauto 3 using wfSubsumption_extend with env.
              unfold fresh. case_extend. inv_eq. omega.
        }
  + Case "T_Select".
    inv hasType.
    assert (wfType P t)
      by eauto using fieldLookup_wfType.
    inv Hstep;
      try(malformed_context); try(inv_eq);
      try(preservation_context_tactic 2).
    - SCase "EvalSelect". clear IHhasType.
      wfEnvLookup. rewrite_and_invert.
      inverts hasType as Vlookup envLookup Hsub.
      assert (t2 = TClass c); subst...
      assert (c0 = c)
        by (wfEnvLookup; rewrite_and_invert); subst.
      assert (wfF: exists v, F f = Some v /\
                             P; Gamma |- EVal v \in t)
        by eauto using dyn_wfFieldLookup, wfHeap_wfFields.
      inv wfF as (v' & Flookup & hasType).
      rewrite_and_invert.
      inv wfL.
      eexists. split...
  + Case "T_Update".
    assert (wfL'': wfLocking H (T_Thread Ls e))
      by eauto 3 using wfLocking_econtext.
    inv Hstep;
      try(malformed_context); try(inv_eq);
      try(preservation_context_tactic 2).
    - SCase "EvalUpdate". clear IHhasType1. clear IHhasType2.
      inv hasType1. wfEnvLookup. rewrite_and_invert.
      inv hasType. wfEnvLookup.
      assert (Heq: TClass c1 = TClass c)... inv Heq.
      rewrite_and_invert.
      exists Gamma. split...
      inverts wfL as ? ? wfL.
      inv wfL...
      eapply wfConfiguration_heapUpdate;
        eauto using wfFields_extend, wfHeldLocks_taken;
        crush.
  + Case "T_Let".
    assert (wfL': wfLocking H' T').
      eapply wfLocking_preservation in Hstep...
      econstructor...
      econstructor...
      simpl...
    assert (wfLocking H (T_Thread Ls e))
      by (apply wfLocking_econtext with (ctx := ctx_let x body); eauto).
    inv Hstep;
      try(malformed_context); try(inv_eq);
      try(preservation_context_tactic 2).
    - SCase "EvalLet". clear IHhasType1. clear IHhasType2.
      exists (extend Gamma (env_var (DV (DVar n))) t).
      split...
      * { econstructor; auto.
          + eapply wfHeap_invariance
            with (Gamma := Gamma);
            eauto 2 with env.
          + eapply wfVars_extend...
            eapply wfVars_ge...
          + econstructor;
            eauto using hasType_subst with env;
            autorewrite with freeVars...
        }
      * apply wfSubsumption_fresh...
  + Case "T_Cast".
    assert (wfL'': wfLocking H (T_Thread Ls e))
      by eauto 3 using wfLocking_econtext.
    inv Hstep;
      try(malformed_context); try(inv_eq);
      try(preservation_context_tactic 2).
    - SCase "EvalCast". clear IHhasType.
      exists Gamma. split...
      econstructor...
      econstructor...
      inv hasType...
  + Case "T_Par".
    assert (wfL': wfLocking H' T').
      eapply wfLocking_preservation in Hstep...
      econstructor...
      econstructor...
      simpl... crush.
    inv Hstep; try(malformed_context).
    exists Gamma.
    split...
    econstructor...
    apply wfSubsumption_frame in H0 as []...
    econstructor...
    - econstructor...
      eapply hasType_subsumption with (Gamma := Gamma1)...
    - econstructor...
      eapply hasType_subsumption with (Gamma := Gamma2)...
  + Case "T_Lock".
    inv hasType1.
    wfEnvLookup.
    inv hasType.
    - SCase "V x = l".
      inv Hstep;
      try(malformed_context); try(inv_eq);
      try(preservation_context_tactic 2);
      rewrite_and_invert.
      exists Gamma. split...
      econstructor...
      eapply wfHeap_update...
      eapply wfHeap_wfFields...
    - inv Hstep;
      try(malformed_context); try(inv_eq);
      try(preservation_context_tactic 2);
      rewrite_and_invert.
  + Case "T_Locked".
    inv hasType1.
    assert (wfL'': wfLocking H (T_Thread Ls e))
      by eauto 3 using wfLocking_econtext.
    inv Hstep;
      try(malformed_context); try(inv_eq);
      try(preservation_context_tactic 2).
    - SCase "EvalLock_Release". clear IHhasType1. clear IHhasType2.
      exists Gamma. split...
      econstructor...
      eapply wfHeap_update...
      eapply wfHeap_wfFields...
Qed.

Theorem preservation :
  forall P t' Gamma cfg cfg' t,
    wfProgram P t' ->
    wfConfiguration P Gamma cfg t ->
    P / cfg ==> cfg' ->
    exists Gamma',
      wfConfiguration P Gamma' cfg' t /\
      wfSubsumption Gamma Gamma'.
Proof with eauto using wfConfiguration.
  introv wfP wfCfg Hstep.
  inverts wfCfg as Hfresh wfH wfV wfT wfL.
  gen t cfg' wfL wfT.
  induction T; intros...
  + Case "T = EXN".
    (* EXN does not step *)
    inv Hstep.
  + Case "T = T_Thread e".
    eapply single_threaded_preservation...
  + Case "T = T_Async T1 T2 e".
    inverts wfT as Hfree hasType wfT1 wfT2.
    inverts wfL as wfWl wfRl Hdisj wfL1 wfL2.
    destruct cfg' as [[[H' V'] n'] T'].
    assert (Hmono: n <= n')
      by eauto using step_n_monotonic.
    assert(wfLocking H' T')
      by eauto using wfLocking_preservation.
    inv Hstep;
    try(
        solve
          [
            (* When no thread steps, Gamma still types the cfg *)
            exists Gamma; split; eauto with env
          |
            (* When one of the threads step, IH applies *)
            match goal with
              | [IH: forall t cfg', _ / (_, _, _, ?T) ==> cfg' -> _,
                   Hstep: _ / (_, _, _, ?T) ==> _ |- _]
                => eapply IH in Hstep as [Gamma' [wfCfg' wfSub]];
                  eauto; inverts wfCfg'; exists Gamma'
            end;
            split; eauto;
            econstructor; eauto with arith;
            econstructor;
            eauto using hasType_subsumption,
                        wfThreads_subsumption
          ]).
Qed.


(* ** Imports and settings *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import word_ssrZ.
Require Import strings word utils type var expr.
Require Import compiler_util byteset.
Require Import ZArith.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope vmap.
Local Open Scope seq_scope.

Module Import E.

  Definition pass : string := "stack allocation".

  Definition stk_error_gen (internal:bool) (x:var_i) msg := {|
    pel_msg := msg;
    pel_fn := None;
    pel_fi := None;
    pel_ii := None;
    pel_vi := Some x.(v_info);
    pel_pass := Some pass;
    pel_internal := internal
  |}.

  Definition stk_error  := stk_error_gen false.
  Definition stk_ierror := stk_error_gen true.

  Definition stk_ierror_basic x msg :=
    stk_ierror x (pp_box [:: pp_s msg; pp_nobox [:: pp_s "("; pp_var x; pp_s ")"]]).

  Definition stk_error_no_var_gen (internal:bool) msg := {|
    pel_msg := pp_s msg;
    pel_fn := None;
    pel_fi := None;
    pel_ii := None;
    pel_vi := None;
    pel_pass := Some pass;
    pel_internal := internal
  |}.

  Definition stk_error_no_var  := stk_error_no_var_gen false.
  Definition stk_ierror_no_var := stk_error_no_var_gen true.

End E.

(* TODO: could [wsize_size] return a [positive] rather than a [Z]?
   If so, [size_of] could return a positive too.
*)
Definition size_of (t:stype) :=
  match t with
  | sword sz => wsize_size sz
  | sarr n   => Zpos n
  | sbool | sint => 1%Z
  end.

Definition slot := var.

Notation size_slot s := (size_of s.(vtype)).

Record region :=
  { r_slot : slot;        (* the name of the region        *)
      (* the size of the region is encoded in the type of [r_slot] *)
    r_align : wsize;      (* the alignment of the region   *)
    r_writable : bool;    (* the region is writable or not *)
  }.

Definition region_beq (r1 r2:region) :=
  [&& r1.(r_slot)     == r2.(r_slot),
      r1.(r_align)    == r2.(r_align) &
      r1.(r_writable) == r2.(r_writable)].

Definition region_same (r1 r2:region) :=
  (r1.(r_slot) == r2.(r_slot)).

Lemma region_axiom : Equality.axiom region_beq.
Proof.
  rewrite /region_beq => -[xs1 xa1 xw1] [xs2 xa2 xw2].
  by apply:(iffP and3P) => /= [[/eqP -> /eqP -> /eqP ->] | [-> -> ->]].
Qed.

Definition region_eqMixin := Equality.Mixin region_axiom.
Canonical  region_eqType  := Eval hnf in EqType region region_eqMixin.

Module CmpR.

  Definition t := [eqType of region].

  Definition cmp (r1 r2: t) :=
    Lex (bool_cmp r1.(r_writable) r2.(r_writable))
     (Lex (wsize_cmp r1.(r_align) r2.(r_align))
          (var_cmp r1.(r_slot) r2.(r_slot))).

#[global]
  Instance cmpO : Cmp cmp.
  Proof.
    constructor => [x y | y x z c | [???] [???]]; rewrite /cmp !Lex_lex.
    + by repeat (apply lex_sym; first by apply cmp_sym); apply cmp_sym.
    + by repeat (apply lex_trans=> /=; first by apply cmp_ctrans); apply cmp_ctrans.
    move=> /lex_eq [] /= h1 /lex_eq [] /= h2 h3.
    by rewrite (cmp_eq h1) (cmp_eq h2) (cmp_eq h3).
  Qed.

End CmpR.

Module Mr := Mmake CmpR.

(* ------------------------------------------------------------------ *)
Record zone := {
  z_ofs : Z;
  z_len : Z;
}.

Scheme Equality for zone.

Lemma zone_eq_axiom : Equality.axiom zone_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_zone_dec_bl.
  by apply: internal_zone_dec_lb.
Qed.

Definition zone_eqMixin := Equality.Mixin zone_eq_axiom.
Canonical  zone_eqType  := EqType zone zone_eqMixin.

Definition disjoint_zones z1 z2 :=
  (((z1.(z_ofs) + z1.(z_len))%Z <= z2.(z_ofs)) ||
   ((z2.(z_ofs) + z2.(z_len))%Z <= z1.(z_ofs)))%CMP.

(* ------------------------------------------------------------------ *)
(* A zone inside a region. *)
Record sub_region := {
    sr_region : region;
    sr_zone  : zone;
  }.

Definition sub_region_beq sr1 sr2 :=
  (sr1.(sr_region) == sr2.(sr_region)) && (sr1.(sr_zone) == sr2.(sr_zone)).

Lemma sub_region_eq_axiom : Equality.axiom sub_region_beq.
Proof.
  rewrite /sub_region_beq => -[mp1 sub1] [mp2 sub2].
  by apply:(iffP andP) => /= [[/eqP -> /eqP ->] | [-> ->]].
Qed.

Definition sub_region_eqMixin := Equality.Mixin sub_region_eq_axiom.
Canonical sub_region_eqType := EqType sub_region sub_region_eqMixin.

(* ------------------------------------------------------------------ *)
(* idea: could we use a gvar instead of var & v_scope? *)
Variant ptr_kind_init :=
| PIdirect of var & zone & v_scope
| PIregptr of var
| PIstkptr of var & zone & var.

Variant ptr_kind :=
| Pdirect of var & Z & wsize & zone & v_scope
| Pregptr of var
| Pstkptr of var & Z & wsize & zone & var.

Record param_info := {
  pp_ptr      : var;
  pp_writable : bool;
  pp_align    : wsize;
}.

Record pos_map := {
  vrip    : var;
  vrsp    : var;
  vxlen   : var;
  globals : Mvar.t (Z * wsize);
  locals  : Mvar.t ptr_kind;
  vnew    : Sv.t;
}.

(* TODO: Z.land or is_align ?
   Could be just is_align (sub_region_addr sr) ws ? *)
Definition check_align x (sr:sub_region) ws :=
  Let _ := assert (ws <= sr.(sr_region).(r_align))%CMP
                  (stk_ierror_basic x "unaligned offset") in
  assert (Z.land sr.(sr_zone).(z_ofs) (wsize_size ws - 1) == 0)%Z
         (stk_ierror_basic x "unaligned sub offset").

Definition writable (x:var_i) (r:region) :=
  assert r.(r_writable)
    (stk_error x (pp_box [:: pp_s "cannot write to the constant pointer"; pp_var x; pp_s "targetting"; pp_var r.(r_slot) ])).

Module Region.

Definition bytes_map := Mvar.t ByteSet.t.

Record region_map := {
  var_region : Mvar.t sub_region; (* The region where the value is initialy stored            *)
  region_var :> Mr.t bytes_map;     (* The set of source variables whose value is in the region *)
    (* region -> var -> ByteSet.t *)
}.

Definition empty_bytes_map := Mvar.empty ByteSet.t.

Definition empty := {|
  var_region := Mvar.empty _;
  region_var := Mr.empty bytes_map;
|}.

Definition get_sub_region (rmap:region_map) (x:var_i) :=
  match Mvar.get rmap.(var_region) x with
  | Some sr => ok sr
  | None => Error (stk_error x (pp_box [:: pp_s "no region associated to variable"; pp_var x]))
  end.

Definition get_bytes_map (r:region) rv : bytes_map :=
  odflt empty_bytes_map (Mr.get rv r).

Definition get_bytes (x:var) (bytes_map:bytes_map) :=
  odflt ByteSet.empty (Mvar.get bytes_map x).

Definition interval_of_zone z :=
  {| imin := z.(z_ofs); imax := z.(z_ofs) + z.(z_len) |}.

Definition get_var_bytes rv r x :=
  let bm := get_bytes_map r rv in
  let bytes := get_bytes x bm in
  bytes.

(* Returns the sub-zone of [z] starting at offset [ofs] and of length [len].
   The offset [z] can be None, meaning its exact value is not known. In this
   case, the full zone [z] is returned. This is a safe approximation.
*)
Definition sub_zone_at_ofs z ofs len :=
  match ofs with
  | None => z
  | Some ofs => {| z_ofs := z.(z_ofs) + ofs; z_len := len |}
  end.

Definition sub_region_at_ofs sr ofs len :=
  {| sr_region := sr.(sr_region);
     sr_zone   := sub_zone_at_ofs sr.(sr_zone) ofs len
  |}.

Definition check_valid (rmap:region_map) (x:var_i) ofs len :=
  (* we get the bytes associated to variable [x] *)
  Let sr := get_sub_region rmap x in
  let bytes := get_var_bytes rmap sr.(sr_region) x in
  let sr' := sub_region_at_ofs sr ofs len in
  let isub_ofs := interval_of_zone sr'.(sr_zone) in
  (* we check if [isub_ofs] is a subset of one of the intervals of [bytes] *)
  Let _   := assert (ByteSet.mem bytes isub_ofs)
                    (stk_error x (pp_box [:: pp_s "the region associated to variable"; pp_var x; pp_s "is partial"])) in
  ok (sr, sr').

Definition clear_bytes i bytes := ByteSet.remove bytes i.
(* TODO: check optim
  let bytes := ByteSet.remove bytes i in
  if ByteSet.is_empty bytes then None else Some bytes.
*)

Definition clear_bytes_map i (bm:bytes_map) :=
  Mvar.map (clear_bytes i) bm.
(* TODO: if optim above, optim below
  let bm := Mvar.filter_map (clear_bytes i) bm in
  if Mvar.is_empty bm then None else Some bm.
*)

(* TODO: take [bytes] as an argument ? *)
Definition set_pure_bytes rv (x:var) sr ofs len :=
  let z     := sr.(sr_zone) in
  let z1    := sub_zone_at_ofs z ofs len in
  let i     := interval_of_zone z1 in
  let bm    := get_bytes_map sr.(sr_region) rv in
  let bytes := if ofs is Some _ then ByteSet.add i (get_bytes x bm)
               else get_bytes x bm
  in
  (* clear all bytes corresponding to z1 *)
  let bm := clear_bytes_map i bm in
  (* set the bytes *)
  let bm := Mvar.set bm x bytes in
  Mr.set rv sr.(sr_region) bm.

Definition set_bytes rv (x:var_i) sr (ofs : option Z) (len : Z) :=
  Let _     := writable x sr.(sr_region) in
  ok (set_pure_bytes rv x sr ofs len).

(* TODO: as many functions are similar, maybe we could have one big function
   taking flags as arguments that tell whether we have to check align/check valid... *)
Definition set_sub_region rmap (x:var_i) sr (ofs : option Z) (len : Z) :=
  Let rv := set_bytes rmap x sr ofs len in
  ok {| var_region := Mvar.set rmap.(var_region) x sr;
        region_var := rv |}.

Definition sub_region_stkptr s ws z :=
  let r := {| r_slot := s; r_align := ws; r_writable := true |} in
  {| sr_region := r; sr_zone := z |}.

Section WITH_POINTER_DATA.
Context {pd: PointerData}.

Definition set_stack_ptr (rmap:region_map) s ws z (x':var) :=
  let sr := sub_region_stkptr s ws z in
  let rv := set_pure_bytes rmap x' sr (Some 0)%Z (wsize_size Uptr) in
  {| var_region := rmap.(var_region);
     region_var := rv |}.

(* TODO: fusion with check_valid ? *)
Definition check_stack_ptr rmap s ws z x' :=
  let sr := sub_region_stkptr s ws z in
  let z := sub_zone_at_ofs z (Some 0)%Z (wsize_size Uptr) in
  let i := interval_of_zone z in
  let bytes := get_var_bytes rmap sr.(sr_region) x' in
  ByteSet.mem bytes i.

End WITH_POINTER_DATA.

(* Precondition size_of x = ws && length sr.sr_zone = wsize_size ws *)
Definition set_word rmap (x:var_i) sr ws :=
  Let _ := check_align x sr ws in
  set_sub_region rmap x sr (Some 0)%Z (size_slot x).

(* If we write to array [x] at offset [ofs], we invalidate the corresponding
   memory zone for the other variables, and mark it as valid for [x].
   The offset [ofs] can be None, meaning its exact value is not known. In this
   case, the full zone [z] associated to array [x] is invalidated for the
   other variables, and remains the zone associated to [x]. It is a safe
   approximation.
*)
(* [set_word], [set_stack_ptr] and [set_arr_word] could be factorized? -> think more about it *)
Definition set_arr_word (rmap:region_map) (x:var_i) ofs ws :=
  Let sr := get_sub_region rmap x in
  Let _ := check_align x sr ws in
  set_sub_region rmap x sr ofs (wsize_size ws).

Definition set_arr_call rmap x sr := set_sub_region rmap x sr (Some 0)%Z (size_slot x).

Definition set_move_bytes rv x sr :=
  let bm := get_bytes_map sr.(sr_region) rv in
  let bytes := get_bytes x bm in
  let bm := Mvar.set bm x (ByteSet.add (interval_of_zone sr.(sr_zone)) bytes) in
  Mr.set rv sr.(sr_region) bm.

Definition set_move_sub (rmap:region_map) x sr :=
  let rv := set_move_bytes rmap x sr in
  {| var_region := rmap.(var_region);
     region_var := rv |}.

Definition set_arr_sub (rmap:region_map) (x:var_i) ofs len sr_from :=
  Let sr := get_sub_region rmap x in
  let sr' := sub_region_at_ofs sr (Some ofs) len in
  Let _ := assert (sr' == sr_from)
                  (stk_ierror x
                    (pp_box [::
                      pp_s "the assignment to sub-array"; pp_var x;
                      pp_s "cannot be turned into a nop: source and destination regions are not equal"]))
  in
  ok (set_move_sub rmap x sr').

(* identical to [set_sub_region], except clearing
   TODO: fusion with set_arr_sub ? not sure its worth
*)
Definition set_move (rmap:region_map) (x:var) sr :=
  let rv := set_move_bytes rmap x sr in
  {| var_region := Mvar.set rmap.(var_region) x sr;
     region_var := rv |}.

Definition set_arr_init rmap x sr := set_move rmap x sr.

Definition incl_bytes_map (_r: region) (bm1 bm2: bytes_map) :=
  Mvar.incl (fun x => ByteSet.subset) bm1 bm2.

Definition incl (rmap1 rmap2:region_map) :=
  Mvar.incl (fun x r1 r2 => r1 == r2) rmap1.(var_region) rmap2.(var_region) &&
  Mr.incl incl_bytes_map rmap1.(region_var) rmap2.(region_var).

Definition merge_bytes (x:var) (bytes1 bytes2: option ByteSet.t) :=
  match bytes1, bytes2 with
  | Some bytes1, Some bytes2 =>
    let bytes := ByteSet.inter bytes1 bytes2 in
    if ByteSet.is_empty bytes then None
    else Some bytes
  | _, _ => None
  end.

Definition merge_bytes_map (_r:region) (bm1 bm2: option bytes_map) :=
  match bm1, bm2 with
  | Some bm1, Some bm2 =>
    let bm := Mvar.map2 merge_bytes bm1 bm2 in
    if Mvar.is_empty bm then None
    else Some bm
  | _, _ => None
  end.

Definition merge (rmap1 rmap2:region_map) :=
  {| var_region :=
       Mvar.map2 (fun _ osr1 osr2 =>
        match osr1, osr2 with
        | Some sr1, Some sr2 => if sr1 == sr2 then osr1 else None
        | _, _ => None
        end) rmap1.(var_region) rmap2.(var_region);
     region_var := Mr.map2 merge_bytes_map rmap1.(region_var) rmap2.(region_var) |}.

End Region.

Import Region.

Section ASM_OP.
Context {pd: PointerData}.
Context `{asmop:asmOp}.

Definition mul := Papp2 (Omul (Op_w Uptr)).
Definition add := Papp2 (Oadd (Op_w Uptr)).

Definition mk_ofs aa ws e1 ofs :=
  let sz := mk_scale aa ws in
  if is_const e1 is Some i then
    cast_const (i * sz + ofs)%Z
  else
    add (mul (cast_const sz) (cast_ptr e1)) (cast_const ofs).

Definition mk_ofsi aa ws e1 :=
  if is_const e1 is Some i then Some (i * (mk_scale aa ws))%Z
  else None.

Section CHECK.

(* The code in this file is called twice.
   - First, it is called from the stack alloc OCaml oracle. Indeed, the oracle
     returns initial results, and performs stack and reg allocation using
     these results. Based on the program that it obtains,
     it fixes some of the results and returns them.
   - Second, it is called as a normal compilation pass on the results returned
     by the oracle.

   When the code is called from the OCaml oracle, all the checks
   that are performed so that the pass can be proved correct are actually not
   needed. We introduce this boolen [check] to deactivate some of the tests
   when the code is called from the oracle.

   TODO: deactivate more tests (or even do not use rmap) when [check] is [false]
*)
Variable (check : bool).

Definition assert_check E b (e:E) :=
  if check then assert b e
  else ok tt.

Variant vptr_kind :=
  | VKglob of Z * wsize
  | VKptr  of ptr_kind.

Definition var_kind := option vptr_kind.

Record stack_alloc_params :=
  {
    (* Return an instruction that computes an address from an base address and
     an offset. *)
    sap_mov_ofs :
      lval            (* The variable to save the address to. *)
      -> assgn_tag    (* The tag present in the source. *)
      -> vptr_kind    (* The kind of address to compute. *)
      -> pexpr        (* Variable with base address. *)
      -> Z            (* Offset. *)
      -> option instr_r;
  }.

Context
  (saparams : stack_alloc_params).

Section Section.

Variables (pmap:pos_map).

Section ALLOC_E.

Variables (rmap: region_map).

Definition get_global (x:var_i) :=
  match Mvar.get pmap.(globals) x with
  | None => Error (stk_ierror_basic x "unallocated global variable")
  | Some z => ok z
  end.

Definition get_local (x:var) := Mvar.get pmap.(locals) x.

Definition check_diff (x:var_i) :=
  if Sv.mem x pmap.(vnew) then
    Error (stk_ierror_basic x "the code writes to one of the new variables")
  else ok tt.

Definition check_var (x:var_i) :=
  match get_local x with
  | None => ok tt
  | Some _ =>
    Error (stk_error x (pp_box [::
      pp_var x; pp_s "is a stack variable, but a reg variable is expected"]))
  end.

Definition with_var xi x :=
  {| v_var := x; v_info := xi.(v_info) |}.

Definition base_ptr sc :=
  match sc with
  | Slocal => pmap.(vrsp)
  | Sglobal => pmap.(vrip)
  end.

Definition addr_from_pk (x:var_i) (pk:ptr_kind) :=
  match pk with
  | Pdirect _ ofs _ z sc => ok (with_var x (base_ptr sc), ofs + z.(z_ofs))
  | Pregptr p            => ok (with_var x p,             0)
  | Pstkptr _ _ _ _ _    =>
    Error (stk_error x (pp_box [::
      pp_var x; pp_s "is a stack pointer, it should not appear in an expression"]))
  end%Z.

Definition addr_from_vpk x (vpk:vptr_kind) :=
  match vpk with
  | VKglob zws => ok (with_var x pmap.(vrip), zws.1)
  | VKptr pk => addr_from_pk x pk
  end.

Definition mk_addr_ptr x aa ws (pk:ptr_kind) (e1:pexpr) :=
  Let xofs := addr_from_pk x pk in
  ok (xofs.1, mk_ofs aa ws e1 xofs.2).

Definition mk_addr x aa ws (vpk:vptr_kind) (e1:pexpr) :=
  Let xofs := addr_from_vpk x vpk in
  ok (xofs.1, mk_ofs aa ws e1 xofs.2).

Definition get_var_kind x :=
  let xv := x.(gv) in
  if is_glob x then
    Let z := get_global xv in
    ok (Some (VKglob z))
  else
    ok (omap VKptr (get_local xv)).

Definition sub_region_full x r :=
  let z := {| z_ofs := 0; z_len := size_slot x |} in
  {| sr_region := r; sr_zone := z |}.

Definition sub_region_glob x ws :=
  let r := {| r_slot := x; r_align := ws; r_writable := false |} in
  sub_region_full x r.

Definition check_vpk rmap (x:var_i) vpk ofs len :=
  match vpk with
  | VKglob (_, ws) =>
    let sr := sub_region_glob x ws in
    ok (sr, sub_region_at_ofs sr ofs len)
  | VKptr _pk =>
    check_valid rmap x ofs len
  end.

(* We could write [check_vpk] as follows.
  Definition check_vpk' rmap (x : gvar) ofs len :=
    let (sr, bytes) := check_gvalid rmap x in
    let sr' := sub_region_at_ofs sr.(sr_zone) ofs len in
    let isub_ofs := interval_of_zone sr'.(sr_zone) in
    (* we check if [isub_ofs] is a subset of one of the intervals of [bytes] *)
    (* useless test when [x] is glob, but factorizes call to [sub_region_at_ofs] *)
    Let _   := assert (ByteSet.mem bytes isub_ofs)
                      (Cerr_stk_alloc "check_valid: the region is partial") in
    ok sr'.
*)

Definition check_vpk_word rmap x vpk ofs ws :=
  Let srs := check_vpk rmap x vpk ofs (wsize_size ws) in
  check_align x srs.1 ws.

Fixpoint alloc_e (e:pexpr) :=
  match e with
  | Pconst _ | Pbool _ | Parr_init _ => ok e
  | Pvar   x =>
    let xv := x.(gv) in
    Let vk := get_var_kind x in
    match vk with
    | None => Let _ := check_diff xv in ok e
    | Some vpk =>
      if is_word_type (vtype xv) is Some ws then
        Let _ := check_vpk_word rmap xv vpk (Some 0%Z) ws in
        Let pofs := mk_addr xv AAdirect ws vpk (Pconst 0) in
        ok (Pload ws pofs.1 pofs.2)
      else Error (stk_ierror_basic xv "not a word variable in expression")
    end

  | Pget aa ws x e1 =>
    let xv := x.(gv) in
    Let e1 := alloc_e e1 in
    Let vk := get_var_kind x in
    match vk with
    | None => Let _ := check_diff xv in ok (Pget aa ws x e1)
    | Some vpk =>
      let ofs := mk_ofsi aa ws e1 in
      Let _ := check_vpk_word rmap xv vpk ofs ws in
      Let pofs := mk_addr xv aa ws vpk e1 in
      ok (Pload ws pofs.1 pofs.2)
    end

  | Psub aa ws len x e1 =>
    Error (stk_ierror_basic x.(gv) "Psub")

  | Pload ws x e1 =>
    Let _ := check_var x in
    Let _ := check_diff x in
    Let e1 := alloc_e e1 in
    ok (Pload ws x e1)

  | Papp1 o e1 =>
    Let e1 := alloc_e e1 in
    ok (Papp1 o e1)

  | Papp2 o e1 e2 =>
    Let e1 := alloc_e e1 in
    Let e2 := alloc_e e2 in
    ok (Papp2 o e1 e2)

  | PappN o es =>
    Let es := mapM alloc_e es in
    ok (PappN o es)

  | Pif t e e1 e2 =>
    Let e := alloc_e e in
    Let e1 := alloc_e e1 in
    Let e2 := alloc_e e2 in
    ok (Pif t e e1 e2)
  end.

  Definition alloc_es := mapM alloc_e.

End ALLOC_E.

Definition sub_region_direct x align sc z :=
  let r := {| r_slot := x; r_align := align; r_writable := sc != Sglob |} in
  {| sr_region := r; sr_zone := z |}.

Definition sub_region_stack x align z :=
  sub_region_direct x align Slocal z.

Definition sub_region_pk x pk :=
  match pk with
  | Pdirect x ofs align sub Slocal => ok (sub_region_stack x align sub)
  | _ => Error (stk_ierror x (pp_box [:: pp_var x; pp_s "is not in the stack"]))
  end.

Definition alloc_lval (rmap: region_map) (r:lval) (ty:stype) :=
  match r with
  | Lnone _ _ => ok (rmap, r)

  | Lvar x =>
    (* TODO: could we remove this [check_diff] and use an invariant in the proof instead? *)
    match get_local x with
    | None => Let _ := check_diff x in ok (rmap, r)
    | Some pk =>
      if is_word_type (vtype x) is Some ws then
        if subtype (sword ws) ty then
          Let pofs := mk_addr_ptr x AAdirect ws pk (Pconst 0) in
          Let sr   := sub_region_pk x pk in
          let r := Lmem ws pofs.1 pofs.2 in
          Let rmap := Region.set_word rmap x sr ws in
          ok (rmap, r)
        else Error (stk_ierror_basic x "invalid type for assignment")
      else Error (stk_ierror_basic x "not a word variable in assignment")
    end

  | Laset aa ws x e1 =>
    (* TODO: could we remove this [check_diff] and use an invariant in the proof instead? *)
    Let e1 := alloc_e rmap e1 in
    match get_local x with
    | None => Let _ := check_diff x in ok (rmap, Laset aa ws x e1)
    | Some pk =>
      let ofs := mk_ofsi aa ws e1 in
      Let rmap := set_arr_word rmap x ofs ws in
      Let pofs := mk_addr_ptr x aa ws pk e1 in
      let r := Lmem ws pofs.1 pofs.2 in
      ok (rmap, r)
    end

  | Lasub aa ws len x e1 =>
    Error (stk_ierror_basic x "Lasub")

  | Lmem ws x e1 =>
    Let _ := check_var x in
    Let _ := check_diff x in
    Let e1 := alloc_e rmap e1 in
    ok (rmap, Lmem ws x e1)
  end.

Definition nop := Copn [::] AT_none Onop [::].

(* [is_spilling] is used for stack pointers. *)
Definition is_nop is_spilling rmap (x:var) (sry:sub_region) : bool :=
  if is_spilling is Some (s, ws, z, f) then
    if Mvar.get rmap.(var_region) x is Some srx then
      (srx == sry) && check_stack_ptr rmap s ws z f
    else false
  else false.

(* TODO: better error message *)
Definition get_addr is_spilling rmap x dx tag sry vpk y ofs :=
  let ir := if is_nop is_spilling rmap x sry
            then Some nop
            else sap_mov_ofs saparams dx tag vpk y ofs in
  let rmap := Region.set_move rmap x sry in
  (rmap, ir).

Definition get_ofs_sub aa ws x e1 :=
  match mk_ofsi aa ws e1 with
  | None     => Error (stk_ierror_basic x "cannot take/set a subarray on a unknown starting position")
  | Some ofs => ok ofs
  end.

Definition get_Lvar_sub lv :=
  match lv with
  | Lvar x => ok (x, None)
  | Lasub aa ws len x e1 =>
    Let ofs := get_ofs_sub aa ws x e1 in
    ok (x, Some (ofs, arr_size ws len))
  | _      => Error (stk_ierror_no_var "get_Lvar_sub: variable/subarray expected")
  end.

Definition get_Pvar_sub e :=
  match e with
  | Pvar x => ok (x, None)
  | Psub aa ws len x e1 =>
    Let ofs := get_ofs_sub aa ws x.(gv) e1 in
    ok (x, Some (ofs, arr_size ws len))
  | _      => Error (stk_ierror_no_var "get_Pvar_sub: variable/subarray expected")
  end.

Definition is_stack_ptr vpk :=
  match vpk with
  | VKptr (Pstkptr s ofs ws z f) => Some (s, ofs, ws, z, f)
  | _ => None
  end.

(* Not so elegant: function [addr_from_vpk] can fail, but it
   actually fails only on the [Pstkptr] case, that is treated apart.
   Thus function [mk_addr_pexpr] never fails, but this is not checked statically.
*)
Definition mk_addr_pexpr rmap x vpk :=
  if is_stack_ptr vpk is Some (s, ofs, ws, z, f) then
    Let _   := assert (check_stack_ptr rmap s ws z f)
                      (stk_error x (pp_box [:: pp_s "the stack pointer"; pp_var x; pp_s "is no longer valid"])) in
    ok (Pload Uptr (with_var x pmap.(vrsp)) (cast_const (ofs + z.(z_ofs))), 0%Z)
  else
    Let xofs := addr_from_vpk x vpk in
    ok (Plvar xofs.1, xofs.2).

(* TODO: the check [is_lvar] was removed, was it really on purpose? *)
(* TODO : currently, we check that the source array is valid and set the target
   array as valid too. We could, instead, give the same validity to the target
   array as the source one.
   [check_vpk] should be replaced with some function returning the valid bytes
   of y...
*)
(* Precondition is_sarr ty *)
Definition alloc_array_move rmap r tag e :=
  Let xsub := get_Lvar_sub r in
  Let ysub := get_Pvar_sub e in
  let '(x,subx) := xsub in
  let '(y,suby) := ysub in

  Let sryl :=
    let vy := y.(gv) in
    Let vk := get_var_kind y in
    let (ofs, len) :=
      match suby with
      | None => (0%Z, size_slot vy)
      | Some p => p
      end
    in
    match vk with
    | None => Error (stk_ierror_basic vy "register array remains")
    | Some vpk =>
      Let srs := check_vpk rmap vy vpk (Some ofs) len in
      let sry := srs.2 in
      Let eofs := mk_addr_pexpr rmap vy vpk in
      ok (sry, vpk, eofs.1, (eofs.2 + ofs)%Z)
    end
  in
  let '(sry, vpk, ey, ofs) := sryl in
  match subx with
  | None =>
    match get_local (v_var x) with
    | None    => Error (stk_ierror_basic x "register array remains")
    | Some pk =>
      match pk with
      | Pdirect s _ ws zx sc =>
        let sr := sub_region_direct s ws sc zx in
        Let _  :=
          assert (sr == sry)
                 (stk_ierror x
                    (pp_box [::
                      pp_s "the assignment to array"; pp_var x;
                      pp_s "cannot be turned into a nop: source and destination regions are not equal"]))
        in
        let rmap := Region.set_move rmap x sry in
        ok (rmap, nop)
      | Pregptr p =>
        let (rmap, oir) :=
            get_addr None rmap x (Lvar (with_var x p)) tag sry vpk ey ofs in
        match oir with
        | None =>
          let err_pp := pp_box [:: pp_s "cannot compute address"; pp_var x] in
          Error (stk_error x err_pp)
        | Some ir =>
          ok (rmap, ir)
        end
      | Pstkptr slot ofsx ws z x' =>
        let is_spilling := Some (slot, ws, z, x') in
        let dx_ofs := cast_const (ofsx + z.(z_ofs)) in
        let dx := Lmem Uptr (with_var x pmap.(vrsp)) dx_ofs in
        let (rmap, oir) := get_addr is_spilling rmap x dx tag sry vpk ey ofs in
        match oir with
        | None =>
          let err_pp := pp_box [:: pp_s "cannot compute address"; pp_var x] in
          Error (stk_error x err_pp)
        | Some ir =>
          ok (Region.set_stack_ptr rmap slot ws z x', ir)
        end
      end
    end
  | Some (ofs, len) =>
    match get_local (v_var x) with
    | None   => Error (stk_ierror_basic x "register array remains")
    | Some _ =>
      Let rmap := Region.set_arr_sub rmap x ofs len sry in
      ok (rmap, nop)
    end
  end.

(* This function is also defined in array_init.v *)
(* TODO: clean *)
Definition is_array_init e :=
  match e with
  | Parr_init _ => true
  | _ => false
  end.

(* We do not update the [var_region] part *)
(* there seems to be an invariant: all Pdirect are in the rmap *)
(* long-term TODO: we can avoid putting PDirect in the rmap (look in pmap instead) *)
Definition alloc_array_move_init rmap r tag e :=
  if is_array_init e then
    Let xsub := get_Lvar_sub r in
    let '(x,subx) := xsub in
    let (ofs, len) :=
      match subx with
      | None => (0%Z, size_slot (v_var x))
      | Some p => p
      end in
    Let sr :=
      match get_local (v_var x) with
      | None    => Error (stk_ierror_basic x "register array remains")
      | Some pk =>
        match pk with
        | Pdirect x' _ ws z sc =>
          if sc is Slocal then
            ok (sub_region_stack x' ws z)
          else
            Error (stk_error x (pp_box [:: pp_s "cannot initialize glob array"; pp_var x]))
        | _ =>
          get_sub_region rmap x
        end
      end in
    let sr := sub_region_at_ofs sr (Some ofs) len in
    let rmap := Region.set_move_sub rmap x sr in
    ok (rmap, nop)
  else alloc_array_move rmap r tag e.

Definition bad_lval_number := stk_ierror_no_var "invalid number of lval".

Definition alloc_lvals rmap rs tys :=
  fmapM2 bad_lval_number alloc_lval rmap rs tys.

Section LOOP.

 Variable ii:instr_info.

 Variable check_c2 : region_map -> cexec ((region_map * region_map) * (pexpr * (seq cmd * seq cmd)) ).

 Fixpoint loop2 (n:nat) (m:region_map) :=
    match n with
    | O => Error (pp_at_ii ii (stk_ierror_no_var "loop2"))
    | S n =>
      Let m' := check_c2 m in
      if incl m m'.1.2 then ok (m'.1.1, m'.2)
      else loop2 n (merge m m'.1.2)
    end.

End LOOP.

Record stk_alloc_oracle_t :=
  { sao_align : wsize
  ; sao_size: Z
  ; sao_ioff: Z
  ; sao_extra_size: Z
  ; sao_max_size : Z
  ; sao_max_call_depth : Z
  ; sao_params : seq (option param_info)  (* Allocation of pointer params *)
  ; sao_return : seq (option nat)         (* Where to find the param input region *)
  ; sao_slots : seq (var * wsize * Z)
  ; sao_alloc: seq (var * ptr_kind_init)   (* Allocation of local variables without params, and stk ptr *)
  ; sao_to_save: seq (var * Z)
  ; sao_rsp: saved_stack
  ; sao_return_address: return_address_location
  }.

Section PROG.

Context (local_alloc: funname -> stk_alloc_oracle_t).

Definition get_Pvar e :=
  match e with
  | Pvar x => ok x
  | _      => Error (stk_ierror_no_var "get_Pvar: variable expected")
  end.

(* The name is chosen to be similar to [set_pure_bytes] and [set_move_bytes],
   but there are probably better ideas.
   TODO: factorize [set_clear_bytes] and [set_pure_bytes] ?
*)
Definition set_clear_bytes rv sr ofs len :=
  let z     := sr.(sr_zone) in
  let z1    := sub_zone_at_ofs z ofs len in
  let i     := interval_of_zone z1 in
  let bm    := get_bytes_map sr.(sr_region) rv in
  (* clear all bytes corresponding to z1 *)
  let bm := clear_bytes_map i bm in
  Mr.set rv sr.(sr_region) bm.

Definition set_clear_pure rmap sr ofs len :=
  {| var_region := rmap.(var_region);
     region_var := set_clear_bytes rmap sr ofs len |}.

Definition set_clear rmap x sr ofs len :=
  Let _ := writable x sr.(sr_region) in
  ok (set_clear_pure rmap sr ofs len).

(* We clear the arguments. This is not necessary in the classic case, because
   we also clear them when assigning the results in alloc_call_res
   (this works if each writable reg ptr is returned (which is currently
   checked by the pretyper) and if each result variable has the same size
   as the corresponding input variable).
   But this complexifies the proof and needs a few more
   checks in stack_alloc to be valid. Thus, for the sake of simplicity, it was
   decided to make the clearing of the arguments twice : here and in
   alloc_call_res.

   We use two rmaps:
   - the initial rmap [rmap0] is used to check the validity of the sub-regions;
   - the current rmap [rmap] is [rmap0] with all the previous writable sub-regions cleared.
   Actually, we could use [rmap] to check the validity, and that would partially
   enforce that the arguments correspond to disjoint regions (in particular,
   writable sub-regions are pairwise disjoint), so with this version we could
   simplify check_all_disj. If we first check the validity and clear the writable regions,
   and then check the validity of the non-writable ones, we can even remove [check_all_disj].
   But the error message (disjoint regions) is much clearer when we have [check_all_disj],
   so I leave it as it is now.
*)
Definition alloc_call_arg_aux rmap0 rmap (sao_param: option param_info) (e:pexpr) :=
  Let x := get_Pvar e in
  Let _ := assert (~~is_glob x)
                  (stk_ierror_basic x.(gv) "global variable in argument of a call") in
  let xv := gv x in
  match sao_param, get_local xv with
  | None, None =>
    Let _ := check_diff xv in
    ok (rmap, (None, Pvar x))
  | None, Some _ => Error (stk_ierror_basic xv "argument not a reg")
  | Some pi, Some (Pregptr p) =>
    Let srs := Region.check_valid rmap0 xv (Some 0%Z) (size_slot xv) in
    let sr := srs.1 in
    Let rmap := if pi.(pp_writable) then set_clear rmap xv sr (Some 0%Z) (size_slot xv) else ok rmap in
    Let _  := check_align xv sr pi.(pp_align) in
    ok (rmap, (Some (pi.(pp_writable),sr), Pvar (mk_lvar (with_var xv p))))
  | Some _, _ => Error (stk_ierror_basic xv "the argument should be a reg ptr")
  end.

Definition alloc_call_args_aux rmap sao_params es :=
  fmapM2 (stk_ierror_no_var "bad params info") (alloc_call_arg_aux rmap) rmap sao_params es.

Definition disj_sub_regions sr1 sr2 :=
  ~~(region_same sr1.(sr_region) sr2.(sr_region)) ||
  disjoint_zones sr1.(sr_zone) sr2.(sr_zone).

Fixpoint check_all_disj (notwritables writables:seq sub_region) (srs:seq (option (bool * sub_region) * pexpr)) :=
  match srs with
  | [::] => true
  | (None, _) :: srs => check_all_disj notwritables writables srs
  | (Some (writable, sr), _) :: srs =>
    if all (disj_sub_regions sr) writables then
      if writable then
        if all (disj_sub_regions sr) notwritables then
          check_all_disj notwritables (sr::writables) srs
        else false
      else check_all_disj (sr::notwritables) writables srs
    else false
  end.

Definition alloc_call_args rmap (sao_params: seq (option param_info)) (es:seq pexpr) :=
  Let es := alloc_call_args_aux rmap sao_params es in
  Let _  := assert (check_all_disj [::] [::] es.2)
                   (stk_error_no_var "some writable reg ptr are not disjoints") in
  ok es.

Definition check_lval_reg_call (r:lval) :=
  match r with
  | Lnone _ _ => ok tt
  | Lvar x =>
    match get_local x with
    | None   => Let _ := check_diff x in ok tt
    | Some _ => Error (stk_ierror_basic x "call result should be stored in reg")
    end
  | Laset aa ws x e1 => Error (stk_ierror_basic x "array assignement in lval of a call")
  | Lasub aa ws len x e1 => Error (stk_ierror_basic x "sub-array assignement in lval of a call")
  | Lmem ws x e1     => Error (stk_ierror_basic x "call result should be stored in reg")
  end.

Definition check_is_Lvar r (x:var) :=
  match r with
  | Lvar x' => x == x'
  | _       => false
  end.

Definition get_regptr (x:var_i) :=
  match get_local x with
  | Some (Pregptr p) => ok (with_var x p)
  | _ => Error (stk_ierror x (pp_box [:: pp_s "variable"; pp_var x; pp_s "should be a reg ptr"]))
  end.

Definition alloc_lval_call (srs:seq (option (bool * sub_region) * pexpr)) rmap (r: lval) (i:option nat) :=
  match i with
  | None =>
    Let _ := check_lval_reg_call r in
    ok (rmap, r)
  | Some i =>
    match nth (None, Pconst 0) srs i with
    | (Some (_,sr), _) =>
      match r with
      | Lnone i _ => ok (rmap, Lnone i (sword Uptr))
      | Lvar x =>
        Let p := get_regptr x in
        Let rmap := Region.set_arr_call rmap x sr in
        (* TODO: Lvar p or Lvar (with_var x p) like in alloc_call_arg? *)
        ok (rmap, Lvar p)
      | Laset aa ws x e1 => Error (stk_ierror_basic x "array assignement in lval of a call")
      | Lasub aa ws len x e1 => Error (stk_ierror_basic x "sub-array assignement in lval of a call")
      | Lmem ws x e1     => Error (stk_ierror_basic x "call result should be stored in reg ptr")
      end
    | (None, _) => Error (stk_ierror_no_var "alloc_lval_call")
    end
  end.

Definition alloc_call_res rmap srs ret_pos rs :=
  fmapM2 bad_lval_number (alloc_lval_call srs) rmap rs ret_pos.

Definition is_RAnone ral :=
  if ral is RAnone then true else false.

Definition alloc_call (sao_caller:stk_alloc_oracle_t) rmap ini rs fn es :=
  let sao_callee := local_alloc fn in
  Let es  := alloc_call_args rmap sao_callee.(sao_params) es in
  let '(rmap, es) := es in
  Let rs  := alloc_call_res rmap es sao_callee.(sao_return) rs in (*
  Let _   := assert_check (~~ is_RAnone sao_callee.(sao_return_address))
               (Cerr_stk_alloc "cannot call export function")
  in *)
  Let _   :=
    let local_size :=
      if is_RAnone sao_caller.(sao_return_address) then
        (sao_caller.(sao_size) + sao_caller.(sao_extra_size) + wsize_size sao_caller.(sao_align) - 1)%Z
      else
        (round_ws sao_caller.(sao_align) (sao_caller.(sao_size) + sao_caller.(sao_extra_size)))%Z
    in
    assert_check (local_size + sao_callee.(sao_max_size) <=? sao_caller.(sao_max_size))%Z
                 (stk_ierror_no_var "error in max size computation")
  in
  Let _   := assert_check (sao_callee.(sao_align) <= sao_caller.(sao_align))%CMP
                          (stk_ierror_no_var "non aligned function call")
  in
  let es  := map snd es in
  ok (rs.1, Ccall ini rs.2 fn es).

(* Before stack_alloc :
     Csyscall [::x] (getrandom len) [::t]
     t : arr n & len <= n.
     return arr len.
   After:
     xlen: Uptr
     xlen := len;
     Csyscall [::xp] (getrandom len) [::p, xlen]
*)
Definition alloc_syscall ii rmap rs o es :=
  add_iinfo ii
  match o with
  | RandomBytes len =>
    (* per the semantics, we have [len <= wbase Uptr], but we need [<] *)
    Let _ := assert (len <? wbase Uptr)%Z
                    (stk_error_no_var "randombytes: the requested size is too large")
    in
    match rs, es with
    | [::Lvar x], [::Pvar xe] =>
      let xe := xe.(gv) in
      let xlen := with_var xe (vxlen pmap) in
      Let p  := get_regptr xe in
      Let xp := get_regptr x in
      Let sr := get_sub_region rmap xe in
      Let rmap := set_sub_region rmap x sr (Some 0%Z) (Zpos len) in
      ok (rmap,
          [:: MkI ii (Cassgn (Lvar xlen) AT_none (sword Uptr) (cast_const (Zpos len)));
              MkI ii (Csyscall [::Lvar xp] o [:: Plvar p; Plvar xlen])])
    | _, _ =>
      Error (stk_ierror_no_var "randombytes: invalid args or result")
    end
  end.

Fixpoint alloc_i sao (rmap:region_map) (i: instr) : cexec (region_map * cmd) :=
  let (ii, ir) := i in

    match ir with
    | Cassgn r t ty e =>
      if is_sarr ty then
        Let ri := add_iinfo ii (alloc_array_move_init rmap r t e) in
        ok (ri.1, [:: MkI ii ri.2])
      else
        Let e := add_iinfo ii (alloc_e rmap e) in
        Let r := add_iinfo ii (alloc_lval rmap r ty) in
        ok (r.1, [:: MkI ii (Cassgn r.2 t ty e)])

    | Copn rs t o e =>
      Let e  := add_iinfo ii (alloc_es rmap e) in
      Let rs := add_iinfo ii (alloc_lvals rmap rs (sopn_tout o)) in
      ok (rs.1, [:: MkI ii (Copn rs.2 t o e)])

    | Csyscall rs o es =>
      alloc_syscall ii rmap rs o es

    | Cif e c1 c2 =>
      Let e := add_iinfo ii (alloc_e rmap e) in
      Let c1 := fmapM (alloc_i sao) rmap c1 in
      Let c2 := fmapM (alloc_i sao) rmap c2 in
      let rmap:= merge c1.1 c2.1 in
      ok (rmap, [:: MkI ii (Cif e (flatten c1.2) (flatten c2.2))])

    | Cwhile a c1 e c2 =>
      let check_c rmap :=
        Let c1 := fmapM (alloc_i sao) rmap c1 in
        let rmap1 := c1.1 in
        Let e := add_iinfo ii (alloc_e rmap1 e) in
        Let c2 := fmapM (alloc_i sao) rmap1 c2 in
        ok ((rmap1, c2.1), (e, (c1.2, c2.2))) in
      Let r := loop2 ii check_c Loop.nb rmap in
      ok (r.1, [:: MkI ii (Cwhile a (flatten r.2.2.1) r.2.1 (flatten r.2.2.2))])

    | Ccall ini rs fn es =>
      Let ri := add_iinfo ii (alloc_call sao rmap ini rs fn es) in
      ok (ri.1, [::MkI ii ri.2])

    | Cfor _ _ _  => Error (pp_at_ii ii (stk_ierror_no_var "don't deal with for loop"))

    end.

End PROG.

End Section.

Definition init_stack_layout (mglob : Mvar.t (Z * wsize)) sao :=
  let add (xsr: var * wsize * Z)
          (slp:  Mvar.t (Z * wsize) * Z) :=
    let '(stack, p) := slp in
    let '(x,ws,ofs) := xsr in
    if Mvar.get stack x is Some _ then Error (stk_ierror_no_var "duplicate stack region")
    else if Mvar.get mglob x is Some _ then Error (stk_ierror_no_var "a region is both glob and stack")
    else
      if (p <= ofs)%CMP then
        let len := size_slot x in
        if (ws <= sao.(sao_align))%CMP then
          if (Z.land ofs (wsize_size ws - 1) == 0)%Z then
            let stack := Mvar.set stack x (ofs, ws) in
            ok (stack, (ofs + len)%Z)
          else Error (stk_ierror_no_var "bad stack region alignment")
        else Error (stk_ierror_no_var "bad stack alignment")
      else Error (stk_ierror_no_var "stack region overlap") in
  Let _ := assert (0 <=? sao.(sao_ioff))%Z (stk_ierror_no_var "negative initial stack offset") in
  Let sp := foldM add (Mvar.empty _, sao.(sao_ioff)) sao.(sao_slots) in
  let '(stack, size) := sp in
  if (size <= sao.(sao_size))%CMP then ok stack
  else Error (stk_ierror_no_var "stack size").

Definition add_alloc globals stack (xpk:var * ptr_kind_init) (lrx: Mvar.t ptr_kind * region_map * Sv.t) :=
  let '(locals, rmap, sv) := lrx in
  let '(x, pk) := xpk in
  if Sv.mem x sv then Error (stk_ierror_no_var "invalid reg pointer")
  else if Mvar.get locals x is Some _ then
    Error (stk_ierror_no_var "the oracle returned two results for the same var")
  else
    Let svrmap :=
      match pk with
      | PIdirect x' z sc =>
        let vars := if sc is Slocal then stack else globals in
        match Mvar.get vars x' with
        | None => Error (stk_ierror_no_var "unknown region")
        | Some (ofs', ws') =>
          if [&& (size_slot x <= z.(z_len))%CMP, (0%Z <= z.(z_ofs))%CMP &
                 ((z.(z_ofs) + z.(z_len))%Z <= size_slot x')%CMP] then
            let rmap :=
              if sc is Slocal then
                let sr := sub_region_stack x' ws' z in
                Region.set_arr_init rmap x sr
              else
                rmap
            in
            ok (sv, Pdirect x' ofs' ws' z sc, rmap)
          else Error (stk_ierror_no_var "invalid slot")
        end
      | PIstkptr x' z xp =>
        if ~~ is_sarr x.(vtype) then
          Error (stk_ierror_no_var "a stk ptr variable must be an array")
        else
        match Mvar.get stack x' with
        | None => Error (stk_ierror_no_var "unknown stack region")
        | Some (ofs', ws') =>
          if Sv.mem xp sv then Error (stk_ierror_no_var "invalid stk ptr (not unique)")
          else if xp == x then Error (stk_ierror_no_var "a pseudo-var is equal to a program var")
          else if Mvar.get locals xp is Some _ then Error (stk_ierror_no_var "a pseudo-var is equal to a program var")
          else
            if [&& (Uptr <= ws')%CMP,
                (0%Z <= z.(z_ofs))%CMP,
                (Z.land z.(z_ofs) (wsize_size Uptr - 1) == 0)%Z,
                (wsize_size Uptr <= z.(z_len))%CMP &
                ((z.(z_ofs) + z.(z_len))%Z <= size_slot x')%CMP] then
              ok (Sv.add xp sv, Pstkptr x' ofs' ws' z xp, rmap)
          else Error (stk_ierror_no_var "invalid ptr kind")
        end
      | PIregptr p =>
        if ~~ is_sarr x.(vtype) then
          Error (stk_ierror_no_var "a reg ptr variable must be an array")
        else
        if Sv.mem p sv then Error (stk_ierror_no_var "invalid reg pointer already exists")
        else if Mvar.get locals p is Some _ then Error (stk_ierror_no_var "a pointer is equal to a program var")
        else if vtype p != sword Uptr then Error (stk_ierror_no_var "invalid pointer type")
        else ok (Sv.add p sv, Pregptr p, rmap)
      end in
    let '(sv,pk, rmap) := svrmap in
    let locals := Mvar.set locals x pk in
    ok (locals, rmap, sv).

Definition init_local_map vrip vrsp vxlen globals stack sao :=
  Let _ := assert (vxlen != vrip) (stk_ierror_no_var "two fresh variables are equal") in
  Let _ := assert (vxlen != vrsp) (stk_ierror_no_var "two fresh variables are equal") in
  let sv := Sv.add vxlen (Sv.add vrip (Sv.add vrsp Sv.empty)) in
  Let aux := foldM (add_alloc globals stack) (Mvar.empty _, Region.empty, sv) sao.(sao_alloc) in
  let '(locals, rmap, sv) := aux in
  ok (locals, rmap, sv).

(** For each function, the oracle returns:
  - the size of the stack block;
  - an allocation for local variables;
  - an allocation for the variables to save;
  - where to save the stack pointer (of the caller); (* TODO: merge with above? *)
  - how to pass the return address (non-export functions only)

  It can call back the partial stack-alloc transformation that given an oracle (size of the stack block and allocation of stack variables)
  will transform the body of the current function.

  The oracle is implemented as follows:
   1/ stack allocation
   2/ Reg allocation
   3/ if we have remaining register to save the stack pointer we use on those register
      else
        4/ we restart stack allocation and we keep one position in the stack to save the stack pointer
        5/ Reg allocation
*)

Definition check_result pmap rmap paramsi params oi (x:var_i) :=
  match oi with
  | Some i =>
    match nth None paramsi i with
    | Some sr =>
      Let _ := assert (x.(vtype) == (nth x params i).(vtype))
                      (stk_ierror_no_var "reg ptr in result not corresponding to a parameter") in
      Let srs := check_valid rmap x (Some 0%Z) (size_slot x) in
      let sr' := srs.1 in
      Let _  := assert (sr == sr') (stk_ierror_no_var "invalid reg ptr in result") in
      Let p  := get_regptr pmap x in
      ok p
    | None => Error (stk_ierror_no_var "invalid function info")
    end
  | None =>
    Let _ := check_var pmap x in
    Let _ := check_diff pmap x in
    ok x
  end.

(* TODO: clean the 3 [all2] functions *)
Definition check_all_writable_regions_returned paramsi (ret_pos:seq (option nat)) :=
  all2 (fun i osr =>
    match osr with
    | Some sr => if sr.(sr_region).(r_writable) then Some i \in ret_pos else true
    | None => true
    end) (iota 0 (size paramsi)) paramsi.

Definition check_results pmap rmap paramsi params ret_pos res :=
  Let _ := assert (check_all_writable_regions_returned paramsi ret_pos)
                  (stk_ierror_no_var "a writable region is not returned")
  in
  mapM2 (stk_ierror_no_var "invalid function info")
        (check_result pmap rmap paramsi params) ret_pos res.

(* TODO: is duplicate region the best error msg ? *)
Definition init_param (mglob stack : Mvar.t (Z * wsize)) accu pi (x:var_i) :=
  let: (disj, lmap, rmap) := accu in
  Let _ := assert (~~ Sv.mem x disj) (stk_ierror_no_var "a parameter already exists") in
  if Mvar.get lmap x is Some _ then Error (stk_ierror_no_var "a stack variable also occurs as a parameter")
  else
  match pi with
  | None => ok (accu, (None, x))
  | Some pi =>
    Let _ := assert (vtype pi.(pp_ptr) == sword Uptr) (stk_ierror_no_var "bad ptr type") in
    Let _ := assert (~~Sv.mem pi.(pp_ptr) disj) (stk_ierror_no_var "duplicate region") in
    Let _ := assert (is_sarr x.(vtype)) (stk_ierror_no_var "bad reg ptr type") in
    if Mvar.get lmap pi.(pp_ptr) is Some _ then Error (stk_ierror_no_var "a pointer is equal to a local var")
    else if Mvar.get mglob x is Some _ then Error (stk_ierror_no_var "a region is both glob and param")
    else if Mvar.get stack x is Some _ then Error (stk_ierror_no_var "a region is both stack and param")
    else
    let r :=
      {| r_slot := x;
         r_align := pi.(pp_align); r_writable := pi.(pp_writable) |} in
    let sr := sub_region_full x r in
    ok (Sv.add pi.(pp_ptr) disj,
        Mvar.set lmap x (Pregptr pi.(pp_ptr)),
        set_move rmap x sr,
        (Some sr, with_var x pi.(pp_ptr)))
  end.

Definition init_params mglob stack disj lmap rmap sao_params params :=
  fmapM2 (stk_ierror_no_var "invalid function info")
    (init_param mglob stack) (disj, lmap, rmap) sao_params params.

Definition alloc_fd_aux p_extra mglob (fresh_reg : string -> stype -> string) (local_alloc: funname -> stk_alloc_oracle_t) sao fd : cexec _ufundef :=
  let vrip := {| vtype := sword Uptr; vname := p_extra.(sp_rip) |} in
  let vrsp := {| vtype := sword Uptr; vname := p_extra.(sp_rsp) |} in
  let vxlen := {| vtype := sword Uptr; vname := fresh_reg "__len__"%string (sword Uptr) |} in
  let ra := sao.(sao_return_address) in
  Let stack := init_stack_layout mglob sao in
  Let mstk := init_local_map vrip vrsp vxlen mglob stack sao in
  let '(locals, rmap, disj) := mstk in
  (* adding params to the map *)
  Let rparams :=
    init_params mglob stack disj locals rmap sao.(sao_params) fd.(f_params) in
  let: (sv, lmap, rmap, alloc_params) := rparams in
  let paramsi := map fst alloc_params in
  let params : seq var_i := map snd alloc_params in
  let pmap := {|
        vrip    := vrip;
        vrsp    := vrsp;
        vxlen   := vxlen;
        globals := mglob;
        locals  := lmap;
        vnew    := sv;
      |} in
  Let _ := assert (0 <=? sao.(sao_extra_size))%Z
                  (stk_ierror_no_var "negative extra size")
  in
  Let _ :=
    let local_size :=
      if is_RAnone sao.(sao_return_address) then
        (sao.(sao_size) + sao.(sao_extra_size) + wsize_size sao.(sao_align) - 1)%Z
      else
        (round_ws sao.(sao_align) (sao.(sao_size) + sao.(sao_extra_size)))%Z
    in
    assert_check (local_size <=? sao.(sao_max_size))%Z
                 (stk_ierror_no_var "sao_max_size too small")
  in
  Let rbody := fmapM (alloc_i pmap local_alloc sao) rmap fd.(f_body) in
  let: (rmap, body) := rbody in
  Let res :=
      check_results pmap rmap paramsi fd.(f_params) sao.(sao_return) fd.(f_res) in
  ok {|
    f_info := f_info fd;
    f_tyin := map2 (fun o ty => if o is Some _ then sword Uptr else ty) sao.(sao_params) fd.(f_tyin);
    f_params := params;
    f_body := flatten body;
    f_tyout := map2 (fun o ty => if o is Some _ then sword Uptr else ty) sao.(sao_return) fd.(f_tyout);
    f_res := res;
    f_extra := f_extra fd |}.

Definition alloc_fd p_extra mglob (fresh_reg : string -> stype -> string) (local_alloc: funname -> stk_alloc_oracle_t) fn fd :=
  let: sao := local_alloc fn in
  Let fd := alloc_fd_aux p_extra mglob fresh_reg local_alloc sao fd in
  let f_extra := {|
        sf_align  := sao.(sao_align);
        sf_stk_sz := sao.(sao_size);
        sf_stk_ioff := sao.(sao_ioff);
        sf_stk_extra_sz := sao.(sao_extra_size);
        sf_stk_max := sao.(sao_max_size);
        sf_max_call_depth := sao.(sao_max_call_depth);
        sf_to_save := sao.(sao_to_save);
        sf_save_stack := sao.(sao_rsp);
        sf_return_address := sao.(sao_return_address);
      |} in
  ok (swith_extra fd f_extra).

Definition check_glob (m: Mvar.t (Z*wsize)) (data:seq u8) (gd:glob_decl) :=
  let x := gd.1 in
  match Mvar.get m x with
  | None => false
  | Some (z, _) =>
    let n := Z.to_nat z in
    let data := drop n data in
    match gd.2 with
    | @Gword ws w =>
      let s := Z.to_nat (wsize_size ws) in
      (s <= size data) &&
      (LE.decode ws (take s data) == w)
    | @Garr p t =>
      let s := Z.to_nat p in
      (s <= size data) &&
      all (fun i =>
             match read t (Z.of_nat i) U8 with
             | Ok w => nth 0%R data i == w
             | _    => false
             end) (iota 0 s)
    end
  end.

Definition check_globs (gd:glob_decls) (m:Mvar.t (Z*wsize)) (data:seq u8) :=
  all (check_glob m data) gd.

Definition init_map (sz:Z) (l:list (var * wsize * Z)) : cexec (Mvar.t (Z*wsize)) :=
  let add (vp:var * wsize * Z) (globals:Mvar.t (Z*wsize) * Z) :=
    let '(v, ws, p) := vp in
    if (globals.2 <=? p)%Z then
      if Z.land p (wsize_size ws - 1) == 0%Z then
        let s := size_slot v in
        ok (Mvar.set globals.1 v (p,ws), p + s)%Z
      else Error (stk_ierror_no_var "bad global alignment")
    else Error (stk_ierror_no_var "global overlap") in
  Let globals := foldM add (Mvar.empty (Z*wsize), 0%Z) l in
  if (globals.2 <=? sz)%Z then ok globals.1
  else Error (stk_ierror_no_var "global size").

Definition alloc_prog (fresh_reg:string -> stype -> Ident.ident)
    rip rsp global_data global_alloc local_alloc (P:_uprog) : cexec _sprog :=
  Let mglob := init_map (Z.of_nat (size global_data)) global_alloc in
  let p_extra :=  {|
    sp_rip   := rip;
    sp_rsp   := rsp;
    sp_globs := global_data;
  |} in
  if rip == rsp then Error (stk_ierror_no_var "rip and rsp clash")
  else if check_globs P.(p_globs) mglob global_data then
    Let p_funs := map_cfprog_name (alloc_fd  p_extra mglob fresh_reg local_alloc) P.(p_funcs) in
    ok  {| p_funcs  := p_funs;
           p_globs := [::];
           p_extra := p_extra;
        |}
  else
     Error (stk_ierror_no_var "invalid data").

End CHECK.

End ASM_OP.


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

Local Open Scope Z_scope.

Section Spec.

 Definition find_lock_map_target_rec_spec (rec: Pointer) (target: Z64) (adt: RData) : option RData :=
   match target with
   | VZ64 target =>
     rely is_int64 target;
     rely (peq (base rec) buffer_loc);
     when gidx == ((buffer (priv adt)) @ (offset rec));
     rely is_gidx gidx;
     let gn := (gs (share adt)) @ gidx in
     rely gtype gn =? GRANULE_STATE_REC;
     rely g_inited (gro gn);
     let idx1 := __mpidr_to_rec_idx target in
     let idx2 := g_rec_idx (gro gn) in
     rely is_int64 idx1; rely is_int64 idx2;
     if idx1 =? idx2 then
       rely (g_rec (gro gn) =? gidx);
       when adt == query_oracle adt;
       let gn := (gs (share adt)) @ gidx in
       rely prop_dec (glock gn = None);
       let g' := gn {glock: Some CPU_ID} in
       Some adt {log: (EVT CPU_ID (ACQ gidx)) :: log adt} {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}
            {priv: (priv adt) {buffer: (buffer (priv adt)) # SLOT_REC_TARGET == (Some gidx)} {target_rec: SLOT_REC_TARGET}}
     else
       rely (g_tag (ginfo gn) =? GRANULE_STATE_REC);
       rely (ref_accessible gn CPU_ID);
       let rd_gidx := g_rec_rd (grec gn) in
       let recl_gidx := g_rec_rec_list (grec gn) in
       rely is_gidx rd_gidx; rely is_gidx recl_gidx;
       rely prop_dec ((buffer (priv adt)) @ SLOT_REC_LIST = None);
        when adt == (query_oracle adt);
        let adt := adt {log: EVT CPU_ID (RECL recl_gidx idx1 GET_RECL) :: log adt} in
        let grecl := (gs (share adt)) @ recl_gidx in
        rely (gtype grecl =? GRANULE_STATE_REC_LIST);
        let g_rec_gidx := (g_data (gnorm grecl)) @ idx1 in
        if g_rec_gidx =? 0 then
          Some adt {priv: (priv adt) {target_rec: 0}}
        else
          rely is_gidx g_rec_gidx;
          when adt == query_oracle adt;
          let e := EVT CPU_ID (ACQ g_rec_gidx) in
          let adt := adt {log: e :: log adt} in
          let gn_target := (gs (share adt)) @ g_rec_gidx in
          rely prop_dec (glock gn_target = None);
          let gn_target := gn_target {glock: Some CPU_ID} in
          rely is_int (g_tag (ginfo gn_target));
          rely is_gidx (g_rd (ginfo gn_target));
          if g_tag (ginfo gn_target) =? GRANULE_STATE_REC then
            if g_rd (ginfo gn_target) =? rd_gidx then
              let adt := adt {share: (share adt) {gs: (gs (share adt)) # g_rec_gidx == gn_target}} in
              when adt == query_oracle adt;
              let gn_target := (gs (share adt)) @ g_rec_gidx in
              rely (gtype gn_target =? g_tag (ginfo gn_target));
              let e := EVT CPU_ID (RECL recl_gidx idx1 GET_RECL) in
              rely (gtype ((gs (share adt)) @ recl_gidx) =? GRANULE_STATE_REC_LIST);
              let g_rec_gidx' := (g_data (gnorm ((gs (share adt)) @ recl_gidx))) @ idx1 in
              rely is_int g_rec_gidx';
              if g_rec_gidx =? g_rec_gidx' then
                Some adt {log: e :: log adt}
                     {priv: (priv adt) {buffer: (buffer (priv adt)) # SLOT_REC_TARGET == (Some g_rec_gidx)} {target_rec: SLOT_REC_TARGET}}
              else
                let e' := EVT CPU_ID (REL g_rec_gidx gn_target) in
                Some adt {share: (share adt) {gs: (gs (share adt)) # g_rec_gidx == (gn_target {glock: None})}}
                     {log: e' :: e :: log adt} {priv: (priv adt) {target_rec: 0}}
            else
              rely (gtype gn_target =? g_tag (ginfo gn_target));
              Some adt {log: EVT CPU_ID (REL g_rec_gidx gn_target) :: log adt}
                  {priv: (priv adt) {target_rec: 0}}
          else
            rely (gtype gn_target =? g_tag (ginfo gn_target));
            Some adt {log: EVT CPU_ID (REL g_rec_gidx gn_target) :: log adt}
                 {priv: (priv adt) {target_rec: 0}}
   end.

End Spec.