Require Import UFO.Rel.Definitions.
Require Import UFO.Rel.Adequacy.
Require Import UFO.Rel.Compatability.
Require Import UFO.Rel.Parametricity.
Require Import UFO.Lang.BindingsFacts.
Require Import UFO.Lang.Static.
Require Import UFO.Lang.StaticFacts.
Require Import UFO.Lang.Xs.
Require Import UFO.Lang.SigFacts.
Require Import UFO.Lang.Context.
Require Import FunctionalExtensionality.

Implicit Types EV LV V L : Set.

Section section_congruence.

Hint Resolve ok_wf_lbl ok_wf_ty ok_wf_eff ok_wf_tm.
Hint Resolve XLEnv_inv_wf_XEnv.
Hint Resolve EV_map_XLEnv LV_map_XLEnv.
Hint Unfold compose.

Fixpoint
congruence_tm n EV LV V L (t₁ t₂ : tm EV LV V L)
(Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L)
(T : ty ∅ EV LV L) (E : eff ∅ EV LV L) (T0 : ty0)
C (OK_C : ok_ctx C Γ Π T E T0) {struct OK_C} :
n ⊨ 【 Π Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : T # E 】 →
n ⊨ 【 LEnv_empty ∅→ ⊢ (ctx_plug C t₁) ≼ˡᵒᵍ (ctx_plug C t₂) : T0 # [] 】
with
congruence_md n EV LV V L (m₁ m₂ : md EV LV V L)
(Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L)
(β : L) (σ : ms ∅ EV LV L) (T0 : ty0)
D (OK_D : ok_dtx D Γ Π β σ T0) {struct OK_D} :
n ⊨ 【 Π Γ ⊢ m₁ ≼ˡᵒᵍₘ m₂ : σ ^ (lbl_id (lid_b β)) 】 →
n ⊨ 【 LEnv_empty ∅→ ⊢ (dtx_plug D m₁) ≼ˡᵒᵍ (dtx_plug D m₂) : T0 # [] 】
.
Proof.
{
intro H.
destruct OK_C as [ | ???? D ???????? OK_D | ???? C | ???? C ?? T E | ???? C |
  ???? C t ??????? OK_t | ???? C s ??????? OK_s | ???? C s ???????? OK_s |
  ???? C t ???????? OK_t | ???? C E₁ | ???? C ℓ₁ |
  ???? C s ???????? OK_s | ???? C t ???????? OK_t | ???? C
] ; (simpl ctx_plug || simpl dtx_plug).
+ apply H ; rewrite empty_def ; try rewrite keys_def ;
    try rewrite map_nil ; simpl ; shelve.
+ eapply congruence_md ; [exact OK_D|].
  iintro Ξ ; iintro f ; iintro HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl ; destruct (f β) as [|X] eqn:EQ_fβ ; [auto|].
  eapply compat_md_res ; [ eauto using LEnv_lookup_inv_binds | ].
  match goal with
  | [ H : ?n ⊨ ⟦ _ ?Γ ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ |- ?n ⊨ ⟦ _ ?Γ' ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; crush.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ.
  iespecialize H ; ispecialize H ; [exact HΞΠ|].
  simpl L_bind_ty ; simpl L_bind_tm.
  rewrite L_bind_it_msig.
  apply compat_tm_op.
  apply H.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ.
  iespecialize H ; ispecialize H ; [exact HΞΠ|].
  simpl ; rewrite <- L_bind_eff_app.
  apply compat_tm_up ; exact H.
+ eapply congruence_tm ; try exact OK_C.
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ ; simpl.
  eapply compat_tm_down ; [intro;eauto|eauto|eauto|eauto|].
  intros X FrX.
  ispecialize H (Ξ & X ~ (L_bind_ty f T, L_bind_eff f E)).
  ispecialize H (env_ext f (lid_f X)).
  ispecialize H.
  { iintro_prop ; constructor ; eauto. }
  simpl in H.
  unshelve erewrite L_bind_map_ty, L_map_ty_id in H ; [eauto|eauto| |eauto|].
  unshelve erewrite L_bind_map_eff, L_map_eff_id in H ; [eauto|eauto| |eauto|].
  repeat erewrite L_bind_bind_tm with (g := env_ext f (lid_f X)).
  match goal with
  | [ H : ?n ⊨ ⟦ _ ?Γ ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ |- ?n ⊨ ⟦ _ ?Γ' ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  { extensionality x ; unfold compose.
    unshelve erewrite L_bind_map_ty, L_map_ty_id ; eauto.
    intro ; erewrite L_map_lid_id ; eauto.
  }
  { intro α ; destruct α ; simpl ; [auto|].
    unshelve erewrite L_bind_map_lid, L_map_lid_id, L_bind_lid_id ; auto.
  }
  { intro α ; destruct α ; simpl ; [auto|].
    unshelve erewrite L_bind_map_lid, L_map_lid_id, L_bind_lid_id ; auto.
  }
  { intro ; erewrite L_map_lid_id ; auto. }
  { intro ; erewrite L_map_lid_id ; auto. }
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl ; eapply compat_tm_let ; [|exact H].
  apply SI_LN_parametricity_tm ; [ eauto | intro ; eauto | ].
  eapply ok_wf_tm in OK_t ; [|eauto].
  match goal with
  | [ H : wf_tm ?Ξ ?Γ ?t ?T ?E |- wf_tm ?Ξ ?Γ' ?t ?T ?E ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; crush.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl ; apply compat_tm_let with (S := L_bind_ty f S).
  { match goal with
    | [ H : ?n ⊨ ⟦ _ ?Γ ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ |- ?n ⊨ ⟦ _ ?Γ' ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ ] =>
      replace Γ' with Γ ; [ exact H | ]
    end.
    extensionality x ; crush.
  }
  apply SI_LN_parametricity_tm ; [ eauto | intro ; eauto | eauto ].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-* ; eapply compat_tm_throw ; [exact H|].
  apply SI_LN_parametricity_tm ; [ eauto | intro ; eauto | eauto ].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-* ; eapply compat_tm_throw ; [|exact H].
  apply SI_LN_parametricity_tm ; [ eauto | intro ; eauto | ].
  eapply ok_wf_tm in OK_t ; eauto.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  erewrite <- EV_L_bind_ms ; [ eapply compat_tm_app_eff ; exact H | auto ].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  erewrite <- LV_L_bind_ms ; [ eapply compat_tm_app_lbl ; eauto | auto ].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  eapply compat_tm_app_tm ; [exact H|].
  eapply SI_LN_parametricity_tm ; [eauto|intro ; eauto|eauto].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  eapply compat_tm_app_tm ; [|exact H].
  eapply SI_LN_parametricity_tm ; [eauto|intro ; eauto|].
  eapply ok_wf_tm in OK_t ; eauto.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  eapply compat_sub with (E := L_bind_eff f E1) ; eauto using subty_st, L_bind_se.
}
{
intro H.
destruct OK_D as [ ???? C ????? OK_C | ???? D ????? OK_D |
  ???? D ????? OK_D | ???? D ?????? OK_D ] ; (simpl ctx_plug || simpl dtx_plug).
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  apply compat_tm_val.
  destruct (f β) as [α|X] eqn:EQ_fβ ; simpl in H|-* ; [destruct α|].
  apply compat_val_md ; apply H.
+ eapply congruence_md ; [exact OK_D|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  apply compat_md_ev.
  match goal with
  | [ H : ?n ⊨ ⟦ _ ?Γ ⊢ _ ≼ˡᵒᵍₘ _ : _ ^ _ ⟧ |- ?n ⊨ ⟦ _ ?Γ' ⊢ _ ≼ˡᵒᵍₘ _ : _ ^ _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; auto using L_bind_EV_map_ty.
+ eapply congruence_md ; [exact OK_D|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  apply compat_md_lv.
  match goal with
  | [ H : ?n ⊨ ⟦ _ ?Γ ⊢ _ ≼ˡᵒᵍₘ _ : _ ^ _ ⟧ |- ?n ⊨ ⟦ _ ?Γ' ⊢ _ ≼ˡᵒᵍₘ _ : _ ^ _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; auto using L_bind_LV_map_ty.
+ eapply congruence_md ; [exact OK_D|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  apply compat_md_tm.
  match goal with
  | [ H : ?n ⊨ ⟦ _ ?Γ ⊢ _ ≼ˡᵒᵍₘ _ : _ ^ _ ⟧ |- ?n ⊨ ⟦ _ ?Γ' ⊢ _ ≼ˡᵒᵍₘ _ : _ ^ _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; auto.
}
Qed.

End section_congruence.

Section section_soundness.

Hint Rewrite dom_empty union_empty_l Xs_ctx_plug.

Theorem soundness EV LV V L (t₁ t₂ : tm EV LV V L) (Closed_t₁ : Xs_tm t₁ = \{})
(Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L)
(T : ty ∅ EV LV L) (E : eff ∅ EV LV L) :
⊨ 【 Π Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : T # E 】 →
【 Π Γ ⊢ t₁ ≼ᶜᵗˣ t₂ : T # E 】.
Proof.
intro Ht.
intros C T0 OK_C Closed_C.
eapply adequacy ; [ | crush ].
intro n.
eapply congruence_tm with (n := n) in Ht as HCt ; [|exact OK_C].
iespecialize HCt.
ispecialize HCt ; [ iintro_prop ; constructor | ].
erewrite L_bind_tm_id, L_bind_tm_id, L_bind_ty_id, L_bind_eff_id in HCt ;
  [|auto|auto|auto|auto].
replace (L_bind_ty ∅→ ∘ ∅→) with (∅→ : ∅ → ty0) in HCt ; [|extensionality x ; auto].
exact HCt.
Qed.

Fact unfold_log_eq_I_valid EV LV V L (t₁ t₂ : tm EV LV V L)
(Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L)
(T : ty ∅ EV LV L) (E : eff ∅ EV LV L) :
(⊨ 【 Π Γ ⊢ t₁ ≈ˡᵒᵍ t₂ : T # E 】) →
(⊨ 【 Π Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : T # E 】) ∧ (⊨ 【 Π Γ ⊢ t₂ ≼ˡᵒᵍ t₁ : T # E 】).
Proof.
intro H ; split ; intro n ; specialize (H n) ; idestruct H as H1 H2 ; assumption.
Qed.

Theorem soundness_eq EV LV V L (t₁ t₂ : tm EV LV V L)
(Closed_t₁ : Xs_tm t₁ = \{}) (Closed_t₂ : Xs_tm t₂ = \{})
(Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L)
(T : ty ∅ EV LV L) (E : eff ∅ EV LV L) :
⊨ 【 Π Γ ⊢ t₁ ≈ˡᵒᵍ t₂ : T # E 】 →
【 Π Γ ⊢ t₁ ≈ᶜᵗˣ t₂ : T # E 】.
Proof.
intro H.
apply unfold_log_eq_I_valid in H ; destruct H as [H1 H2].
split ; apply soundness ; assumption.
Qed.

End section_soundness.


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

Require Import ZArith List.
Require Import Monad vgtac VocabA Syn InterCfg DStr DLat DItv DPos
        UserInputType.
Require Import DomBasic DomArrayBlk DomAbs DomMem SemEval SemAbs.

Local Open Scope sumbool.

Inductive query' : Type :=
| ArrayExp (lv : lval) (e : exp)
| DerefExp (e : exp).
Definition query : Type := query'.

Inductive status' := Proven | UnProven | BotAlarm.

Definition status : Type := status'.

(** ** Collect alarm expressions *)

Fixpoint add_offset (o : offset) (orig_offset : offset) : offset :=
  match orig_offset with
  | NoOffset => o
  | FOffset f o1 => FOffset f (add_offset o o1)
  | IOffset e o1 => IOffset e (add_offset o o1)
  end.

Definition lval_append_field (lv : lval) (f : vid_t) : lval :=
  match lv with
  | lval_intro lh o pos =>
    lval_intro lh (add_offset (FOffset f NoOffset) o) pos
  end.

Definition lval_append_index (lv : lval) (e : exp) : lval :=
  match lv with
  | lval_intro lh o pos =>
    lval_intro lh (add_offset (IOffset e NoOffset) o) pos
  end.

Fixpoint c_offset (lv : lval) (ofs : offset) (pos : DPos.t)
: list (query * DPos.t) :=
  match ofs with
  | NoOffset => nil
  | FOffset f o => c_offset (lval_append_field lv f) o pos
  | IOffset e o =>
    (ArrayExp lv e, pos)
      :: c_exp e ++ c_offset (lval_append_index lv e) o pos
  end

with c_lv (lv : lval) : list (query * DPos.t) :=
  match lv with
  | lval_intro (VarLhost v is_g) ofs pos =>
    c_offset (lval_intro (VarLhost v is_g) NoOffset pos) ofs pos
  | lval_intro (MemLhost e) ofs pos =>
    (DerefExp e, pos)
      :: c_exp e
      ++ c_offset (lval_intro (MemLhost e) NoOffset pos) ofs pos
  end

with c_exp (e : exp) : list (query * DPos.t) :=
  match e with
  | Lval lv _ => c_lv lv
  | AlignOfE e _ => c_exp e
  | UnOp _ e _ => c_exp e
  | BinOp _ e1 e2 _ => c_exp e1 ++ c_exp e2
  | CastE _ e _ => c_exp e
  | AddrOf lv _ => c_lv lv
  | StartOf lv _ => c_lv lv
  | _ => nil
  end.

Definition c_alloc (alloc : alloc) : list (query * DPos.t) :=
  match alloc with
  | Array e => c_exp e
  end.

Definition c_exps (exps : list exp) : list (query * DPos.t) :=
  list_fold (fun e q => c_exp e ++ q) exps nil.

Definition collect_query (cmd : cmd) : list (query * DPos.t) :=
  match cmd with
  | Cset lv e _ => c_lv lv ++ c_exp e
  | Cexternal lv _ => c_lv lv
  | Calloc lv a _ => c_lv lv ++ c_alloc a
  | Csalloc lv _ _ => c_lv lv
  | Cassume e _ => c_exp e
  | Ccall None e es _ => c_exp e ++ c_exps es
  | Ccall (Some lv) e es _ => c_lv lv ++ c_exp e ++ c_exps es
  | Creturn (Some e) _ => c_exp e
  | _ => nil
  end.

Load AlarmType.

Module Alarm (Import M : Monad) (MB : MemBasic M) <: ALARM M MB.

Module Import SemMem := SemMem.Make M MB.

Module Import SemEval := SemEval.Make M MB.

Module Import Run := SemAbs.Run M MB.

Section Alarm.

Variable mode : update_mode.

Definition check_bo arr i : list status :=
  if ArrayBlk.eq_dec arr ArrayBlk.bot then BotAlarm :: nil else
    let check_bo' a ofs_size lst :=
      let '(ofs, size, _) := ofs_size in
      let ofs := Itv.plus ofs i in
      let status :=
        match ofs, size with
        | Itv.Bot, _
        | _, Itv.Bot => BotAlarm
        | @Itv.V (Itv.Int ol) (Itv.Int oh) _ _ _, @Itv.V (Itv.Int sl) _ _ _ _ =>
          if Z_ge_dec ol 0%Z &&& Z_lt_dec oh sl then Proven else UnProven
        | _, _ => UnProven
        end in
      status :: lst in
    ArrayBlk.foldi check_bo' arr nil.

Definition make_bot_proven status :=
  match status with
    | BotAlarm => Proven
    | _ => status
  end.

Definition check_query (node : InterNode.t) (mem : Mem.t) (q : query)
: m (list status) :=
  match q with
  | ArrayExp lv e =>
    do lvs <- SemEval .eval_lv mode node lv mem ;
    do v1 <- mem_lookup lvs mem ;
    do v2 <- eval mode node e mem ;
    ret (check_bo (array_of_val v1) (itv_of_val v2))
  | DerefExp e =>
    do v <- eval mode node e mem ;
    let statuses := check_bo (array_of_val v) Itv.zero in
    let r :=
        if Val.eq_dec v Val.bot then statuses else
          List.map make_bot_proven statuses
    in
    ret r
  end.

End Alarm.

End Alarm.

Local Close Scope sumbool.


Set Warnings "-notation-overridden,-parsing".
Require Import Tweetnacl_verif.init_tweetnacl.
Require Import Tweetnacl_verif.spec_Z.
Require Import Tweetnacl.Libs.Export.
Require Import Tweetnacl.ListsOp.Export.
Require Import Tweetnacl.Low.Z.

Open Scope Z.

Definition Gprog : funspecs :=
      ltac:(with_library prog [Z_spec]).
Import Low.

Lemma body_Z: semax_body Vprog Gprog f_Z Z_spec.
Proof.
start_function.
unfold nm_overlap_array_sep_3, nm_overlap_array_sep_3' in *.
assert(HA: Zlength (Z a b) = 16). rewrite Zub_Zlength ; omega.
assert(HmA: Zlength (mVI64 (Z a b)) = 16). rewrite ?Zlength_map //.
assert(Forall (fun x : ℤ => amin - bmax < x < amax - bmin) (Z a b)).  apply Zub_bound_Zlength_lt ; trivial ; omega.
assert(Htkdp: tkdp 16 (mVI64 (Z a b)) o = mVI64 (Z a b)). rewrite -HmA tkdp_all ; trivial ; rewrite ?Zlength_map; omega.
assert(Haux1: forall i, 0 <= i < 16 -> exists aux1, Vlong aux1 = Znth i (mVI64 a) Vundef). intros; erewrite (Znth_map Int64.zero) ; [eexists ; reflexivity | rewrite Zlength_map; omega].
assert(Haux2: forall i, 0 <= i < 16 -> exists aux2, Vlong aux2 = Znth i (mVI64 b) Vundef). intros; erewrite (Znth_map Int64.zero) ; [eexists ; reflexivity | rewrite Zlength_map; omega].
assert(Haux3: forall i, 0 <= i < 16 -> exists aux3, Vlong aux3 = Znth i (tkdp i (mVI64 (Z a b)) (mVI64 a)) Vundef).
  intros ; rewrite /tkdp -?map_firstn -?map_skipn -?map_app ;
  erewrite (Znth_map Int64.zero);[eexists ; reflexivity | rewrite ?Zlength_map];
  change (firstn (nat_of_Z i) (Z a b) ++ skipn (nat_of_Z i) a) with (tkdp i (Z a b) a);
  rewrite tkdp_Zlength HA ; omega.
assert(Haux4: forall i, 0 <= i < 16 -> exists aux4, Vlong aux4 = Znth i (tkdp i (mVI64 (Z a b)) (mVI64 b)) Vundef).
  intros ; rewrite /tkdp -?map_firstn -?map_skipn -?map_app ;
  erewrite (Znth_map Int64.zero);[eexists ; reflexivity | rewrite ?Zlength_map];
  change (firstn (nat_of_Z i) (Z a b) ++ skipn (nat_of_Z i) a) with (tkdp i (Z a b) a);
  rewrite tkdp_Zlength HA ; omega.

flatten ; Intros.
1: subst o v_a.
2: subst o v_b.
3: subst b v_b.
4: subst o a v_o v_a.

1: forward_for_simple_bound 16 (Z_Inv sho sha shb v_o v_o v_b (mVI64 a) a amin amax b bmin bmax 0);
[ unfold nm_overlap_array_sep_3' ; entailer!| |
  rewrite Htkdp; forward; unfold nm_overlap_array_sep_3' ; entailer!].
2: forward_for_simple_bound 16 (Z_Inv sho sha shb v_o v_a v_o (mVI64 b) a amin amax b bmin bmax 1);
[ unfold nm_overlap_array_sep_3' ; entailer! | |
  rewrite Htkdp; forward; unfold nm_overlap_array_sep_3' ; entailer!].
3: forward_for_simple_bound 16 (Z_Inv sho sha shb v_o v_a v_a o a amin amax a amin amax 2);
[ unfold nm_overlap_array_sep_3' ; entailer!| |
  rewrite Htkdp; forward; unfold nm_overlap_array_sep_3' ; entailer!].
4: forward_for_simple_bound 16 (Z_Inv sho sha shb v_b v_b v_b (mVI64 b) b bmin bmax b bmin bmax 3);
[ unfold nm_overlap_array_sep_3' ; entailer!| |
  rewrite Htkdp; forward; unfold nm_overlap_array_sep_3' ; entailer!].
5: forward_for_simple_bound 16 (Z_Inv sho sha shb v_o v_a v_b o a amin amax b bmin bmax 4);
[ unfold nm_overlap_array_sep_3' ; entailer!| |
  rewrite Htkdp; forward; unfold nm_overlap_array_sep_3' ; entailer!].
all: unfold nm_overlap_array_sep_3' ; simpl ; Intros.
all: specialize Haux1 with i ; destruct (Haux1 H7) as [aux1 HHaux1].
all: specialize Haux2 with i ; destruct (Haux2 H7) as [aux2 HHaux2].
all: specialize Haux3 with i ; destruct (Haux3 H7) as [aux3 HHaux3].
all: specialize Haux4 with i ; destruct (Haux4 H7) as [aux4 HHaux4].
all: forward ; rewrite -?HHaux1 -?HHaux2 -?HHaux3 -?HHaux4 ; [entailer!|].
all: forward ; rewrite -?HHaux1 -?HHaux2 -?HHaux3 -?HHaux4 ; [entailer!|].
all: forward.
all: entailer!.
all: rewrite map_map in HHaux1.
all: rewrite map_map in HHaux2.
all: rewrite (Znth_map 0) in HHaux1; [ | omega ].
all: rewrite (Znth_map 0) in HHaux2; [ | omega ].
all: rewrite Znth_tkdp in HHaux3 ; [ | omega].
all: rewrite Znth_tkdp in HHaux4 ; [ | omega].
all: rewrite map_map in HHaux4.
all: rewrite map_map in HHaux3.
all: try (rewrite (Znth_map 0) in HHaux3; [ | omega ]).
all: try (rewrite (Znth_map 0) in HHaux4; [ | omega ]).
1,3,5,7,9: inversion HHaux1.
1,2,3,4,5: inversion HHaux2.
1,2,3,4,5: inversion HHaux3.
1,2,3,4,5: inversion HHaux4.
all: try assert(-2^62 < (Znth i a 0) < 2 ^ 62) by (solve_bounds_by_values_ H).
all: try assert(-2^62 < (Znth i b 0) < 2 ^ 62) by (solve_bounds_by_values_ H0).
all: try assert((-2^62) - (2^62) <= Znth i a 0 - Znth i b 0 <= 2^62 - (-2^62)) by omega.
all: try assert((-2^62) - (2^62) <= Znth i a 0 - Znth i a 0 <= 2^62 - (-2^62)) by omega.
all: try assert((-2^62) - (2^62) <= Znth i b 0 - Znth i b 0 <= 2^62 - (-2^62)) by omega.
1,2,3,4,5: rewrite ?Int64.signed_repr ; solve_bounds_by_values.
all: unfold nm_overlap_array_sep_3' ; simpl ; data_atify ; cancel ; replace_cancel.
all: unfold Z.
  (* postcond |-- loop invariant *)
all: clean_context_from_VST.
all: rewrite /tkdp -?map_firstn -?map_skipn -?map_app in HHaux3.
all: rewrite /tkdp -?map_firstn -?map_skipn -?map_app in HHaux4.
all: inv HHaux1 ; inv HHaux2 ; inv HHaux3 ; inv HHaux4.
all: rewrite sub64_repr /nat_of_Z.
all: rewrite ?Znth_nth; try omega.
all: rewrite <- ZsubList_nth_Zlength ; try omega.
all: rewrite /tkdp ?simple_S_i ; try omega.
all: rewrite /Z in HA, HmA.
all: rewrite (upd_Znth_app_step_Zlength _ _ _ Vundef); try omega.

all: f_equal ; rewrite map_map (Znth_map 0) ?Znth_nth ; try reflexivity.
all: omega.
Qed.

Close Scope Z.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RmiAux.Layer.
Require Import RmiAux2.Code.init_rec_rvic_state.

Require Import RmiAux2.LowSpecs.init_rec_rvic_state.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _set_rvic_mask_bits ↦ gensem set_rvic_mask_bits_spec
  .

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

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_set_rvic_mask_bits: block.
    Hypothesis h_set_rvic_mask_bits_s : Genv.find_symbol ge _set_rvic_mask_bits = Some b_set_rvic_mask_bits.
    Hypothesis h_set_rvic_mask_bits_p : Genv.find_funct_ptr ge b_set_rvic_mask_bits
                                        = Some (External (EF_external _set_rvic_mask_bits
                                                         (signature_of_type (Tcons Tptr (Tcons tuint (Tcons tulong Tnil))) tvoid cc_default))
                                               (Tcons Tptr (Tcons tuint (Tcons tulong Tnil))) tvoid cc_default).
    Local Opaque set_rvic_mask_bits_spec.

    Lemma init_rec_rvic_state_body_correct:
      forall m d d' env le rvic_base rvic_offset
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTrvic: PTree.get _rvic le = Some (Vptr rvic_base (Int.repr rvic_offset)))
             (Hspec: init_rec_rvic_state_spec0 (rvic_base, rvic_offset) d = Some d'),
           exists le', (exec_stmt ge env le ((m, d): mem) init_rec_rvic_state_body E0 le' (m, d') Out_normal).
    Proof.
      Local Opaque set_rvic_mask_bits_spec.
      solve_code_proof Hspec init_rec_rvic_state_body; try solve [eexists; solve_proof_low].
      get_loop_body. clear_hyp.
      set (Hloop := C).
      remember (PTree.set _i (Vint (Int.repr 0)) le)  as le_loop.
      remember 8 as num.
      set (P := fun le0 m0 => m0 = (m, d) /\ le0 = le_loop).
      set (Q := fun (le0: temp_env) m0 => m0 = (m, d')).
      set (Inv := fun le0 m0 n => exists i' adt1,
                      init_rec_rvic_state_loop0 (Z.to_nat (num - n)) 0 (rvic_base, rvic_offset) d
                      = Some (adt1, Int.unsigned i') /\ Int.unsigned i' = num - n /\
                      m0 = (m, adt1) /\ 0 <= n /\ n <= num /\ le0 ! _i = Some (Vint i') /\
                      le0 ! _rvic = Some (Vptr rvic_base (Int.repr rvic_offset))).
      assert(loop_succ: forall N, Z.of_nat N <= num -> exists i' adt',
                  init_rec_rvic_state_loop0 (Z.to_nat (num - Z.of_nat N)) 0 (rvic_base, rvic_offset) d
                  = Some (adt', Int.unsigned i')).

      { add_int Hloop z; try somega.
        induction N. rewrite Z.sub_0_r. rewrite Hloop. intros. repeat eexists; reflexivity.
        intros. erewrite loop_ind_sub1 in IHN; try omega.
        rewrite Nat2Z.inj_succ, succ_plus_1 in H.
        assert(Hcc: Z.of_nat N <= num) by omega.
        apply IHN in Hcc. destruct Hcc as (? & ? & Hnext).
        Local Opaque Z.of_nat. simpl in Hnext. clear Heqle_loop.
        simpl_func Hnext; try add_int' z0; repeat eexists; try somega. }
      assert (T: LoopProofSimpleWhile.t (external_calls_ops := CompatExternalCalls.compatlayer_extcall_ops L) cond body ge (PTree.empty _) P Q).
      { apply LoopProofSimpleWhile.make with (W:=Z) (lt:=fun z1 z2 => (0 <= z2 /\ z1 < z2)) (I:=Inv).
        - apply Zwf_well_founded.
        - unfold P, Inv. intros ? ? CC. destruct CC as [CC1 CC2].
          rewrite CC2 in *. exists num.
          replace (num - num) with 0 by omega. simpl. add_int' 0; try somega.
          rewrite Heqnum. rewrite Heqle_loop.
          repeat eexists; first [reflexivity|assumption|solve_proof_low].
        - intros ? ? ? I. unfold Inv in I. destruct I as (? & ? & ? & ? & ? & ? & ? & ? & ?).
          set (Hnow := H).
          rewrite Heqbody, Heqcond in *.
          destruct (n >? 0) eqn:Hn; bool_rel.
          + eexists. eexists. split_and.
            * solve_proof_low.
            * solve_proof_low.
            * intro CC. inversion CC.
            * assert(Hlx: Z.of_nat (Z.to_nat (n-1)) <= num) by (rewrite Z2Nat.id; omega).
              apply loop_succ in Hlx. rewrite Z2Nat.id in Hlx; try omega.
              intro. destruct Hlx as (? & ? & Hnext). duplicate Hnext.
              rewrite loop_nat_sub1 in Hnext; try somega.
              simpl in Hnext. rewrite Hnow in Hnext.
              autounfold in Hnext; repeat simpl_hyp Hnext;
                repeat destruct_con; bool_rel; contra; inversion Hnext.
              rewrite H8, H9 in *; eexists; eexists; split. solve_proof_low.
              exists (n-1); split. split; solve_proof_low.
              solve_proof_low; unfold Inv; repeat eexists; first[eassumption|solve_proof_low].
          + eexists. eexists. split_and.
            * solve_proof_low.
            * solve_proof_low.
            * intro. unfold Q.
              assert (n=0) by omega. clear Heqle_loop. subst.
              sstep. rewrite Hloop in Hnow. inv Hnow.
              split_and; first[reflexivity|solve_proof_low].
            * intro CC. inversion CC. }
        assert (Pre: P le_loop (m, d)) by (split; reflexivity).
        pose proof (LoopProofSimpleWhile.termination _ _ _ _ _ _ T _ (m, d) Pre) as LoopProof.
        destruct LoopProof as (le' & m' & (exec & Post)).
        unfold exec_stmt in exec. rewrite Heqle_loop in exec.
        unfold Q in Post. rewrite Post in exec.
        eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.


Require Import Rupicola.Lib.Api.
Require Import Rupicola.Lib.Alloc.
Require Import Crypto.Bedrock.Specs.Field.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Local Open Scope Z_scope.

Section Compile.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.
  Context {field_parameters : FieldParameters}
          {field_representaton : FieldRepresentation}
          {field_representation_ok : FieldRepresentation_ok}.

  Definition maybe_bounded mbounds v :=
    match mbounds with
    | Some bounds => bounded_by bounds v
    | None => True
    end.

  (* TODO: Replace uses of the old FElem with this? *)
  Definition FElem mbounds ptr v :=
    (Lift1Prop.ex1 (fun v' => (emp (feval v' = v /\ maybe_bounded mbounds v') * FElem ptr v')%sep)).

  Lemma drop_bounds_FElem x_ptr x bounds
    : Lift1Prop.impl1 (FElem bounds x_ptr x)
                      (FElem None x_ptr x).
  Proof using mem_ok word_ok.
    unfold FElem.
    intros m H.
    sepsimpl.
    exists x0.
    sepsimpl; simpl in *; eauto using relax_bounds.
  Qed.

  Lemma relax_bounds_FElem x_ptr x
    : Lift1Prop.impl1 (FElem (Some tight_bounds) x_ptr x)
                      (FElem (Some loose_bounds) x_ptr x).
  Proof using field_representation_ok mem_ok word_ok.
    unfold FElem.
    intros m H.
    sepsimpl.
    exists x0.
    sepsimpl; simpl in *; eauto using relax_bounds.
  Qed.

  Lemma FElem'_from_bytes
    : forall px : word.rep,
      Lift1Prop.iff1 (Placeholder px) (Lift1Prop.ex1 (FElem None px)).
  Proof using mem_ok word_ok.
    unfold FElem.
    intros.
    split; intros.
    {
      apply FElem_from_bytes in H.
      destruct H.
      do 2 eexists.
      sepsimpl; simpl; eauto.
    }
    {
      destruct H as [? [? ?]].
      sepsimpl.

      eapply FElem_to_bytes; eauto.
    }
  Qed.

  #[refine]
   Instance felem_alloc : Allocable (FElem None) :=
    {|
    size_in_bytes := felem_size_in_bytes;
    size_in_bytes_mod := felem_size_in_bytes_mod;
    |}.
  Proof.
    {
      intros; intros m H.
      apply FElem'_from_bytes.
      eexists.
      eapply drop_bounds_FElem; eauto.
    }
    {
      intros; intros m H.
      apply FElem'_from_bytes.
      eauto.
    }
  Defined.

  Local Ltac prove_field_compilation :=
    repeat straightline';
    handle_call;
    lazymatch goal with
    | |- sep _ _ _ => ecancel_assumption
    | _ => idtac
    end; eauto;
    sepsimpl; repeat straightline'; subst; eauto.

  Local Hint Extern 1 (spec_of _) => (simple refine (@spec_of_BinOp _ _ _ _ _ _ _ _ _ _)) : typeclass_instances.
  Local Hint Extern 1 (spec_of _) => (simple refine (@spec_of_UnOp _ _ _ _ _ _ _ _ _ _)) : typeclass_instances.

  Lemma compile_binop {name} {op: BinOp name}
        {tr m l functions} x y:
    let v := bin_model x y in
    forall P (pred: P v -> predicate) (k: nlet_eq_k P v) k_impl
           Rx Ry Rout out x_ptr x_var y_ptr y_var out_ptr out_var
           bound_out,

      (_: spec_of name) functions ->

      map.get l out_var = Some out_ptr ->
      (FElem bound_out out_ptr out * Rout)%sep m ->

      (FElem (Some bin_xbounds) x_ptr x * Rx)%sep m ->
      (FElem (Some bin_ybounds) y_ptr y * Ry)%sep m ->
      map.get l x_var = Some x_ptr ->
      map.get l y_var = Some y_ptr ->

      (let v := v in
       forall m',
         sep (FElem (Some bin_outbounds) out_ptr v) Rout m' ->
         (<{ Trace := tr;
             Memory := m';
             Locals := l;
             Functions := functions }>
          k_impl
          <{ pred (k v eq_refl) }>)) ->
      <{ Trace := tr;
         Memory := m;
         Locals := l;
         Functions := functions }>
      cmd.seq
        (cmd.call [] name [expr.var out_var; expr.var x_var; expr.var y_var])
        k_impl
      <{ pred (nlet_eq [out_var] v k) }>.
  Proof using env_ok ext_spec_ok locals_ok mem_ok word_ok.
    repeat straightline'.
    unfold FElem in *.
    sepsimpl.
    prove_field_compilation.
    apply H6.

    eapply Proper_sep_impl1; eauto.
    2:exact(fun a b => b).
    intros m' H'.
    eexists.
    sepsimpl;
      eauto.
  Qed.

  Lemma compile_unop {name} (op: UnOp name) {tr m l functions} x:
    let v := un_model x in
    forall P (pred: P v -> predicate) (k: nlet_eq_k P v) k_impl
           Rin Rout out x_ptr x_var out_ptr out_var out_bounds,

      (_: spec_of name) functions ->

      map.get l out_var = Some out_ptr ->
      (FElem out_bounds out_ptr out * Rout)%sep m ->

      (FElem (Some un_xbounds) x_ptr x * Rin)%sep m ->
      map.get l x_var = Some x_ptr ->

      (let v := v in
       forall m',
         sep (FElem (Some un_outbounds) out_ptr v) Rout m' ->
         (<{ Trace := tr;
             Memory := m';
             Locals := l;
             Functions := functions }>
          k_impl
          <{ pred (k v eq_refl) }>)) ->
      <{ Trace := tr;
         Memory := m;
         Locals := l;
         Functions := functions }>
      cmd.seq
        (cmd.call [] name [expr.var out_var; expr.var x_var])
        k_impl
      <{ pred (nlet_eq [out_var] v k) }>.
  Proof using env_ok ext_spec_ok locals_ok mem_ok word_ok.
    repeat straightline'.
    unfold FElem in *.
    sepsimpl.
    prove_field_compilation.
    apply H4.

    eapply Proper_sep_impl1; eauto.
    2:exact(fun a b => b).
    intros m' H'.
    eexists.
    sepsimpl;
      eauto.
  Qed.

  Ltac cleanup_op_lemma lem := (* This makes [simple apply] work *)
    let lm := fresh in
    let op := match lem with _ _ ?op => op end in
    let op_hd := term_head op in
    let simp proj :=
        (let hd := term_head proj in
         let reduced := (eval cbv [op_hd hd] in proj) in
         change proj with reduced in (type of lm)) in
    pose lem as lm;
    first [ simp (bin_model (BinOp := op));
            simp (bin_xbounds (BinOp := op));
            simp (bin_ybounds (BinOp := op));
            simp (bin_outbounds (BinOp := op))
          | simp (un_model (UnOp := op));
            simp (un_xbounds (UnOp := op));
            simp (un_outbounds (UnOp := op)) ];
    let t := type of lm in
    let t := (eval cbv beta in t) in
    exact (lm: t).

  Notation make_bin_lemma op :=
    ltac:(cleanup_op_lemma (@compile_binop _ op)) (only parsing).

  Definition compile_mul := make_bin_lemma bin_mul.
  Definition compile_add := make_bin_lemma bin_add.
  Definition compile_sub := make_bin_lemma bin_sub.

  Notation make_un_lemma op :=
    ltac:(cleanup_op_lemma (@compile_unop _ op)) (only parsing).

  Definition compile_square := make_un_lemma un_square.
  Definition compile_scmula24 := make_un_lemma un_scmula24.

  Local Hint Extern 1 (spec_of _) => (simple refine (@spec_of_felem_copy _ _ _ _ _ _ _ _)) : typeclass_instances.

  Lemma compile_felem_copy {tr m l functions} x :
    let v := x in
    forall P (pred: P v -> predicate) (k: nlet_eq_k P v) k_impl
           R x_ptr x_var out out_ptr out_var x_bound out_bound,

      spec_of_felem_copy functions ->

      map.get l out_var = Some out_ptr ->

      (FElem x_bound x_ptr x * FElem out_bound out_ptr out * R)%sep m ->
      map.get l x_var = Some x_ptr ->

      (let v := v in
       forall m',
         (FElem x_bound x_ptr x * FElem x_bound out_ptr x * R)%sep m' ->
         (<{ Trace := tr;
             Memory := m';
             Locals := l;
             Functions := functions }>
          k_impl
          <{ pred (k v eq_refl) }>)) ->
      <{ Trace := tr;
         Memory := m;
         Locals := l;
         Functions := functions }>
      cmd.seq
        (cmd.call [] felem_copy [expr.var out_var; expr.var x_var])
        k_impl
      <{ pred (nlet_eq [out_var] v k) }>.
  Proof using env_ok ext_spec_ok locals_ok mem_ok word_ok.
    repeat straightline'.
    unfold FElem in *.
    sepsimpl.
    prove_field_compilation.
    apply H3.

    extract_ex1_and_emp_in_goal; ssplit; eauto.
  Qed.

  Local Hint Extern 1 (spec_of _) => (simple refine (@spec_of_from_word _ _ _ _ _ _ _ _)) : typeclass_instances.

  Lemma compile_from_word {tr m l functions} x:
    let v := F.of_Z _ x in
    forall P (pred: P v -> predicate) (k: nlet_eq_k P v) k_impl
           R (wx : word) out out_ptr out_var out_bounds,

      spec_of_from_word functions ->

      map.get l out_var = Some out_ptr ->
      (FElem out_bounds out_ptr out * R)%sep m ->

      word.unsigned wx = x ->

      (let v := v in
       forall m',
         (FElem (Some tight_bounds) out_ptr v * R)%sep m' ->
         (<{ Trace := tr;
             Memory := m';
             Locals := l;
             Functions := functions }>
          k_impl
          <{ pred (k v eq_refl) }>)) ->
      <{ Trace := tr;
         Memory := m;
         Locals := l;
         Functions := functions }>
      cmd.seq
        (cmd.call [] from_word
                  [expr.var out_var; expr.literal x])
        k_impl
      <{ pred (nlet_eq [out_var] v k) }>.
  Proof using env_ok ext_spec_ok locals_ok mem_ok word_ok.
    repeat straightline'.
    unfold FElem in *.
    extract_ex1_and_emp_in H1.
    prove_field_compilation.
    match goal with H : _ |- _ => rewrite word.of_Z_unsigned in H end.
    apply H3.
    extract_ex1_and_emp_in_goal; ssplit; eauto.
  Qed.

  Local Hint Extern 1 (spec_of _) => (simple refine (@spec_of_from_bytes _ _ _ _ _ _ _ _)) : typeclass_instances.

  (*
  Lemma compile_from_bytes {tr m l functions} x :
    let v : F _ := feval_bytes x in
    forall P (pred: P v -> predicate) (k: nlet_eq_k P v) k_impl
           Rx R x_ptr x_var out out_ptr out_var out_bound,

      spec_of_from_bytes functions ->

      map.get l out_var = Some out_ptr ->

      (FElemBytes x_ptr x * Rx)%sep m ->
      (FElem out_bound out_ptr out * R)%sep m ->
      map.get l x_var = Some x_ptr ->

      (let v := v in
       forall m',
         (FElem (Some tight_bounds) out_ptr v * R)%sep m' ->
         (<{ Trace := tr;
             Memory := m';
             Locals := l;
             Functions := functions }>
          k_impl
          <{ pred (k v eq_refl) }>)) ->
      <{ Trace := tr;
         Memory := m;
         Locals := l;
         Functions := functions }>
      cmd.seq
        (cmd.call [] from_bytes [expr.var out_var; expr.var x_var])
        k_impl
      <{ pred (nlet_eq [out_var] v k) }>.
  Proof using env_ok ext_spec_ok locals_ok mem_ok word_ok.
    repeat straightline'.
    unfold FElem in *.
    sepsimpl.
    prove_field_compilation.
    apply H4.

    eapply Proper_sep_impl1; eauto; try reflexivity.
    eapply Lift1Prop.impl1_ex1_r.
    intros m' H'; ssplit; eapply sep_emp_l; ssplit; eauto.
  Qed.

  Lemma compile_to_bytes {tr m l functions} x :
    let v : list _ := Z_to_bytes (F.to_Z x) encoded_felem_size_in_bytes in
    forall P (pred: P v -> predicate) (k: nlet_eq_k P v) k_impl
           Rx R x_ptr x_var out out_ptr out_var,

      spec_of_to_bytes functions ->

      map.get l out_var = Some out_ptr ->

      (FElem (Some tight_bounds) x_ptr x * Rx)%sep m ->
      (FElemBytes out_ptr out * R)%sep m ->
      map.get l x_var = Some x_ptr ->

      (let v := v in
       forall m',
         (FElemBytes out_ptr v * R)%sep m' ->
         (<{ Trace := tr;
             Memory := m';
             Locals := l;
             Functions := functions }>
          k_impl
          <{ pred (k v eq_refl) }>)) ->
      <{ Trace := tr;
         Memory := m;
         Locals := l;
         Functions := functions }>
      cmd.seq
        (cmd.call [] to_bytes [expr.var out_var; expr.var x_var])
        k_impl
      <{ pred (nlet_eq [out_var] v k) }>.
  Proof using env_ok ext_spec_ok locals_ok mem_ok word_ok.
    repeat straightline'.
    subst v.
    unfold FElem in *.
    sepsimpl;
    eapply Proper_call; [ |eapply H]; cycle 1;
     [ ssplit;
        lazymatch goal with
        | |- (_ ⋆ _) _ => ecancel_assumption
        | |- exists R, (_ ⋆ R) _ => eexists; ecancel_assumption
        | _ => idtac
        end
     | cbv[postcondition_func postcondition_func_norets] in *;
        repeat straightline; destruct_lists_of_known_length;
        repeat straightline ].
    { unfold maybe_bounded in *; eauto. }
    intros ? ? ? ?; repeat straightline'.
    subst; eauto.
  Qed.
   *)
End Compile.

(*must be higher priority than compile_mul*)
#[export] Hint Extern 6 (WeakestPrecondition.cmd _ _ _ _ _ (_ (nlet_eq _ (a24 * _)%F _))) =>
simple eapply compile_scmula24; shelve : compiler.

#[export] Hint Extern 8 (WeakestPrecondition.cmd _ _ _ _ _ (_ (nlet_eq _ (_ * _)%F _))) =>
simple eapply compile_mul; shelve : compiler.
#[export] Hint Extern 8 (WeakestPrecondition.cmd _ _ _ _ _ (_ (nlet_eq _ (_ + _)%F _))) =>
simple eapply compile_add; shelve : compiler.
#[export] Hint Extern 8 (WeakestPrecondition.cmd _ _ _ _ _ (_ (nlet_eq _ (_ - _)%F _))) =>
simple eapply compile_sub; shelve : compiler.
#[export] Hint Extern 8 (WeakestPrecondition.cmd _ _ _ _ _ (_ (nlet_eq _ (_ ^ 2)%F _))) =>
simple eapply compile_square; shelve : compiler.
#[export] Hint Extern 8 (WeakestPrecondition.cmd _ _ _ _ _ (_ (nlet_eq _ (F.of_Z M_pos _) _))) =>
simple eapply compile_from_word; shelve : compiler.
#[export] Hint Extern 10 (WeakestPrecondition.cmd _ _ _ _ _ (_ (nlet_eq _ ?v _))) =>
is_var v; simple eapply compile_felem_copy; shelve : compiler.

#[export] Hint Immediate relax_bounds_FElem : ecancel_impl.
#[export] Hint Immediate drop_bounds_FElem : ecancel_impl.

#[export] Hint Extern 1 (spec_of _) => (simple refine (@spec_of_BinOp _ _ _ _ _ _ _ _ _ _)) : typeclass_instances.
#[export] Hint Extern 1 (spec_of _) => (simple refine (@spec_of_UnOp _ _ _ _ _ _ _ _ _ _)) : typeclass_instances.
#[export] Hint Extern 1 (spec_of felem_copy) => (simple refine (@spec_of_felem_copy _ _ _ _ _ _ _ _)) : typeclass_instances.
#[export] Hint Extern 1 (spec_of from_word) => (simple refine (@spec_of_from_word _ _ _ _ _ _ _ _)) : typeclass_instances.