(* This file constructs a notion of N-ary parallel composition for IPDL protocols, rather than only binary. We then lift
our reasoning to be about N-ary composition (with prefix 'pars').
*)

From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq tuple fintype.
From mathcomp Require Import choice path bigop.
Require Import FunctionalExtensionality Classes.Equivalence.
Require Import Lib.SeqOps.
Require Import Lib.Base Ipdl.Exp Lib.TupleLems Lib.setoid_bigop.
Require Import Lib.Set Core.

Definition pars_def {C} (r : list (@ipdl C)) : ipdl := foldr Par (prot0) r.

Definition pars {C} r := (nosimpl (@pars_def C r)).

Notation "[pars xs ]" := (pars xs) (format "[pars  xs ]").
Notation "[|| x1 ]" := (pars (x1 :: [::]))
  (at level 0, format "[||  x1 ]") : seq_scope.

Notation "[|| x1 ; x2 ; .. ; xn ]" := (pars (x1 :: x2 :: .. [:: xn] ..))
  (at level 0, format "[||  '[' x1 ; '/' x2 ; '/' .. ; '/' xn ']' ]"
  ) : ipdl_scope.

Arguments pars : simpl never.

Section Pars.
  Context {chan : Type -> Type}.
  Local Notation EqProt := (@EqProt chan).

Lemma pars_cons r rs :
  EqProt (pars (r :: rs)) (r ||| pars rs).
  rewrite //=.
Qed.

Lemma pars_prot0 (rs : seq (ipdl)) :
  EqProt (pars (prot0 :: rs)) (pars rs).
  rewrite pars_cons -eq_0par //=.
Qed.

Lemma pars_cons_cong r1 r2 rs1 rs2 :
  EqProt r1 r2 ->
  EqProt (pars rs1) (pars rs2) ->
  EqProt (pars (r1 :: rs1)) (pars (r2 :: rs2)).
  intros; rewrite !pars_cons.
  apply EqCong; done.
Qed.

Lemma pars_rcons rs r :
  EqProt (pars rs ||| r) (pars (rcons rs r)).
  induction rs.
  rewrite //=.
  rewrite EqCompComm; reflexivity.
  rewrite //= !pars_cons.
  rewrite -IHrs.
  rewrite EqCompAssoc.
  reflexivity.
Qed.

Lemma pars_nil : @pars chan nil = prot0.
  rewrite /pars //=.
Qed.

Lemma pars_cat rs1 rs2 :
  EqProt (pars (rs1 ++ rs2)) (pars rs1 ||| pars rs2).
  move:rs2; induction rs1; rewrite //=; intro.
  rewrite pars_nil -eq_0par //=.
  rewrite !pars_cons.
  rewrite IHrs1 EqCompAssoc; reflexivity.
Qed.

Lemma pars1 r : EqProt (pars [:: r]) r.
  rewrite /pars //= -eq_par0 //=.
Qed.

Lemma pars_pars rs rs' : EqProt (pars (pars rs :: rs')) (pars (rs ++ rs')).
  rewrite pars_cons.
  rewrite pars_cat.
  reflexivity.
Qed.

  Lemma pars2 r1 r2 :
    EqProt (pars [:: r1; r2]) (r1 ||| r2).
    rewrite !pars_cons /pars -eq_par0 //=.
  Qed.

Lemma Perm_pars (xs ys : seq ipdl) :
  Permutation.Permutation xs ys ->
  EqProt (pars xs) (pars ys).
  elim.
  reflexivity.
  intros.
  rewrite !pars_cons //= H0; reflexivity.
  intros.
  rewrite !pars_cons //= EqCompAssoc (EqCompComm y) -EqCompAssoc; reflexivity.
  intros.
  rewrite (H0); done.
Qed.

   Lemma pars_split (n : nat) (ps : seq ipdl) :
     EqProt (pars ps) (pars (take n ps) ||| pars (drop n ps)).
    rewrite -pars_cat.
    rewrite cat_take_drop //=.
   Qed.

   Lemma par_in_pars r1 r2 rs :
     EqProt (pars ((r1 ||| r2) :: rs))
                (pars (r1 :: r2 :: rs)).
     rewrite !pars_cons EqCompAssoc //=.
   Qed.

    Lemma par_in_pars2 r rs r1 r2 :
        EqProt (pars (r :: (r1 ||| r2) :: rs))
                    (pars (r :: r1 :: r2 :: rs)).
        rewrite !pars_cons.
        apply EqCong; rewrite //=.
        rewrite EqCompAssoc; done.
    Qed.

    Lemma par_in_pars3 r r' rs r1 r2 :
        EqProt (pars (r :: r' :: (r1 ||| r2) :: rs))
                    (pars (r :: r' :: r1 :: r2 :: rs)).
        rewrite !pars_cons.
        apply EqCong; rewrite //=.
        apply EqCong; rewrite //=.
        rewrite EqCompAssoc; done.
    Qed.

    Lemma par_in_pars4 r r' r'' rs r1 r2 :
        EqProt (pars (r :: r' :: r'' :: (r1 ||| r2) :: rs))
                    (pars (r :: r' :: r'' :: r1 :: r2 :: rs)).
        rewrite !pars_cons.
        apply EqCong; rewrite //=.
        apply EqCong; rewrite //=.
        apply EqCong; rewrite //=.
        rewrite EqCompAssoc; done.
    Qed.

Lemma cat_nil_nil {A : eqType} (x y : seq A) :
  x = nil ->
  y = nil ->
  (x ++ y = nil).
  move => -> ->; done.
Qed.

Lemma filter_none {A} (xs : seq A) (P : pred A) :
  all (fun x => ~~ (P x)) xs ->
  filter P xs = nil.
  intros; induction xs; rewrite //=.
  simpl in H; destruct (andP H).
  rewrite (negbTE H0) IHxs //=.
Qed.

Lemma New_in_pars t k rs :
  pars [:: New t k & rs] =p @New chan t (fun x => pars [:: k x & rs]).
  rewrite pars_cons.
  rewrite EqCompNew.
  apply EqCongNew; intros.
  rewrite pars_cons //=.
Qed.

(* Rewriting in pars *)

Inductive list_eqprot : list ipdl -> list ipdl -> Prop :=
  | nil_equiv : list_eqprot nil nil
  | cons_equiv x y s t : EqProt x y -> list_eqprot s t -> list_eqprot (x :: s) (y :: t).

Instance list_eqprot_refl : Reflexive list_eqprot.
   intro.
   induction x.
   constructor.
   constructor.
   done.
   done.
Qed.

Instance list_eqprot_tr : Transitive list_eqprot.
   intro; intros.
   move: z H0; induction H; intros.
   done.
   inversion H1; subst.
   constructor.
   rewrite H //=.
   apply IHlist_eqprot.
   done.
Qed.

Instance list_eqprot_sym : Symmetric list_eqprot.
   intro; intros.
   induction H.
   done.
   constructor.
   rewrite H //=.
   done.
Qed.

Lemma swapE  n k rs :
  EqProt (pars rs) (pars (swap n k rs)).
  apply Perm_pars.
  apply Perm_swap.
Qed.

Lemma pars_fold t1 t2 (a : chan t1) (r : rxn t2)
      (k : t2 -> rxn t1) rs :
  EqProt
         (New t2 (fun c => pars [:: Out a (x <-- Read c ;; k x), Out c r & rs]))
         (pars [:: Out a (x <-- r ;; k x) & rs]).
  etransitivity.
  apply EqCongNew => c.
  rewrite !pars_cons.
  rewrite EqCompAssoc.
  apply EqRefl.
  rewrite -EqCompNew.
  setoid_rewrite EqCompComm at 2.
  rewrite EqFold.
  rewrite -pars_cons //=.
Qed.

(* Tactics for basic permutations / editing *)

Lemma pars_edit' r1 r2 rs :
  EqProt r1 r2 ->
  EqProt (pars (r1 :: rs)) (pars (r2 :: rs)).
  intros.
  rewrite //=.
  apply EqCong.
  done.
  reflexivity.
Qed.

Open Scope bool_scope.

Lemma pars_edit n r1 r2 rs :
  EqProt r1 r2 ->
  List.nth_error rs n = Some r1 ->
  EqProt (pars rs) (pars (lset rs n r2)).
  intros.
  destruct (eqVneq n 0); subst.
  destruct rs.
  rewrite //=.
  simpl in H.
  inversion H0; subst.
  erewrite pars_edit'.
  rewrite lset_0_cons.
  reflexivity.
  done.

  etransitivity.
  apply (swapE 0 n).
  destruct rs; simpl in *.
  destruct n; done.
  erewrite swap0E; last first.
  apply H0.
  done.
  done.
  erewrite pars_edit'; last by apply H.
  etransitivity.
  apply (swapE 0 n).
  simpl.
  have -> : swap 0 n (r2 :: lset rs n.-1 i0) =
           lset (i0 :: rs) n (r2).
  apply nth_error_eqP => j.
  rewrite nth_error_swap //=.
  rewrite nth_error_lset.
  destruct (eqVneq n j); subst.
  rewrite size_lset.
  have: List.nth_error (i0 :: rs) j by rewrite H0.
  rewrite nth_error_size_lt => ->.
  rewrite (negbTE i) //=.
  rewrite -nth_error_size_lt.
  destruct j.
  done.
  simpl.
  simpl in H0.
  rewrite H0 //=.
  rewrite size_lset; last first.
  rewrite -nth_error_size_lt.
  destruct n.
  done.
  simpl in *; rewrite H0 //=.
  destruct n.
  done.
  simpl in *.
  have -> : (n.+1 < (size rs).+1) = (n < size rs) by done.
  rewrite -nth_error_size_lt H0 //=.
  destruct j; simpl.
  rewrite nth_error_lset.
  rewrite eq_refl //=.
  rewrite -nth_error_size_lt H0 //=.
  rewrite nth_error_lset.
  rewrite eqE //= in i1.
  have hnj: n != j by done.
  rewrite (negbTE hnj); done.
  rewrite -nth_error_size_lt H0 //=.
  rewrite -nth_error_size_lt H0 //=.
  reflexivity.
Qed.

Lemma pars_edit_out n m (cm : chan m) (r1 r2 : rxn m) (rs : seq (ipdl)) :
  r1 =r r2 ->
  List.nth_error rs n = Some (Out cm r1) ->
  EqProt (pars rs) (pars (lset rs n (Out cm r2))).
  intros.
  eapply pars_edit.
  apply EqCongReact.
  apply H.
  done.
Qed.

   Lemma inline {t} {t'} (b : chan t') (c : chan t) k r :
     isDet _ r ->
     EqProt (Out b (x <-- Read c ;; k x) ||| Out c r)
                      (Out b (x <-- r ;; k x) ||| Out c r).
     intros.
     rewrite EqCompComm.
     rewrite EqSubst //=.
     rewrite EqCompComm.
     done.
   Qed.

   Lemma pars_inline {t} {t'} (b : chan t') (c : chan t) k r rs :
     isDet _ r ->
     EqProt (pars [:: (Out b (x <-- Read c ;; k x)), Out c r & rs])
                      (pars [:: (Out b (x <-- r ;; k x)), Out c r & rs]).
     intros.
     rewrite !pars_cons.
     rewrite !EqCompAssoc.
     rewrite inline.
     done.
     done.
   Qed.

Lemma pars_mkdep {t1 t2} (c : chan t1) (d : chan t2) r1 r2 rs :
  (forall t (c0 : chan t), can_read c0 r2 -> reads_from c0 r1) ->
  pars [::
          c ::= r1, d ::= r2 & rs] =p
  pars [::
          c ::= (_ <-- Read d ;; r1), d ::= r2 & rs].
  intros.
  symmetry.
  rewrite pars_cons.
  rewrite pars_cons.
  rewrite EqCompAssoc.
  rewrite EqCompComm.
  etransitivity.
  apply EqCongComp.
  rewrite EqCompComm.
  apply EqUnused.
  done.
  symmetry; rewrite !pars_cons.
  symmetry.
  rewrite EqCompComm.
  rewrite EqCompAssoc.
  rewrite (EqCompComm (c ::= r1)).
  done.
Qed.

Lemma pars_unused {t1 t2} (c1 : chan t1) (c2 : chan t2) rs r r' :
  (forall (t : Type) (c0 : chan t), can_read c0 r -> reads_from c0 r') ->
  (pars [:: Out c2 (_ <-- Read c1;; r'), Out c1 r & rs]) =p
  (pars [:: Out c2 (r'), Out c1 r & rs]).
  intros.
  rewrite -pars_mkdep.
  done.
  done.
Qed.

Lemma pars_tr {t1 t2 t3} (c : chan t1) (d : chan t3) k1 (e : chan t2) k2 rs :
  pars [::
          c ::= (x <-- Read d ;; k1 x),
          e ::= (x <-- Read c ;; k2 x) & rs]
  =p
  pars [::
          c ::= (x <-- Read d ;; k1 x),
          e ::= (_ <-- Read d ;; x <-- Read c ;; k2 x) & rs].
  intros; rewrite !pars_cons !EqCompAssoc.
  rewrite EqSubsume; last first.
  done.
Qed.

Lemma new_pars_remove {t1} (r : chan t1 -> rxn t1) rs :
  (a <- new t1 ;; pars [:: Out a (r a) & rs]) =p pars rs.
  intros.
  setoid_rewrite pars_cons.
  rewrite RRemove; done.
Qed.

Lemma generalize_pars_eq2_1 r1 r2 r1' r2' :
  (forall rs, pars [:: r1, r2 & rs] =p pars [:: r1', r2' & rs] ) ->
  forall rs1 rs2,
    @pars chan ([:: r1] ++ rs1 ++ [:: r2] ++ rs2) =p pars (r1' :: rs1 ++ [:: r2'] ++ rs2).
  intros.
  induction rs1.
  simpl.
  rewrite H.
  done.
  simpl.
  rewrite (swapE 0 1); rewrite /swap /lset //=.
  rewrite insert_0.
  rewrite (pars_split 1); simpl.
  rewrite IHrs1.
  rewrite -pars_cat; simpl.
  rewrite (swapE 0 1); rewrite /swap /lset //=.
  rewrite insert_0.
  done.
Qed.

End Pars.

Add Parametric Relation {C} : (list (@ipdl C)) (list_eqprot )
                                       reflexivity proved by (list_eqprot_refl )
                                       symmetry proved by (list_eqprot_sym )
                                           transitivity proved by (list_eqprot_tr ) as list_eqprot_rel.

Close Scope bool_scope.
Require Import Setoid Relation_Definitions Morphisms.

Add Parametric Morphism {C} : (@pars C) with signature
    list_eqprot ==> EqProt as pars_mor.
  intros.
  induction H.
  done.
  rewrite !pars_cons.
  rewrite H.
  rewrite IHlist_eqprot.
  done.
Qed.

Add Parametric Morphism {C} : cons with signature
    (@EqProt C) ==> list_eqprot ==> list_eqprot as cons_mor.
  intros.
  constructor; done.
Qed.

Ltac find_in_pars_rec p rs acc :=
  lazymatch eval simpl in rs with
    | nil => acc
    | (?r :: ?rs') =>
      lazymatch r with
        | context[p] => acc
        | _ => find_in_pars_rec p rs' (S acc)
      end
   end.

Ltac find_in_pars p rs := find_in_pars_rec p rs 0.

Ltac get_idx nxx :=
  let t := type of nxx in
  lazymatch eval simpl in t with
    | nat => constr:(nxx)
    | _ =>
      match goal with
      | [ |- EqProt (pars ?rs) _ ] =>
        let j := find_in_pars nxx rs in j
      end
  end.

Ltac swap_tac nxx mxx :=
  let m___ := get_idx mxx in
  setoid_rewrite (swapE nxx m___) at 1; rewrite /swap /lset /=.

Ltac split_tac n :=
    match goal with
      | [ |- @EqProt  _ _ ] => setoid_rewrite (pars_split n _) at 1; rewrite /= end.

Ltac join_tac :=
    match goal with
      | [ |- EqProt  _ ] => setoid_rewrite <- (pars_cat _ _ ) at 1; rewrite /= end.

Lemma nth_errorP {T} (xs : seq T) x n :
  List.nth_error xs n = Some x ->
  exists xs1 xs2,
    (xs = xs1 ++ [:: x] ++ xs2) /\ (size xs1 = n).
  move: xs x; induction n.
  intros.
  destruct xs.
  done.
  simpl in *.
  inversion H; subst.
  exists nil.
  simpl.
  exists xs; split; done.
  intros.
  destruct xs.
  done.
  simpl in *.
  move/IHn: H => [A [B [h1 h2]]].
  subst.
  exists (t :: A).
  exists B.
  simpl.
  split; done.
Qed.


From SSL_Iris Require Import core.
From iris.program_logic Require Export weakestpre.
From iris.proofmode Require Export tactics coq_tactics ltac_tactics reduction.
From iris.heap_lang Require Import lang notation proofmode.
Require Import common.
From iris_string_ident Require Import ltac2_string_ident.
From Hammer Require Import Hammer.
Context `{!heapG Σ}.
Set Default Proof Using "Type".

Definition sll_append : val :=
rec: "sll_append" "x1" "r" :=
let: "x22" := ! ("r") in
#();;
if: "x1" = #null_loc
then (
#()
)
else (
let: "vx12" := ! ("x1") in
#();;
let: "nxtx12" := ! ("x1" +ₗ #1) in
#();;
"sll_append" "nxtx12" "r";;
let: "y12" := ! ("r") in
#();;
("x1" +ₗ #1) <- ("y12");;
("r") <- ("x1");;
#()
).

Lemma sll_append_spec :
∀ (r : loc) (x2 : loc) (s2 : (list Z)) (_alpha_531 : sll_card) (x1 : loc) (s1 : (list Z)) (_alpha_530 : sll_card),
{{{ (sll x1 s1 _alpha_530) ∗ (sll x2 s2 _alpha_531) ∗ r ↦ #x2 }}}
  sll_append #x1 #r
{{{ RET #(); ∃ (y : loc) (_alpha_532 : sll_card) (s : (list Z)), ⌜(s = (s1 ++ s2))⌝ ∗ (sll y s _alpha_532) ∗ r ↦ #y }}}.
Proof.
iIntros (r x2 s2 _alpha_531 x1 s1 _alpha_530 ϕ) "(iH1 & iH2 & iH3) Post".
iRewriteHyp.
iLöb as "sll_append" forall (r x2 s2 _alpha_531 x1 s1 _alpha_530 ϕ).
ssl_begin.
try rename x2 into x22.
ssl_load.
iRename select ((sll x1 s1 _alpha_530))%I into "iH4".
ssl_if Cond_iH4.

iDestruct (sll_card_0_learn with "iH4") as "[iH4 %iH4_eqn]".
rewrite iH4_eqn; last by safeDispatchPure.
tac_except_post ltac:(rewrite sll_card_0_open).
iDestruct "iH4" as  "(%iH5 & %iH6)".
try wp_pures.
iFindApply.
iExists x22.
iExists _alpha_531.
iExists ([] ++ s2).
ssl_finish.

iDestruct (sll_card_1_learn with "iH4") as "[iH4 %iH4_eqn]".

edestruct iH4_eqn as [_alpha_529x1 ->]; first by safeDispatchPure.
tac_except_post ltac:(rewrite sll_card_1_open).
iDestruct "iH4" as (vx1 s1x1 nxtx1) "((%iH7 & %iH8) & (iH9 & iH10 & iH11 & iH12))".
try rename vx1 into vx12.
ssl_load.
try rename nxtx1 into nxtx12.
ssl_load.
wp_apply ("sll_append" $! (r) (x22) (s2) (_alpha_531) (nxtx12) (s1x1) (_alpha_529x1) with "[$] [$] [$]").

iIntros  "iH16".
iDestruct "iH16" as (y1 _alpha_5321 s3) "(%iH13 & (iH14 & iH15))".
try wp_pures.
try rename y1 into y12.
ssl_load.
ssl_store.
ssl_store.
try wp_pures.
iFindApply.
iExists x1.
iExists (sll_card_1 _alpha_5321 : sll_card).
iExists (([vx12] ++ s1x1) ++ s2).
ssl_finish.
ssl_rewrite_first_heap sll_card_1_open.
pull_out_exist.
iExists vx12.
pull_out_exist.
iExists (s1x1 ++ s2).
pull_out_exist.
iExists y12.
ssl_finish.
Qed.


Require Import PeanoNat.

Require Export SystemFR.NormalizationSing.
Require Export SystemFR.SubtypeList.
Require Export SystemFR.InferMatch.
Require Export SystemFR.CloseLemmas.

Opaque reducible_values.

Lemma open_nmatch_3: forall Γ T2 T3 t t',
  is_erased_type T2 ->
  is_erased_type T3 ->
  wf T2 0 ->
  wf T3 2 ->
  subset (fv T2) (support Γ) ->
  subset (fv T3) (support Γ) ->
  [ Γ ⊨ t ⤳* t' ] ->
  [ Γ ⊫ List_Match t T2 T3 = List_Match t' T2 T3 ].
Proof.
  eauto using open_sub_list_match_scrut, delta_beta_obs_equiv.
Qed.

Lemma nmatch_nil: forall ρ T2 T3,
  valid_interpretation ρ ->
  [ ρ ⊨ List_Match tnil T2 T3 = T2 ].
Proof.
  unfold equivalent_types, List_Match;
    repeat step || simp_red_top_level_goal || simp_red_top_level_hyp || open_none;
    eauto using reducible_values_closed.

  - apply_anywhere equivalent_value_left; steps; eauto with closing values.
  - left; repeat step || simp_red || exists uu;
      eauto using reducible_values_closed;
      eauto using equivalent_refl.
Qed.

Opaque List.

Lemma nmatch_cons: forall ρ t ts T2 T3,
  valid_interpretation ρ ->
  wf t 0 ->
  wf ts 0 ->
  is_erased_term t ->
  is_erased_term ts ->
  pfv t term_var = nil ->
  pfv ts term_var = nil ->
  wf T3 2 ->
  pfv T3 term_var = nil ->
  is_erased_type T3 ->
  [ ρ ⊨ t : T_top ] ->
  [ ρ ⊨ ts : List ] ->
  [ ρ ⊨ List_Match (tcons t ts) T2 T3 = open 0 (open 1 T3 t) ts ].
Proof.
  unfold equivalent_types, List_Match;
    repeat step || simp_red_top_level_goal || simp_red_top_level_hyp || open_none;
    eauto using reducible_values_closed;
    eauto 3 using right_left_equivalence with exfalso values.

  - apply_anywhere tright_equiv; eauto with closing values.
    eapply reducibility_open_equivalent2; try eassumption; steps;
      eauto 3 using equivalent_sym, pair_equiv_1, pair_equiv_2 with closing.

  - right; repeat step.
    apply reducible_expr_value; eauto with values.
    apply reducible_exists with t;
      repeat step || list_utils || rewrite open_list || open_none; eauto with fv wf erased.
    apply reducible_exists with ts;
      repeat step || list_utils || open_none; eauto with fv wf erased.
    apply reducible_type_refine with uu; repeat step || open_none || list_utils;
      eauto with fv wf erased;
      eauto using reducible_value_expr.
    apply reducible_value_expr; repeat step || simp_red_goal.
    apply equivalent_refl; repeat step || list_utils.
Qed.

Opaque List_Match.

Lemma open_nmatch_nil: forall Θ Γ T2 T3,
  [ Θ; Γ ⊨ List_Match tnil T2 T3 = T2 ].
Proof.
  unfold open_equivalent_types; repeat step || rewrite substitute_List_Match;
    eauto with wf;
    eauto using nmatch_nil.
Qed.

Lemma open_nmatch_1: forall Γ T2 T2' T3 t,
  is_erased_type T2 ->
  is_erased_type T3 ->
  wf T2 0 ->
  wf T3 2 ->
  subset (fv T2) (support Γ) ->
  subset (fv T3) (support Γ) ->
  [ Γ ⊨ t ⤳* tnil ] ->
  [ Γ ⊫ T2 = T2' ] ->
  [ Γ ⊫ List_Match t T2 T3 = T2' ].
Proof.
  intros.
  eapply open_equivalent_types_trans; try apply open_nmatch_3;
    eauto using open_equivalent_types_trans, open_nmatch_nil.
Qed.

Lemma open_nmatch_cons: forall Θ Γ T2 T3 t1 t2,
  wf t1 0 ->
  wf t2 0 ->
  wf T3 2 ->
  is_erased_term t1 ->
  is_erased_term t2 ->
  is_erased_type T3 ->
  subset (fv t1) (support Γ) ->
  subset (fv t2) (support Γ) ->
  subset (fv T3) (support Γ) ->
  [ Θ; Γ ⊨ t1 : T_top ] ->
  [ Θ; Γ ⊨ t2 : List ] ->
  [ Θ; Γ ⊨ List_Match (tcons t1 t2) T2 T3 = open 0 (open 1 T3 t1) t2 ].
Proof.
  unfold open_equivalent_types, open_reducible;
    repeat step || rewrite substitute_List_Match || t_substitutions ||
           t_instantiate_sat3 || apply nmatch_cons;
    eauto with wf erased fv.
Qed.

Lemma reducibility_subst_equiv:
  forall ρ v T x t1 t2,
    [ ρ ⊨ v : psubstitute T ((x, t1) :: nil) term_var ]v ->
    valid_interpretation ρ ->
    wf T 0 ->
    is_erased_type T ->
    subset (fv T) (x :: nil) ->
    [ t1 ≡ t2 ] ->
    [ ρ ⊨ v : psubstitute T ((x, t2) :: nil) term_var ]v.
Proof.
  intros; repeat rewrite <- (open_close _ _ _ 0) in * by auto.
  rewrite <- (open_close _ _ _ 0) in H by auto.
  eapply reducibility_open_equivalent; eauto; repeat step;
    eauto with erased wf;
    eauto using fv_close_nil2.
Qed.

Lemma reducibility_subst_equiv2:
  forall ρ T x t1 t2,
    valid_interpretation ρ ->
    wf T 0 ->
    is_erased_type T ->
    subset (fv T) (x :: nil) ->
    [ t1 ≡ t2 ] ->
    [ ρ ⊨ psubstitute T ((x, t1) :: nil) term_var = psubstitute T ((x, t2) :: nil) term_var ].
Proof.
  unfold equivalent_types; steps;
    eauto using reducibility_subst_equiv, equivalent_sym.
Qed.

Lemma subset_diff:
  forall s1 x s2,
    subset s1 (x :: s2) ->
    subset (s1 -- (x :: nil)) s2.
Proof.
  unfold subset; repeat step || instantiate_any || rewrite in_remove in *.
Qed.

Opaque diff.

Lemma subset_diff2:
  forall s1 x s2,
    subset s1 (x :: s2) ->
    subset (s1 -- s2) (x :: nil).
Proof.
  unfold subset; repeat step || instantiate_any || rewrite in_diff in *.
Qed.

Lemma closed_mapping_fv2:
  forall l tag,
    pclosed_mapping l tag ->
    pfv_range l tag = nil.
Proof.
  induction l; repeat step || list_utils.
Qed.

Lemma reducibility_subst_equiv3:
  forall ρ T x l t1 t2,
    valid_interpretation ρ ->
    wf T 0 ->
    is_erased_type T ->
    ~ x ∈ support l ->
    wfs l 0 ->
    erased_terms l ->
    pclosed_mapping l term_var ->
    subset (fv T) (x :: support l) ->
    [ t1 ≡ t2 ] ->
    [ ρ ⊨ psubstitute T ((x, t1) :: l) term_var = psubstitute T ((x, t2) :: l) term_var ].
Proof.
  intros.
  repeat rewrite (substitute_cons4 _ T); steps.
  apply reducibility_subst_equiv2; steps; eauto with wf erased fv.
  eapply subset_transitive; eauto using fv_subst2;
    repeat step || sets || rewrite closed_mapping_fv2 by auto;
    eauto using subset_diff2;
    eauto with sets.
Qed.

Lemma in_support_in_context:
  forall P Γ l x,
    x ∈ support l ->
    satisfies P Γ l ->
    x ∈ pfv_context Γ term_var.
Proof.
  intros; apply fv_context_support; erewrite satisfies_same_support; eauto.
Qed.

Lemma open_instantiate:
  forall Θ Γ x t T T1 T2,
    ~ x ∈ fv T ->
    ~ x ∈ fv_context Γ ->
    wf T1 0 ->
    wf T2 0 ->
    is_erased_type T1 ->
    is_erased_type T2 ->
    subset (fv T1) (x :: support Γ) ->
    subset (fv T2) (x :: support Γ) ->
    [ Θ; Γ ⊨ t : T ] ->
    [ Θ; (x, T) :: Γ ⊨ T1 = T2 ] ->
    [ Θ; Γ ⊨ psubstitute T1 ((x, t) :: nil) term_var = psubstitute T2 ((x, t) :: nil) term_var ].
Proof.
  unfold open_equivalent_types, open_reducible; repeat step || t_instantiate_sat3.
  top_level_unfold reduces_to; steps.
  unshelve epose proof (H8 ρ ((x, v) :: l) _ _);
    repeat step || apply SatCons || (rewrite <- substitute_cons3 by steps);
    eauto with fv wf twf erased.

  eapply equivalent_types_trans; try eapply reducibility_subst_equiv3;
    repeat step || erewrite satisfies_same_support in * by eauto;
    try solve [ equivalent_star ];
    eauto using in_support_in_context;
    eauto with wf erased fv.

  eapply equivalent_types_trans; eauto; apply equivalent_types_sym.

  apply reducibility_subst_equiv3;
    repeat step || erewrite satisfies_same_support in * by eauto;
    try solve [ equivalent_star ];
    eauto using in_support_in_context;
    eauto with wf erased fv.
Qed.

Lemma open_reducible_weaken:
  forall Θ Γ x A t B,
    ~ x ∈ fv t ->
    ~ x ∈ fv B ->
    [ Θ; Γ ⊨ t : B ] ->
    [ Θ; (x, A) :: Γ ⊨ t : B ].
Proof.
  unfold open_reducible; repeat step || step_inversion satisfies || t_substitutions.
Qed.

Lemma open_nmatch_2: forall Γ T2 T3 T3' t t1 t2 x y,
  is_erased_term t1 ->
  is_erased_term t2 ->
  is_erased_type T2 ->
  is_erased_type T3 ->
  is_erased_type T3' ->
  wf t1 0 ->
  wf t2 0 ->
  wf T2 0 ->
  wf T3 2 ->
  wf T3' 0 ->
  subset (fv t1) (support Γ) ->
  subset (fv t2) (support Γ) ->
  subset (fv T2) (support Γ) ->
  subset (fv T3) (support Γ) ->
  subset (fv T3') (support Γ) ->
  ~ x ∈ fv t1 ->
  ~ x ∈ fv t2 ->
  ~ x ∈ fv T3 ->
  ~ x ∈ fv T3' ->
  ~ x ∈ fv_context Γ ->
  ~ y ∈ fv t1 ->
  ~ y ∈ fv t2 ->
  ~ y ∈ fv T3 ->
  ~ y ∈ fv T3' ->
  ~ y ∈ fv_context Γ ->
  x <> y ->
  [ Γ ⊫ t1 : T_top ] ->
  [ Γ ⊫ t2 : List ] ->
  [ Γ ⊨ t ⤳* tcons t1 t2 ] ->
  [ (x, T_singleton T_top t1) :: (y, T_singleton List t2) :: Γ ⊫
    open 0 (open 1 T3 (fvar x term_var)) (fvar y term_var) = T3' ] ->
  [ Γ ⊫ List_Match t T2 T3 = T3' ].
Proof.
  intros.
  eapply open_equivalent_types_trans; try apply open_nmatch_3; try eassumption; steps.
  eapply open_equivalent_types_trans; try apply open_nmatch_cons; steps.
  apply (open_instantiate _ _ _ t1) in H28;
    repeat step || list_utils || apply wf_open || apply is_erased_type_open ||
           rewrite pfv_shift2 in *;
    eauto with fv wf erased;
    eauto using subset_add2.
  - apply (open_instantiate _ _ _ t2) in H28;
      repeat step || list_utils || apply wf_open || apply wf_subst || t_substitutions ||
             apply is_erased_type_open || apply subst_erased_type ||
             rewrite pfv_shift2 in *;
      eauto with fv wf erased;
      eauto using subset_add2;
      eauto using open_reducible_singleton.

    + rewrite (substitute_nothing2 T3') in *; repeat step || rewrite substitute_nothing3 in *.
      rewrite (substitute_nothing2 T3') in *; repeat step || rewrite substitute_nothing3 in *.

    + eapply subset_transitive; eauto using fv_open; repeat step || sets.
      eapply subset_transitive; eauto using fv_open; repeat step || sets;
        eauto using subset_add2.

  - eapply subset_transitive; eauto using fv_open; repeat step || sets.
    eapply subset_transitive; eauto using fv_open; repeat step || sets;
      eauto using subset_add2.
  - apply open_reducible_weaken; repeat step || rewrite pfv_shift2 in *;
      eauto using open_reducible_singleton.
Qed.


Add LoadPath "/users/paulkline/Documents/coqs/protosynth".
Add LoadPath "/home/paul/Documents/coqs/protosynth/cpdt/src" as Cpdt.
Require Import MyShortHand.

Inductive Noun : Set:=
  | VirusChecker
  | PCR.
Theorem eq_dec_Noun : equality Noun.
crush_equal.
Defined.
Hint Resolve eq_dec_Noun : eq_dec_db.
(* Now we define what it is we would like to know about these nouns. *)
Inductive Attribute : Set :=
  | Name : Attribute
  | Hash : Attribute
  | Index : nat -> Attribute
  | Version : Attribute.
Theorem eq_dec_Attribute : equality Attribute.
crush_equal. Defined.
Hint Resolve eq_dec_Attribute : eq_dec_db.
(*We only want to disallow nonsensical combinations, like a (PCR, version),
 hence this relation. *)
Inductive DescriptionR : Noun -> Attribute -> Set :=
  | pcrMR : forall n, DescriptionR PCR (Index n)
  | virusCheckerNameR : DescriptionR VirusChecker Name
  | virusCheckerVersionR : DescriptionR VirusChecker Version.
Theorem eq_dec_DescriptionR {n} {a}:  equality (DescriptionR n a).
crush_equal.
Defined.
Hint Resolve eq_dec_DescriptionR : eq_dec_db.
Hint Resolve eq_dec_DescriptionR.

(* This 'extra step' is done simply so that comparison between descriptors
is 'easy.'It is much more involved to be able to compare indexed types. *)
Inductive Description : Set :=
  | descriptor {n : Noun} {a : Attribute} : DescriptionR n a -> Description.
Theorem eq_dec_Description : equality Description.
crush_equal.
Defined.
Hint Resolve eq_dec_Description : eq_dec_db.

(*This defines what the type of measuring these things should be. *)
Definition measurementDenote (d: Description) :=
match d with
 | descriptor r => (match r with
    | pcrMR n => nat
    | virusCheckerNameR => nat
    | virusCheckerVersionR => nat
    end)
end.

(* Here we begin specificiation of requirements. So not only do I want a particular measurment,
   but I want it to be certain values. *)
Inductive Requirement (d : Description) :=
| requirement : ( (measurementDenote d) -> bool) -> Requirement d.
Require Import FunctionalExtensionality.
Theorem eq_dec_f {A} {B} : forall (a b : (A -> B)), a =<> b.
Proof. intros.
specialize functional_extensionality with a b. intros.
 Admitted.
Hint Resolve eq_dec_f : eq_dec_db.
Theorem eq_dec_Requirement : forall d (x y : Requirement d), x =<> y.
Proof. intros.
destruct d.
destruct d;
crush_equal.
Defined.
Hint Resolve eq_dec_Requirement : eq_dec_db.

(* This begins the defining of what a privacy policy is. First we define a rule.
    A rule regulates the release of a measurement. We could decide to release information if
    some counter condition holds; we could release it for free; we could explicitly never release it;
    or some combination of and-ing and or-ing rules.
    Note that at this point we've allowed for nonsensical release rules like, "never release or release for free",
     "release for free and never release".
    NOTE: If we can't request something twice, what if duplicate occurs in rule req?
          todo: keep all received measurements and check those first for the value *)
Inductive Rule (mything : Description) :=
| rule  {your : Description} : (Requirement your) -> Rule mything
| free : Rule mything
| never : Rule mything.
(*| multiReqAnd : Rule mything ->Rule mything -> Rule mything
| multiReqOr : Rule mything -> Rule mything -> Rule mything.
*)
Theorem eq_dec_Rule : forall x, equality (Rule x).
Proof.

intros. intro_equals.
destruct x.
destruct d;
generalize dependent x0;
induction y;
intro_equals;
destruct x0; try first [decidable |
crush_equal].
(* rest is for and and or case included *)
(*
specialize IHy1 with x0_1.
specialize IHy2 with x0_2.
destruct IHy1.  subst.
destruct IHy2.  subst. decidable.
decidable.  decidable.
specialize IHy1 with x0_1.
specialize IHy2 with x0_2.
destruct IHy1.  subst.
destruct IHy2.  subst. decidable.
crush_equal. decidable.
specialize IHy1 with x0_1.
specialize IHy2 with x0_2.
destruct IHy1.  subst.
destruct IHy2.  subst. decidable.
decidable.  decidable.
specialize IHy1 with x0_1.
specialize IHy2 with x0_2.
destruct IHy1.  subst.
destruct IHy2.  subst. decidable.
crush_equal. decidable.

specialize IHy1 with x0_1.
specialize IHy2 with x0_2.
destruct IHy1.  subst.
destruct IHy2.  subst. decidable.
decidable.  decidable.
specialize IHy1 with x0_1.
specialize IHy2 with x0_2.
destruct IHy1.  subst.
destruct IHy2.  subst. decidable.
crush_equal. decidable.
*)
Defined.
Hint Resolve eq_dec_Rule : eq_dec_db.
(* simply a list of rules. *)
Inductive PrivacyPolicy :=
| EmptyPolicy : PrivacyPolicy
| ConsPolicy {d :Description}:
    Rule d ->
    PrivacyPolicy -> PrivacyPolicy.
Theorem eq_dec_PrivacyPolicy : equality PrivacyPolicy.
intro_equals.
generalize dependent x.
induction y; try
crush_equal + decidable.
intros. destruct x; decidable.
intros. destruct x. decidable.
 specialize IHy with x.
 destruct IHy.  subst. crush_equal.
 crush_equal.
Defined.
Hint Resolve eq_dec_PrivacyPolicy : eq_dec_db.
Inductive Action : Set :=
 | ASend : Action
 | AReceive : Action.
Theorem eq_dec_Action : equality Action.
crush_equal.
Defined.
Hint Resolve eq_dec_Action : eq_dec_db.
(*A RequestItem is used to compose a list of the items and requirements upon
those items in an attestation *)
Inductive RequestItem : Set :=
 | requestItem (d : Description) : (Requirement d) -> RequestItem.
Theorem eq_dec_RequestItem : equality RequestItem.
intro_equals.
generalize dependent x.
induction y;  intros. destruct x; try crush_equal.
Defined.
Hint Resolve eq_dec_RequestItem : eq_dec_db.

Inductive RequestLS : Set :=
 | emptyRequestLS : RequestLS
 | ConsRequestLS : RequestItem -> RequestLS -> RequestLS.
Theorem eq_dec_RequestLS : equality RequestLS.
crush_equal.
Defined.
Hint Resolve eq_dec_RequestLS : eq_dec_db.

Inductive Role : Set :=
 | Appraiser
 | Attester.
Theorem eq_dec_Role : equality Role.
crush_equal.
Defined.


Require Import Helix.LLVMGen.Correctness_Prelude.
Require Import Helix.LLVMGen.Correctness_Invariants.
Require Import Helix.LLVMGen.Correctness_NExpr.
Require Import Helix.LLVMGen.Correctness_MExpr.
Require Import Helix.LLVMGen.Correctness_AExpr.
Require Import Helix.LLVMGen.IdLemmas.
Require Import Helix.LLVMGen.StateCounters.
Require Import Helix.LLVMGen.VariableBinding.
Require Import Helix.LLVMGen.BidBound.
Require Import Helix.LLVMGen.LidBound.
Require Import Helix.LLVMGen.StateCounters.
Require Import Helix.LLVMGen.Context.
Require Import Helix.LLVMGen.Correctness_While.

Import ProofMode.

Set Implicit Arguments.
Set Strict Implicit.

Opaque dropVars.
Opaque newLocalVar.
Opaque resolve_PVar.
Opaque incBlockNamed.
Opaque incVoid.
Opaque incLocal.
Opaque genWhileLoop.

Import ListNotations.
Import MonadNotation.
Local Open Scope monad_scope.
Local Open Scope nat_scope.

Section DSHPower_is_tfor.

  Definition DSHPower_tfor_body (σ : evalContext) (f : AExpr) (x y : mem_block) (xoffset yoffset : nat) (acc : mem_block) :=
    xv <- lift_Derr (mem_lookup_err "Error reading 'xv' memory in denoteDSHBinOp" xoffset x) ;;
    yv <- lift_Derr (mem_lookup_err "Error reading 'yv' memory in denoteDSHBinOp" yoffset acc) ;;
    v' <- denoteBinCType σ f yv xv ;;
    ret (mem_add yoffset v' acc).

  Definition DSHPower_tfor
             (σ: evalContext)
             (n: nat)
             (f: AExpr)
             (x y: mem_block)
             (xoffset yoffset: nat) :
    itree Event mem_block
    :=
      tfor (fun i acc =>
              DSHPower_tfor_body σ f x y xoffset yoffset acc
           ) 0 n y.

  Definition DSHPower_interpreted_tfor
             {E}
             (σ: evalContext)
             (n: nat)
             (f: AExpr)
             (x y: mem_block)
             (xoffset yoffset: nat) m
    : itree E (option (memoryH * mem_block))
    :=
      tfor (fun i acc =>
              match acc with
              | None => Ret None
              | Some (m',acc) =>
                interp_helix (DSHPower_tfor_body σ f x y xoffset yoffset acc) m'
              end
           ) 0 n (Some (m, y)).

  Lemma denoteDSHPower_as_tfor :
    forall (σ: evalContext)
      (n: nat)
      (f: AExpr)
      (x y: mem_block)
      (xoffset yoffset: nat),
      denoteDSHPower σ n f x y xoffset yoffset
                     ≈
                     DSHPower_tfor σ n f x y xoffset yoffset.
  Proof.
    intros σ n; revert σ.
    induction n; unfold DSHPower_tfor; intros σ f x y xoffset yoffset.
    - cbn.
      rewrite tfor_0.
      reflexivity.
    - cbn.
      rewrite tfor_unroll_down; [|lia|].
      + cbn.
        unfold mem_lookup_err.
        repeat setoid_rewrite bind_bind.
        eapply eutt_clo_bind; [reflexivity|].
        intros u1 u2 H; subst.
        eapply eutt_clo_bind; [reflexivity|].
        intros u0 u3 H0; subst.
        eapply eutt_clo_bind; [reflexivity|].
        intros u1 u0 H.
        rewrite bind_ret_l.
        unfold DSHPower_tfor in IHn.
        subst.
        apply IHn.
      + intros x0 i j.
        reflexivity.
  Qed.

  Lemma DSHPower_as_tfor : forall σ ne x_p xoffset y_p yoffset f initial,
      denoteDSHOperator σ (DSHPower ne (x_p,xoffset) (y_p,yoffset) f initial)
                        ≈
          '(x_i,x_size) <- denotePExpr σ x_p ;;
          '(y_i,y_size) <- denotePExpr σ y_p ;;
          lift_Serr (assert_nat_neq "DSHPower 'x' must not be equal 'y'" x_i y_i);;
          x <- trigger (MemLU "Error looking up 'x' in DSHPower" x_i) ;;
          y <- trigger (MemLU "Error looking up 'y' in DSHPower" y_i) ;;
          n <- denoteNExpr σ ne ;; (* [n] denoteuated once at the beginning *)
          xoff <- denoteNExpr σ xoffset ;;
          yoff <- denoteNExpr σ yoffset ;;
          lift_Derr (assert_NT_lt "DSHPower 'y' offset out of bounds" yoff y_size) ;;
          let y' := mem_add (MInt64asNT.to_nat yoff) initial y in
          y'' <- DSHPower_tfor (protect_p σ y_p) (MInt64asNT.to_nat n) f x y' (MInt64asNT.to_nat xoff) (MInt64asNT.to_nat yoff) ;;
          trigger (MemSet y_i y'').
  Proof.
    intros σ ne x_p xoffset y_p yoffset f initial.
    unfold denoteDSHOperator.
    cbn.
    repeat (eapply eutt_clo_bind_returns; [reflexivity|intros; try break_match_goal; subst]).
    rewrite denoteDSHPower_as_tfor.
    reflexivity.
  Qed.

  Lemma DSHPower_intepreted_as_tfor : forall σ ne x_p xoffset y_p yoffset f initial E m,
      interp_helix (E := E) (denoteDSHOperator σ (DSHPower ne (x_p,xoffset) (y_p,yoffset) f initial)) m
                        ≈
      interp_helix (E := E)
      ('(x_i,x_size) <- denotePExpr σ x_p ;;
       '(y_i,y_size) <- denotePExpr σ y_p ;;
        _ <- lift_Serr (assert_nat_neq "DSHPower 'x' must not be equal 'y'" x_i y_i);;
       x <- trigger (MemLU "Error looking up 'x' in DSHPower" x_i) ;;
       y <- trigger (MemLU "Error looking up 'y' in DSHPower" y_i) ;;
       n <- denoteNExpr σ ne ;; (* [n] denoteuated once at the beginning *)
       xoff <- denoteNExpr σ xoffset ;;
       yoff <- denoteNExpr σ yoffset ;;
       lift_Derr (assert_NT_lt "DSHPower 'y' offset out of bounds" yoff y_size) ;;
       let y' := mem_add (MInt64asNT.to_nat yoff) initial y in
       y'' <- DSHPower_tfor (protect_p σ y_p) (MInt64asNT.to_nat n) f x y' (MInt64asNT.to_nat xoff) (MInt64asNT.to_nat yoff) ;;
       trigger (MemSet y_i y'')) m.
  Proof.
    intros σ ne x_p xoffset y_p yoffset f initial E m.

    rewrite DSHPower_as_tfor.
    reflexivity.
  Qed.

  Definition DSHPower_code (px py xv yv : raw_id) (xtyp xptyp : typ) (x : ident) (src_nexpr : exp typ) (fexpr : exp typ) (fexpcode : code typ) (storeid1 : int) :=
    ([
      (IId px,  INSTR_Op (OP_GetElementPtr
                            xtyp (xptyp, (EXP_Ident x))
                            [(IntType, EXP_Integer 0%Z);
                            (IntType, src_nexpr)]

      ));
    (IId xv, INSTR_Load false TYPE_Double
                        (TYPE_Pointer TYPE_Double,
                         (EXP_Ident (ID_Local px)))
                        (ret 8%Z));
    (IId yv, INSTR_Load false TYPE_Double
                        (TYPE_Pointer TYPE_Double,
                         (EXP_Ident (ID_Local py)))
                        (ret 8%Z))
    ]
      ++ fexpcode ++
      [
        (IVoid storeid1, INSTR_Store false
                                     (TYPE_Double, fexpr)
                                     (TYPE_Pointer TYPE_Double,
                                      (EXP_Ident (ID_Local py)))
                                     (ret 8%Z))
      ])%list.

  Definition DSHPower_block body_block_id loopcontblock (px py xv yv : raw_id) (xtyp xptyp : typ) (x : ident) (src_nexpr : exp typ) (fexpr : exp typ) (fexpcode : code typ) (storeid1 : int) : LLVMAst.block typ :=
    {|
    blk_id    := body_block_id ;
    blk_phis  := [];
    blk_code  := DSHPower_code px py xv yv xtyp xptyp x src_nexpr fexpr fexpcode storeid1;
    blk_term  := TERM_Br_1 loopcontblock;
    blk_comments := None
    |}.

  (* be careful about local_scope_modif *)
  Lemma DSHPower_body_eutt :
    forall σ f x y xoffset yoffset acc px py xvid yv xtyp xptyp x_c src_nexpr fexpr fexpcode storeid loopcontblock g li mV mH _label body_entry,
          eutt
            (fun x y => True)
            (interp_helix (DSHPower_tfor_body σ f x y xoffset yoffset acc) mH)
            (interp_cfg (denote_ocfg (convert_typ [] [(DSHPower_block body_entry loopcontblock px py xvid yv xtyp xptyp x_c src_nexpr fexpr fexpcode storeid)]) (_label, body_entry)) g li mV).
  Proof.
    intros σ f x y xoffset yoffset acc px py xvid yv xtyp xptyp x_c src_nexpr fexpr fexpcode storeid
           loopcontblock g li mV mH _label body_entry.
    cbn* in *; simp.
    break_match_goal; simp.
    - admit.
    - break_match_goal; simp.
      + admit.
      + unfold DSHPower_block. cbn.
        unfold fmap. unfold Fmap_block.
        cbn.
        rewrite denote_ocfg_unfold_in.
        2: { apply find_block_eq; auto. }

        cbn.
        rewrite denote_block_unfold.
        cbn.
        vstep.
        hstep.
        rewrite denote_no_phis.
        rewrite bind_ret_l.
        vstep.
        rewrite denote_code_cons.
  Admitted.

End DSHPower_is_tfor.

(* The result is a branch *)
Definition branches (to : block_id) (mh : memoryH * ()) (c : config_cfg_T (block_id * block_id + uvalue)) : Prop :=
  match c with
  | (m,(l,(g,res))) => exists from, res ≡ inl (from, to)
  end.

Definition genIR_post (σ : evalContext) (s1 s2 : IRState) (to : block_id) (li : local_env)
  : Rel_cfg_T unit ((block_id * block_id) + uvalue) :=
  lift_Rel_cfg (state_invariant σ s2) ⩕
               branches to ⩕
               (fun sthf stvf => local_scope_modif s1 s2 li (fst (snd stvf))).

(* TODO: probably want to move this ltac *)
Ltac get_mem_eqs :=
  cbn in *;
  repeat match goal with
         | H: (lift_Rel_cfg (state_invariant ?σ1 ?s3) ⩕ genNExpr_post ?e ?σ2 ?s1 ?s2 ?mh (mk_config_cfg ?mv ?l ?g)) (?mh', ?t) (?mv', (?l', (?g', ()))) |- _
           => apply genNExpr_memoryV in H
         end.

Ltac solve_mem_eq :=
  get_mem_eqs; subst;
  reflexivity.

Ltac solve_dtyp_fits_mem_eq :=
  match goal with
  | H: dtyp_fits ?m1 ?ptr ?τ
    |- dtyp_fits ?m2 ?ptr ?τ
    => let MEM := fresh "MEM" in assert (m2 ≡ m1) as MEM by solve_mem_eq; rewrite MEM; assumption
  end.

(* TODO: expand this. Just trying to figure out this case first *)
Ltac solve_dtyp_fits :=
  first [ solve_dtyp_fits_mem_eq
        | eapply dtyp_fits_array_elem; [eauto|eassumption|eauto]
        ].

Lemma DSHPower_correct:
  ∀ (n : NExpr) (src dst : MemRef) (f : AExpr) (initial : binary64) (s1 s2 : IRState) (σ : evalContext) (memH : memoryH) (nextblock bid_in bid_from : block_id) (bks : list (LLVMAst.block typ)) (g : global_env)
    (l : local_env) (memV : memoryV),
    genIR (DSHPower n src dst f initial) nextblock s1 ≡ inr (s2, (bid_in, bks))
    → bid_bound s1 nextblock
    → state_invariant σ s1 memH (memV, (l, g))
    → Gamma_safe σ s1 s2
    → no_failure (E := E_cfg) (interp_helix (denoteDSHOperator σ (DSHPower n src dst f initial)) memH)
    → eutt (succ_cfg (genIR_post σ s1 s2 nextblock l)) (interp_helix (denoteDSHOperator σ (DSHPower n src dst f initial)) memH) (interp_cfg (denote_ocfg (convert_typ [] bks) (bid_from, bid_in)) g l memV).
Proof.
  intros n src dst f initial s1 s2 σ memH nextblock bid_in bid_from bks g l memV GEN NEXT PRE GAM NOFAIL.

  pose proof generates_wf_ocfg_bids _ NEXT GEN as WFOCFG.
  pose proof inputs_bound_between _ _ _ GEN as INPUTS_BETWEEN.
  pose proof genWhileLoop_entry_in_scope _ _ _ GEN as ENTRY_IN.

  cbn in * |-; simp.
  rewrite DSHPower_as_tfor; cbn.
  inv_resolve_PVar Heqs0.
  inv_resolve_PVar Heqs1.
  unfold denotePExpr in *.
  cbn* in *.
  destruct u.
  simp; try_abs.

  assert (incLocalNamed "Power_i" i21
                        ≡ inr
                        ({|
                            block_count := block_count i21;
                            local_count := S (local_count i21);
                            void_count := void_count i21;
                            Γ := Γ i21 |}, Name ("Power_i" @@ string_of_nat (local_count i21)))) as LC_Gen by reflexivity.

  repeat apply no_failure_Ret in NOFAIL.
  break_match_hyp; try_abs.
  repeat apply no_failure_Ret in NOFAIL.
  rename Heqs0 into NO_ALIAS_XY.

  do 2 (apply no_failure_helix_LU in NOFAIL; destruct NOFAIL as (? & NOFAIL & ?); cbn in NOFAIL).

  (* Symbolically reducing the concrete prefix on the Helix side *)
  hred.
  rewrite NO_ALIAS_XY.
  hred.
  hstep; [eassumption |].
  hred; hstep; [eassumption |].
  hred.

  rename l0 into loop_blocks.

  assert (wf_ocfg_bid loop_blocks) as WF_loop_blocks.
  { eapply wf_ocfg_bid_add_comment; eauto.
  }
  assert (free_in_cfg loop_blocks nextblock) as FREE_loop_blocks_nextblock.
  {
    rewrite Forall_forall in INPUTS_BETWEEN. intros IN. subst.
    rewrite inputs_convert_typ, add_comment_inputs in INPUTS_BETWEEN.
    apply INPUTS_BETWEEN in IN; clear INPUTS_BETWEEN.
    eapply not_bid_bound_between; eauto.
  }

  assert (~ (b ≡ bid_in \/ False)) as BBID_IN. (* easier than writing out all the body blocks *)
  { (* entry_id (bid_in), is not in the outputs of body_blocks *)
    intros [CONTRA | []].
    subst.

    Set Nested Proofs Allowed.
    eapply genWhileLoop_entry_block in Heqs2.
    inv Heqs2.
    Transparent incBlockNamed.
    inv Heqs.
    Opaque incBlockNamed.
  }

  (* body_etry (* b0 *) is in inputs body_blocks *)
  assert (b0 ≡ b0 ∨ False) as B0B0 by auto.
  epose proof @genWhileLoop_init' _ _ _ _ _ _ _ _ _ _ _ _ _ bid_from Heqs2 WF_loop_blocks BBID_IN FREE_loop_blocks_nextblock B0B0 as INIT.
  cbn in INIT.
  destruct INIT as (body_bks' & GEN' & INIT & WF_BODY_BKS' & FREE_BODY_BKS'_NEXTBLOCK).
  clear Heqs2.

  (* TODO: use matches to get sb1 / sb2 *)
  match goal with
  | H: genWhileLoop ?prefix ?x ?y ?loopvar ?loopcontblock ?body_entry ?body_blocks [] ?nextblock ?s1 ≡ inr (?s2, (?bid_in, ?bks)) |- _
    => epose proof @genWhileLoop_tfor_correct_nexpr prefix loopvar loopcontblock body_entry body_blocks nextblock bid_in σ {|
           block_count := block_count i21;
           local_count := S (local_count i21);
           void_count := void_count i21;
           Γ := Γ i21 |} s2 i16 {|
           block_count := block_count i21;
           local_count := S (local_count i21);
           void_count := void_count i21;
           Γ := Γ i21 |} bks as LOOPTFOR
  end.

  (* s1 s2 sb1 sb2

     sb1 << sb2
     local_count sb2 ≡ local_count s1

     What's modified in l_loop and l_AExpr?

   *)

  assert (In b0
               (inputs
                  [{| blk_id := b0;
                      blk_phis := [];
                      blk_code :=
                        (IId r2, INSTR_Load false TYPE_Double (TYPE_Pointer TYPE_Double, (EXP_Ident (ID_Local r))) (Some 8%Z))
                          :: c2 ++
                          [(IVoid i15,
                            INSTR_Store false (TYPE_Double, e2)
                                        (TYPE_Pointer TYPE_Double, (EXP_Ident (ID_Local r))) (Some 8%Z)) : (instr_id * instr typ)];
                      blk_term := TERM_Br_1 b;
                      blk_comments := None
                   |}])) as Inb0 by auto.

  assert (is_correct_prefix "Power") as PREF_POWER by solve_prefix.

  assert (lid_bound_between i16 {|
           block_count := block_count i21;
           local_count := S (local_count i21);
           void_count := void_count i21;
           Γ := Γ i21 |}
                            ("Power_i" @@ string_of_nat (local_count i21))) as LID_BOUND_BETWEEN_POWER_I by solve_lid_bound_between.

  specialize (LOOPTFOR Inb0 PREF_POWER WF_BODY_BKS' LID_BOUND_BETWEEN_POWER_I).
  specialize (LOOPTFOR FREE_BODY_BKS'_NEXTBLOCK).

  clear LID_BOUND_BETWEEN_POWER_I.
  assert (lid_bound_between i21 {|
           block_count := block_count i21;
           local_count := S (local_count i21);
           void_count := void_count i21;
           Γ := Γ i21 |}
                            ("Power_i" @@ string_of_nat (local_count i21))) as LID_BOUND_BETWEEN_POWER_I by solve_lid_bound_between.

  (* Need to know how many times we loop, this is determined by the
  result of evaluating the expression e1 *)
  pose proof Heqs7 as LOOP_END.

  (* Clean up LLVM side a bit *)
  setoid_rewrite add_comment_eutt.

  (* Substitute blocks *)
  rewrite INIT.

  rename r0 into src_ptr_id.
  rename r1 into src_val_id.
  rename r into dst_ptr_id.
  rename r2 into dst_val_id.

  rename e0 into xoff_exp.
  rename e1 into yoff_exp.
  rename e into loop_end_exp.
  rename c0 into xoff_code.
  rename c1 into yoff_code.
  rename c into loop_end_code.

  rename n0 into xoff_nexpr.
  rename n1 into yoff_nexpr.
  rename n into loop_end_nexpr.

  rename n4 into dst_addr_h.
  rename i into dst_size_h.
  rename n5 into src_addr_h.
  rename i2 into src_size_h.

  assert (Γ s1 ≡ Γ s2) as Γ_S1S2.
  { get_gammas.
    apply dropVars_Γ' in Heqs15.
    rewrite <- Heqs14 in Heqs15.
    solve_gamma.
  }

  (* Need to reorder the nexprs to line things up.

     In helix we evaluate:

     1) loop_end
     2) xoff
     3) yoff

     In LLVM the loop_end is calculated last:

     1) xoff
     2) yoff
     3) loop_end

     I should be able to commute loop_end_code in order to match it up
     with denoteNExpr σ loop_end_nexpr.
   *)

  repeat rewrite convert_typ_code_app.
  repeat setoid_rewrite denote_code_app.

  vstep.
  vred.

  (* loop_end *)
  eapply eutt_clo_bind_returns.
  { eapply genNExpr_correct; [eauto|solve_state_invariant|solve_gamma_safe|eauto].
  }

  intros [[m_loopend t_loopend] |] [mV_loopend [l_loopend [g_loopend []]]] PostLoopEnd RetLoopNExp RetLoopCode; [|inversion PostLoopEnd].
  destruct PostLoopEnd as [PostLoopEndSINV PostLoopEndNExpr]. cbn in PostLoopEndSINV.
  pose proof (Correctness_NExpr.is_almost_pure PostLoopEndNExpr) as [MHPURE [MVPURE GPURE]]; subst.
  vred; hred; vred.

  pose proof NOFAIL as NOFAIL_loopend.
  eapply no_failure_helix_bind_prefix in NOFAIL_loopend.
  eapply no_failure_helix_bind_continuation in NOFAIL; [eauto|eassumption].

  pose proof NOFAIL as NOFAIL_xoff.
  eapply no_failure_helix_bind_prefix in NOFAIL_xoff.

  (* xoff *)
   eapply eutt_clo_bind_returns.
  { eapply genNExpr_correct; [eauto|solve_state_invariant|solve_gamma_safe|eauto].
  }

  intros [[m_xoff xoff_res] |] [mV_xoff [l_xoff [g_xoff []]]] PostXoff RetXoffNExp RetXoffCode; [|inversion PostXoff].
  destruct PostXoff as [PostXoffSINV PostXoffNExpr]. cbn in PostXoffSINV.
  pose proof (Correctness_NExpr.is_almost_pure PostXoffNExpr) as [MHPURE [MVPURE GPURE]]; subst.
  vred; hred; vred.

  eapply no_failure_helix_bind_continuation in NOFAIL; [eauto|eassumption].
  pose proof NOFAIL as NOFAIL_yoff.
  eapply no_failure_helix_bind_prefix in NOFAIL_yoff.

  (* yoff *)
  eapply eutt_clo_bind_returns.
  { eapply genNExpr_correct; [eauto|solve_state_invariant|solve_gamma_safe|eauto].
  }

  intros [[m_yoff yoff_res] |] [mV_yoff [l_yoff [g_yoff []]]] PostYoff RetYoffNExp RetYoffCode; [|inversion PostYoff].
  destruct PostYoff as [PostYoffSINV PostYoffNExpr]. cbn in PostYoffSINV.
  pose proof (Correctness_NExpr.is_almost_pure PostYoffNExpr) as [MHPURE [MVPURE GPURE]]; subst.

  Ltac nexpr_modifs :=
    repeat
      match goal with
      | POST : genNExpr_post _ _ _ _ _ _ _ _ |- _
        => eapply Correctness_NExpr.extends in POST; cbn in POST
      end.

  assert (local_scope_modif i5 i7 l l_xoff /\ local_scope_modif i5 i8 l l_yoff) as [LSM_xoff LSM_yoff].
  {
    nexpr_modifs.
    epose proof local_scope_modif_trans'' PostLoopEndNExpr PostXoffNExpr as LSM_xoff.
    repeat (forward LSM_xoff; solve_local_count).
    epose proof local_scope_modif_trans'' LSM_xoff PostYoffNExpr as LSM_yoff.
    repeat (forward LSM_yoff; solve_local_count).
    auto.
  }

  assert (WF_IRState σ i5) as WFi5.
  { eapply WF_IRState_Γ; eauto.
    solve_gamma.
  }

  assert (gamma_bound i5) as GBi5.
  { eapply gamma_bound_mono.
    { eapply st_gamma_bound in PRE. apply PRE. }
    solve_local_count.
    solve_gamma.
  }

  hred.

  eapply no_failure_helix_bind_continuation in NOFAIL; [eauto|eassumption].
  pose proof NOFAIL as NOFAIL_Assert.
  eapply no_failure_helix_bind_prefix in NOFAIL_Assert.

  (* TODO: I feel like I should be able to automate all of this no failure stuff. *)
  break_match_goal.
  { exfalso; eapply failure_helix_throw; eassumption. }
  rewrite bind_ret_l in NOFAIL.

  hred.

  match goal with
  | H: assert_NT_lt _ _ _ ≡ inr _ |- _
    =>
    unfold assert_NT_lt, assert_true_to_err in H;
      break_if; inv H
  end.

  match goal with
  | H: (_ <? _) ≡ true |- _
    => rename H into LT_yoff
  end.

  (* Need to figure out the corresponding pointer for id (i3).

     Need to get this from the memory_invariant *)

  pose proof state_invariant_memory_invariant PRE as MINV_YOFF.
  pose proof state_invariant_memory_invariant PRE as MINV_XOFF.
  unfold memory_invariant in MINV_YOFF.
  unfold memory_invariant in MINV_XOFF.
  specialize (MINV_YOFF n3 _ _ _ _ Heqo0 LUn0).
  specialize (MINV_XOFF n2 _ _ _ _ Heqo LUn).
  cbn in MINV_YOFF, MINV_XOFF.

  destruct MINV_YOFF as (ptrll_yoff & τ_yoff & TEQ_yoff & FITS_yoff & INLG_yoff & MLUP_yoff).
  specialize (MLUP_yoff eq_refl) as (bkh_yoff & MLUP_yoff & GETARRAYCELL_yoff).

  destruct MINV_XOFF as (ptrll_xoff & τ_xoff & TEQ_xoff & FITS_xoff & INLG_xoff & MLUP_xoff).
  specialize (MLUP_xoff eq_refl) as (bkh_xoff & MLUP_xoff & GETARRAYCELL_xoff).

  rewrite MLUP_xoff in H; symmetry in H; inv H.
  rewrite MLUP_yoff in H0; symmetry in H0; inv H0.

  inv TEQ_yoff. inv TEQ_xoff. cbn. vred.

  edestruct denote_instr_gep_array_no_read with (m:=mV_yoff) (g:=g_yoff) (l:=l_yoff) (size:=(Z.to_N (Int64.intval i1))) (τ:=DTYPE_Double) (i:=src_ptr_id) (ptr := @EXP_Ident dtyp i0) (a:= ptrll_xoff) (e_ix:=convert_typ [] xoff_exp) (ix:=(MInt64asNT.to_nat xoff_res)).

  { destruct i0.
    { rewrite denote_exp_GR.
      change (UVALUE_Addr ptrll_xoff) with (dvalue_to_uvalue (DVALUE_Addr ptrll_xoff)).
      reflexivity.
      auto.
    }
    { assert (lid_bound s1 id) as LID_BOUND0 by (eapply st_gamma_bound; solve_lid_bound).
      rewrite denote_exp_LR.
      change (UVALUE_Addr ptrll_yoff) with (dvalue_to_uvalue (DVALUE_Addr ptrll_yoff)).
      reflexivity.
      cbn.

      nexpr_modifs.
      Ltac solve_alist_in_yoff upper :=
        erewrite <- local_scope_modif_bound_before with (s2:=upper); eauto;
        repeat (eapply local_scope_modif_add'; [solve_lid_bound_between|]);
        match goal with
        | LSM1 : local_scope_modif ?s1 ?s2 _ ?l2,
          LSM2 : local_scope_modif ?s12 ?s22 ?l1 _
          |- local_scope_modif _ _ ?l1 ?l2
          => eapply (@local_scope_modif_shrink _ s12 s2); [solve_local_scope_modif| |]; solve_local_count
        end.

      solve_alist_in_yoff s2.
    }
  }

  { apply Correctness_NExpr.exp_correct in PostXoffNExpr.
    cbn in PostXoffNExpr.
    rewrite repr_of_nat_to_nat.
    destruct PostYoffNExpr.

    eapply PostXoffNExpr; [solve_local_scope_preserved | solve_gamma_preserved].
  }

  { typ_to_dtyp_simplify.
    erewrite <- from_N_intval; eauto.
  }

  rename x into src_addr.
  destruct H as [HSRC_GEP HSRC_GEP_EUTT].
  cbn.

  replace (match i0 with | ID_Global rid => ID_Global rid | ID_Local lid => ID_Local lid end) with (i0) by (destruct i0; auto).

  rewrite HSRC_GEP_EUTT.

  vred; hred; vred.

  edestruct denote_instr_gep_array_no_read with (m:=mV_yoff) (g:=g_yoff) (l:=(alist_add src_ptr_id (UVALUE_Addr src_addr) l_yoff)) (size:=(Z.to_N (Int64.intval i4))) (τ:=DTYPE_Double) (i:=dst_ptr_id) (ptr := @EXP_Ident dtyp i3) (a:= ptrll_yoff) (e_ix:=fmap (typ_to_dtyp []) yoff_exp) (ix:=(MInt64asNT.to_nat yoff_res)).
  { destruct i3 as [id | id].
    { rewrite denote_exp_GR.
      change (UVALUE_Addr ptrll_yoff) with (dvalue_to_uvalue (DVALUE_Addr ptrll_yoff)).
      reflexivity.
      auto.
    }
    { assert (lid_bound s1 id) as LID_BOUND0 by (eapply st_gamma_bound; solve_lid_bound).
      rewrite denote_exp_LR.
      change (UVALUE_Addr ptrll_yoff) with (dvalue_to_uvalue (DVALUE_Addr ptrll_yoff)).
      reflexivity.
      cbn.

      nexpr_modifs.
      solve_alist_in_yoff s2.
    }
  }

  { apply Correctness_NExpr.exp_correct in PostYoffNExpr.
    cbn in PostYoffNExpr.
    rewrite repr_of_nat_to_nat.

    eapply PostYoffNExpr; [solve_local_scope_preserved | solve_gamma_preserved].
  }

  { typ_to_dtyp_simplify.
    erewrite <- from_N_intval; eauto.
  }

  rename x into dst_addr.
  destruct H as [HDST_GEP HDST_GEP_EUTT].
  cbn.

  replace (match i3 with | ID_Global rid => ID_Global rid | ID_Local lid => ID_Local lid end) with (i3) by (destruct i3; auto).

  rewrite HDST_GEP_EUTT.

  vred; hred; vred.

  (* Store for the initial value *)
  edestruct denote_instr_store_exists with (a := dst_addr) (m:=mV_yoff).

  { cbn.
    apply denote_exp_double.
  }

  { apply denote_exp_LR.
    apply alist_find_add_eq.
  }

  { reflexivity.
  }

  { constructor.
  }

  { typ_to_dtyp_simplify.
    epose proof (vellvm_helix_ptr_size _ LUn0 Heqo0 PRE); subst.

    pose proof (from_N_intval _ EQsz0) as EQ.
    apply Znat.Z2N.inj in EQ; [|apply Int64_intval_pos|apply Int64_intval_pos].

    rewrite <- EQ in *.
    eapply dtyp_fits_array_elem; [eapply FITS_yoff|..]; eauto.

    rewrite Znat.Z2N.id; [|apply Int64_intval_pos].
    apply NPeano.Nat.ltb_lt in LT_yoff.
    pose proof Znat.inj_lt _ _ LT_yoff as LT.
    unfold MInt64asNT.to_nat in LT.
    rewrite Znat.Z2Nat.id in LT; [|apply Int64_intval_pos].
    rewrite Znat.Z2Nat.id in LT; [|apply Int64_intval_pos].

    rewrite repr_of_nat_to_nat.
    apply LT.
  }

  rename x into mV_init.
  destruct H as [WRITE_INIT STORE_INIT].
  cbn in STORE_INIT.
  cbn.
  rewrite STORE_INIT.

  vred.

  cbn in PostLoopEndNExpr.
  pose proof Correctness_NExpr.exp_correct PostLoopEndNExpr as PostLoopEndNExprCorrect.
  cbn in PostLoopEndNExprCorrect.

  epose proof (denote_exp_i64 t_loopend) as T_LOOPEND_EUTT.
  assert (eutt Logic.eq (interp_cfg (translate exp_to_instr (denote_exp (Some (DTYPE_I (Npos 64))) (EXP_Integer (Integers.Int64.intval t_loopend)))) g_yoff l_loopend mV_yoff)
               (interp_cfg
                  (translate exp_to_instr
                             (denote_exp (Some (DTYPE_I (Npos 64)))
                                         (convert_typ [] loop_end_exp))) g_yoff l_loopend mV_yoff)) as EUTT_INT.
  rewrite T_LOOPEND_EUTT.
  rewrite PostLoopEndNExprCorrect.
  reflexivity.

  solve_local_scope_preserved.
  solve_gamma_preserved.

  specialize (LOOPTFOR loop_end_nexpr i5 i6 m_yoff m_yoff loop_end_exp loop_end_code WFi5 GBi5 Heqs3).
  repeat (forward LOOPTFOR; [solve_local_count|]).
  specialize (LOOPTFOR t_loopend RetLoopNExp).

  forward LOOPTFOR. eauto.

  (* TODO: may be able to separate this out into the DSHPower_body_eutt lemma *)
  unfold DSHPower_tfor.
  rewrite interp_helix_tfor; [|lia].

  match goal with
    |- eutt _ (ITree.bind' _ (tfor ?bod _ _ _)) _ => specialize (LOOPTFOR _ bod)
  end.

  (* Will need to set up loop invariants and such, just like loop case *)
  (* Invariant at each iteration *)

  set (I := (fun (k : nat) (mH : option (memoryH * mem_block)) (stV : memoryV * (local_env * global_env)) =>
               match mH with
               | None => False
               | Some (mH,mb) =>
                 match stV with
                 | (mV, (l, g)) =>
                   state_invariant (protect σ n3) s2 mH stV /\
                   alist_find dst_ptr_id l ≡ Some (UVALUE_Addr dst_addr) /\
                   alist_find src_ptr_id l ≡ Some (UVALUE_Addr src_addr) /\
                   local_scope_modif i16 s2 (alist_add dst_ptr_id (UVALUE_Addr dst_addr) (alist_add src_ptr_id (UVALUE_Addr src_addr) l_yoff)) l /\
                   g ≡ g_yoff /\
                   allocated ptrll_yoff mV /\
                   (* Not sure if this is the right block *)
                   Returns (Some (mH, mb))
                           (@interp_helix _ E_cfg (tfor
                                                     (λ (_ : nat) (acc : mem_block),
                                                      DSHPower_tfor_body (protect σ n3) f bkh_xoff
                                                                         (mem_add (MInt64asNT.to_nat yoff_res) initial bkh_yoff)
                                                                         (MInt64asNT.to_nat xoff_res) (MInt64asNT.to_nat yoff_res) acc) 0 k
                                                     (mem_add (MInt64asNT.to_nat yoff_res) initial bkh_yoff)) m_yoff) /\
                   (forall y, y ≢ (MInt64asNT.to_nat yoff_res) -> mem_lookup y mb ≡ mem_lookup y bkh_yoff) /\
                   exists v, mem_lookup (MInt64asNT.to_nat yoff_res) mb ≡ Some v /\
                        ext_memory mV_init dst_addr DTYPE_Double (UVALUE_Double v) mV
                 end
               end)).

  (* Precondition *)
  set (P := (fun (mH : option (memoryH * mem_block)) (stV : memoryV * (local_env * global_env)) =>
               match mH with
               | None => False
               | Some (mH,mb) =>
                 match stV with
                 | (mV, (l, g)) =>
                   state_invariant (protect σ n3) s2 mH stV /\
                   alist_find dst_ptr_id l ≡ Some (UVALUE_Addr dst_addr) /\
                   alist_find src_ptr_id l ≡ Some (UVALUE_Addr src_addr) /\
                   local_scope_modif i16 s2 (alist_add dst_ptr_id (UVALUE_Addr dst_addr) (alist_add src_ptr_id (UVALUE_Addr src_addr) l_yoff)) l /\
                   g ≡ g_yoff /\
                   mH ≡ m_yoff /\
                   mb ≡ mem_add (MInt64asNT.to_nat yoff_res) initial bkh_yoff /\
                   mV ≡ mV_init
                 end
               end)).

  (* Postcondition *)
  set (Q := (fun (mH : option (memoryH * mem_block)) (stV : memoryV * (local_env * global_env)) =>
               match mH with
               | None => False
               | Some (mH,mb) => state_invariant σ s2 (memory_set mH dst_addr_h mb) stV
               end)).

  specialize (LOOPTFOR I P Q (Some (m_yoff, mem_add (MInt64asNT.to_nat yoff_res) initial bkh_yoff))).

  (* Relating iterations of the bodies *)
  forward LOOPTFOR.
  { intros g_loop l_loop mV_loop [[mH_loop mb_loop] |] k _label [HI [POWERI [LOOPEND_EXPID [BOUND RETURNS]]]]; [|inv HI].
    cbn in HI.
    destruct HI as [LINV_SINV [LINV_DST_PTR_ID [LINV_SRC_PTR_ID [LINV_LSM [LINV_GLOBALS [LINV_ALLOC [LINV_RET [LINV_HELIX_MB_OLD [v [LINV_HELIX_MB_NEW LINV_MEXT]]]]]]]]]].
    pose proof LINV_MEXT as [LINV_MEXT_NEW LINV_MEXT_OLD].
    unfold DSHPower_tfor_body.

    unfold mem_lookup_err.
    unfold trywith.

    rewrite denoteDSHPower_as_tfor in NOFAIL.
    unfold DSHPower_tfor in NOFAIL.

    eapply no_failure_helix_bind_prefix in NOFAIL.
    rewrite interp_helix_tfor in NOFAIL; [|lia].
    eapply no_failure_tfor with (k0:=k) in NOFAIL; [|lia|eauto].
    cbn in NOFAIL.

    break_match_goal.
    2: { unfold mem_lookup_err in *.
         rewrite Heqo1 in NOFAIL.
         cbn in NOFAIL.
         eapply no_failure_bind_prefix in NOFAIL.
         eapply no_failure_helix_bind_prefix in NOFAIL.
         eapply failure_helix_throw in NOFAIL.
         inv NOFAIL.
    }
    rename Heqo1 into MEMLUP_xoff.

    unfold mem_lookup_err in NOFAIL.
    rewrite MEMLUP_xoff in NOFAIL.

    rewrite LINV_HELIX_MB_NEW in NOFAIL.
    cbn in NOFAIL.
    repeat rewrite bind_ret_l in NOFAIL.
    rewrite LINV_HELIX_MB_NEW.
    cbn.
    repeat rewrite bind_ret_l.

    rewrite denote_ocfg_unfold_in.
    2: {
      apply find_block_eq; auto.
    }

    cbn; vred.

    rewrite denote_no_phis.
    vred; cbn.

    rewrite denote_code_cons.
    vred.

    pose proof (write_correct WRITE_INIT) as [WRITE_ALLOCATED WRITE_WRITTEN].
    specialize (WRITE_WRITTEN DTYPE_Double).
    forward WRITE_WRITTEN; [constructor|].
    destruct WRITE_WRITTEN as [MEXT_INIT_NEW MEXT_INIT_OLD].

    assert (allocated ptrll_xoff mV_yoff) as PTRLL_XOFF_ALLOCATED_mV_yoff by solve_allocated.
    assert (allocated src_addr mV_yoff) as SRC_ALLOCATED_mV_yoff by solve_allocated.

    assert (no_overlap_dtyp dst_addr DTYPE_Double src_addr DTYPE_Double) as NOALIAS.
    { pose proof NO_ALIAS_XY.
      clear NO_ALIAS_XY.
      rename H into NO_ALIAS_XY.
      unfold assert_nat_neq in NO_ALIAS_XY.

      destruct (src_addr_h =? dst_addr_h) eqn:EQ.
      - inv NO_ALIAS_XY.
      - apply beq_nat_false in EQ.
        destruct PRE.

        (* TODO: should this be a lemma? *)
        assert (i0 ≢ i3) as ID_NEQ.
        { intros CONTRA.
          rewrite CONTRA in LUn.
          epose proof (st_no_id_aliasing _ _ _ _ _ _ _ Heqo Heqo0 LUn LUn0).
          subst.

          rewrite Heqo0 in Heqo.
          inv Heqo.
          contradiction.
        }

        unfold no_overlap_dtyp.
        unfold no_overlap.
        left.

        rewrite <- (handle_gep_addr_array_same_block _ _ _ _ HDST_GEP).
        rewrite <- (handle_gep_addr_array_same_block _ _ _ _ HSRC_GEP).
        intros BLOCKS; symmetry in BLOCKS; revert BLOCKS.

        cbn in st_no_llvm_ptr_aliasing.
        eapply st_no_llvm_ptr_aliasing.
        5: eauto.
        3-4: eauto.
        all: eauto.
    }

    (* Load src *)
    rewrite denote_instr_load.
    2: {
      apply denote_exp_LR.

      cbn.
      eauto.
    }
    2: {
      erewrite LINV_MEXT_OLD; eauto; [|solve_allocated].
      erewrite MEXT_INIT_OLD; eauto.

      solve_read.
    }

    vred.
    rewrite map_app.
    cbn.
    typ_to_dtyp_simplify.
    rewrite denote_code_cons.
    vred; hred.

    (* Load dst *)
    rewrite denote_instr_load; [|apply denote_exp_LR; cbn; solve_alist_in|solve_read].

    cbn.
    vred.

    rewrite denote_code_app.
    vred.
    rewrite bind_bind.

    change (map (λ '(id1, i), (Endo_instr_id id1, Fmap_instr typ dtyp (typ_to_dtyp []) i)) c2) with (convert_typ [] c2).

    eapply eutt_clo_bind_returns.
    {
      eapply genAExpr_correct.
      eauto.
      { eapply state_invariant_enter_scope_DSHCType' with (s1:={| block_count := block_count i19; local_count := local_count i19; void_count := void_count i19; Γ := (ID_Local dst_val_id, TYPE_Double) :: Γ i19 |}); cbn; eauto.

        eapply lid_bound_before; [solve_lid_bound | solve_local_count].
        2: solve_alist_in.

        { pose proof GAM.
          unfold Gamma_safe in H.
          assert (~ in_Gamma σ s1 src_val_id) by solve_not_in_gamma.
          assert (Γ s1 ≡ Γ i19) by solve_gamma.

          eapply not_in_gamma_cons; [cbn; eauto; try solve_gamma | solve_not_in_gamma |].

          (* TODO: add this to solve_not_in_gamma? *)
          intros CONTRA; subst.

          match goal with
          | H1: incLocal _ ≡ inr (_, dst_val_id),
                H2: incLocal _ ≡ inr (_, dst_val_id) |- _
            => eapply lid_bound_between_incLocal in H1;
                eapply lid_bound_between_incLocal in H2;
                eapply state_bound_between_id_separate;[|eapply H1|eapply H2|solve_local_count];
                  eapply incLocalNamed_count_gen_injective
          end.
        }

        eapply state_invariant_enter_scope_DSHCType'; cbn.
        eauto.
        eauto.
        3: solve_local_count.

        eapply lid_bound_before; [solve_lid_bound | solve_local_count].
        eapply not_in_Gamma_Gamma_eq with (s1 := s1); [solve_gamma|solve_not_in_gamma].

        { solve_alist_in.
        }

        eapply state_invariant_same_Γ' with (s1:=s2); eauto.
        solve_gamma.
        { get_gamma_bounds.
          assert (Γ i8 ≡ Γ i19) by solve_gamma.
          eapply gamma_bound_mono.
          apply PostYoffSINV.
          solve_local_count.
          eauto.
        }

        { eapply not_in_Gamma_Gamma_eq; eauto.
          eapply not_in_gamma_protect.
          eapply GAM.
          solve_lid_bound_between.
        }

        eapply state_invariant_same_Γ with (s1:=s2); eauto.
        { eapply not_in_Gamma_Gamma_eq; eauto.
          eapply not_in_gamma_protect.
          eapply GAM.
          solve_lid_bound_between.
        }

      }

      { eapply Gamma_safe_Context_extend.
        eapply Gamma_safe_Context_extend.
        9: { cbn.
             change ((ID_Local dst_val_id, TYPE_Double) :: Γ i19) with (Γ {| block_count := block_count i19; local_count := local_count i19; void_count := void_count i19; Γ := (ID_Local dst_val_id, TYPE_Double) :: Γ i19 |}).
             reflexivity.
        }
        4: {
          cbn.
          reflexivity.
        }

        { eapply Gamma_safe_protect.
          eapply Gamma_safe_shrink; eauto.
          solve_gamma.
          solve_local_count.
        }
        3: {
          instantiate (1 := {| block_count := block_count i20; local_count := local_count i20; void_count := void_count i20; Γ := (ID_Local dst_val_id, TYPE_Double) :: Γ i19 |}).
          cbn.
          solve_gamma.
        }

        all: try (solve [cbn; solve_local_count]).

        { intros ? ?.
          solve_id_neq.
        }

        cbn.
        solve_gamma.

        { intros ? ?.
          solve_id_neq.
        }
      }

      { unfold denoteBinCType in NOFAIL.
        eapply no_failure_bind_prefix in NOFAIL.
        eapply no_failure_helix_bind_prefix in NOFAIL.
        eauto.
      }
    }

    intros [[mH_Aexpr t_Aexpr]|] [mV_Aexpr [l_Aexpr [g_Aexpr []]]] POST RetAexp RetAexpCode; [|inv POST].
    destruct POST as [POSTAEXPRSINV POSTAEXPR].

    hred.
    vred.

    forward LINV_MEXT_NEW; [cbn; lia|].
    edestruct (@read_write_succeeds mV_loop dst_addr _ _ (DVALUE_Double t_Aexpr) LINV_MEXT_NEW) as [mV' WRITE]; [constructor|].

    erewrite denote_instr_store; eauto.

    2: {
      destruct POSTAEXPR.
      cbn in exp_correct.
      cbn in POSTAEXPRSINV.
      eapply exp_correct.
      solve_local_scope_preserved.
      solve_gamma_preserved.
    }
    3: {
      cbn. reflexivity.
    }
    3: {
      destruct POSTAEXPR; cbn in is_almost_pure.
      assert (mV_Aexpr ≡ mV_loop) by intuition; subst.
      apply WRITE.
    }
    2: {
      eapply denote_exp_LR.
      destruct POSTAEXPR.

      cbn in extends.
      cbn.

      erewrite local_scope_modif_out.
      4: eapply extends.
      3: solve_lid_bound_between; cbn; solve_local_count.
      2: cbn; solve_local_count.

      solve_alist_in.
    }

    vred.
    rewrite denote_term_br_1.
    vred.

    cbn.
    rename b into jump_label.
    rewrite denote_ocfg_unfold_not_in.
    vred.
    2: {
      cbn.
      assert (b0 ≢ jump_label) as NEQ by solve_id_neq.
      rewrite find_block_ineq; eauto.
    }

    apply eqit_Ret.
    split; [|split; [|split]].
    - destruct POSTAEXPR.
      cbn in *.
      destruct Mono_IRState.
      + eapply local_scope_preserve_modif_up in extends.
        unfold local_scope_preserved in extends.
        rewrite extends.
        rewrite alist_find_neq.
        2: { intros ID; symmetry in ID; revert ID.
             eapply state_bound_between_separate.
             eapply incLocalNamed_count_gen_injective.
             solve_lid_bound_between.
             solve_lid_bound_between.
             solve_local_count.
        }
        2: { unfold lid_bound_between.
             unfold state_bound_between.
             exists "Power_i". eexists. eexists.
             repeat split; eauto.
             2: solve_local_count.
             instantiate (1 := {|
                             block_count := block_count i21;
                             local_count := S (local_count i21);
                             void_count := void_count i21;
                             Γ := Γ i21 |}).
             solve_local_count.
        }
        solve_alist_in.
      + subst.
        (* Brutally long *)
        solve_alist_in.
    - exists b0. reflexivity.
    - (* I *)
      Opaque mem_lookup. (* TODO: HMMM *)
      cbn.
      split.
      { (* TODO: destruct POSTAEXPR in like one place? Maybe
               automate pulling out almost_pure? *)
        pose proof POSTAEXPR as PUREAEXPR.
        apply is_almost_pure in PUREAEXPR.
        cbn in PUREAEXPR. destruct PUREAEXPR as [? [? ?]].
        subst.
        eauto.

        pose proof POSTAEXPR as AEXPR_LSM.
        eapply extends in AEXPR_LSM.
        cbn in AEXPR_LSM.

        destruct POSTAEXPR.
        cbn in POSTAEXPRSINV.

        destruct POSTAEXPRSINV.
        cbn in st_no_llvm_ptr_aliasing.

        destruct LINV_SINV.
        eauto.

        split; auto.
        (* TODO: can I pull these out into lemmas? *)
        (* TODO: probably similar to state_invariant_escape_scope, but with a write *)
        (* TODO: might want to not destruct and look at the state_invariant_write_double stuff? *)
        - cbn in extends.
          unfold memory_invariant.
          pose proof mem_is_inv as MINV.
          unfold memory_invariant in MINV.
          intros n v0 b τ x NTH_σ NTH_Γ.

          pose proof NTH_σ as NTH_σ_orig.
          pose proof NTH_Γ as NTH_Γ_orig.
          do 2 erewrite <- nth_error_Sn in NTH_σ.
          do 2 erewrite <- nth_error_Sn in NTH_Γ.

          pose proof Heqo0 as NTH_σ_dst.
          apply nth_error_protect_eq' in NTH_σ_dst.
          do 2 erewrite <- nth_error_Sn in NTH_σ_dst.

          cbn in Gamma_cst.
          assert (Γ s2 ≡ Γ i19) as Γ_s2i19 by solve_gamma.

          pose proof LUn0 as NTH_Γ_dst.
          do 2 erewrite <- nth_error_Sn in NTH_Γ_dst.
          rewrite Γ_S1S2 in NTH_Γ_dst.
          rewrite Γ_s2i19 in NTH_Γ_dst.
          rewrite <- Gamma_cst in NTH_Γ_dst.

          rewrite Γ_s2i19 in NTH_Γ.
          rewrite <- Gamma_cst in NTH_Γ.

          specialize (MINV _ _ _ _ _ NTH_σ NTH_Γ).

          (* TODO: automate this? *)
          assert (local_scope_modif s1 s2 l l_Aexpr) as LSM_FULL.
          { nexpr_modifs.
            Ltac solve_single_trans_local_scope_modif :=
              match goal with
              | L1 : local_scope_modif ?s1 ?s2 ?l1 ?l2,
                     L2 : local_scope_modif ?s2 ?s3 ?l2 ?l3
                |- local_scope_modif ?s1 ?s3 ?l1 ?l3
                => eapply (local_scope_modif_trans'' L1 L2); solve_local_count
              end.
            Hint Extern 1 (local_scope_modif _ _ _ _) => solve_single_trans_local_scope_modif : LSM.

            pose proof LINV_LSM as LSM'.
            eapply local_scope_modif_shrink with (s1 := i8) (s4:= s2) in LSM'; solve_local_count.
            eapply local_scope_modif_sub'_l in LSM'; [|solve_lid_bound_between].
            eapply local_scope_modif_sub'_l in LSM'; [|solve_lid_bound_between].
            epose proof local_scope_modif_trans'' LSM_yoff LSM'.
            repeat (forward H; solve_local_count).
            pose proof extends.
            eapply local_scope_modif_shrink with (s1 := i8) (s4:= s2) in H0; solve_local_count.
            eapply local_scope_modif_sub'_l in H0; [|solve_lid_bound_between].
            eapply local_scope_modif_sub'_l in H0; [|solve_lid_bound_between].
            epose proof local_scope_modif_trans'' H H0.
            repeat (forward H4; solve_local_count).
            solve_local_scope_modif.
          }

          destruct x, v0; eauto.
          + cbn in MINV. cbn.
            destruct MINV as (ptr & τ' & TEQ & FIND & READ).
            exists ptr. exists τ'.
            repeat split; eauto.

            pose proof (IRState_is_WF _ _ _ NTH_σ) as (id' & NTH_Γ').
            (* id can not be id_addr because of the different
                     type, and thus must be in a different block *)

            (* Find τ' *)
            rewrite NTH_Γ in NTH_Γ'; inv NTH_Γ'.
            cbn in H1. inv H1.

            eapply write_different_blocks; eauto.
            2: reflexivity.
            2-3: typ_to_dtyp_simplify; constructor.

            rewrite <- (handle_gep_addr_array_same_block _ _ _ _ HDST_GEP); eauto.

            intros EQ; symmetry in EQ; revert EQ.
            eapply st_no_llvm_ptr_aliasing.
            eapply NTH_σ.
            { do 2 rewrite nth_error_Sn.
              apply (nth_error_protect_eq' n3 _ Heqo0).
            }
            eapply NTH_Γ.
            rewrite Gamma_cst.
            do 2 rewrite nth_error_Sn.
            rewrite <- Γ_s2i19. rewrite <- Γ_S1S2.
            eauto.
            { intros CONTRA; inv CONTRA.
              epose proof (st_no_id_aliasing _ _ _ _ _ _ _ NTH_σ NTH_σ_dst NTH_Γ NTH_Γ_dst) as EQ; inv EQ.

              rewrite NTH_Γ in NTH_Γ_dst; inv NTH_Γ_dst.
            }
            eauto.
            { destruct i3.
              - eauto.
              - assert (lid_bound s1 id0) as LID_BOUND0 by (eapply Correctness_Invariants.st_gamma_bound; solve_lid_bound).
                cbn; erewrite <- local_scope_modif_bound_before with (s2:=s2); eauto.
            }
          + cbn in MINV. cbn.
            destruct MINV as (ptr & τ' & TEQ & FIND & READ).
            exists ptr. exists τ'.
            repeat split; eauto.

            pose proof (IRState_is_WF _ _ _ NTH_σ) as (id' & NTH_Γ').
            (* id can not be id_addr because of the different
                     type, and thus must be in a different block *)

            (* Find τ' *)
            rewrite NTH_Γ in NTH_Γ'; inv NTH_Γ'.
            cbn in H1. inv H1.

            eapply write_different_blocks; eauto.
            2: reflexivity.
            2-3: typ_to_dtyp_simplify; constructor.

            rewrite <- (handle_gep_addr_array_same_block _ _ _ _ HDST_GEP); eauto.

            intros EQ; symmetry in EQ; revert EQ.
            eapply st_no_llvm_ptr_aliasing.
            eapply NTH_σ.
            { do 2 rewrite nth_error_Sn.
              apply (nth_error_protect_eq' n3 _ Heqo0).
            }
            eapply NTH_Γ.
            rewrite Gamma_cst.
            do 2 rewrite nth_error_Sn.
            rewrite <- Γ_s2i19. rewrite <- Γ_S1S2.
            eauto.
            { intros CONTRA; inv CONTRA.

              epose proof (st_no_id_aliasing _ _ _ _ _ _ _ NTH_σ NTH_σ_dst NTH_Γ NTH_Γ_dst) as EQ; inv EQ.

              rewrite NTH_Γ in NTH_Γ_dst; inv NTH_Γ_dst.
            }
            eauto.
            { destruct i3.
              - eauto.
              - assert (lid_bound s1 id0) as LID_BOUND0 by (eapply Correctness_Invariants.st_gamma_bound; solve_lid_bound).
                cbn; erewrite <- local_scope_modif_bound_before with (s2:=s2); eauto.
            }
          + (* Global vector *)
            cbn in MINV.
            destruct MINV as (ptr & τ' & TEQ & FITS & INLG' & LUP).
            inv TEQ.
            exists ptr. exists τ'.
            repeat split; eauto.
            eapply dtyp_fits_after_write; eauto.
            intros H; destruct b; inv H.
            specialize (LUP eq_refl).
            destruct LUP as (bkh & MLUP_bk & GETARRAYCELL).
            exists bkh.
            split; eauto.
            intros i v0 H.
            specialize (GETARRAYCELL _ _ H).

            erewrite write_untouched_ptr_block_get_array_cell; eauto.

            rewrite <- (handle_gep_addr_array_same_block _ _ _ _ HDST_GEP); eauto.

            eapply st_no_llvm_ptr_aliasing.
            eapply NTH_σ.
            eapply NTH_σ_dst.
            eapply NTH_Γ.
            eapply NTH_Γ_dst.
            2-3: eauto.
            intros CONTRA; inv CONTRA.
            assert (S (S n) ≡ S (S n3)).
            { eapply st_no_id_aliasing; eauto. }
            inv H0.
            apply protect_eq_true in NTH_σ_orig.
            inv NTH_σ_orig.
            { destruct i3.
              - eauto.
              - assert (lid_bound s1 id0) as LID_BOUND0 by (eapply Correctness_Invariants.st_gamma_bound; solve_lid_bound).
                cbn; erewrite <- local_scope_modif_bound_before with (s2:=s2); eauto.
            }
          + (* Local vector *)
            cbn in MINV.
            destruct MINV as (ptr & τ' & TEQ & FITS & INLG' & LUP).
            inv TEQ.
            exists ptr. exists τ'.
            repeat split; eauto.
            eapply dtyp_fits_after_write; eauto.
            intros H; destruct b; inv H.
            specialize (LUP eq_refl).
            destruct LUP as (bkh & MLUP_bk & GETARRAYCELL).
            exists bkh.
            split; eauto.
            intros i v0 H.
            specialize (GETARRAYCELL _ _ H).

            erewrite write_untouched_ptr_block_get_array_cell; eauto.

            rewrite <- (handle_gep_addr_array_same_block _ _ _ _ HDST_GEP); eauto.

            eapply st_no_llvm_ptr_aliasing.
            eapply NTH_σ.
            eapply NTH_σ_dst.
            eapply NTH_Γ.
            eapply NTH_Γ_dst.

            intros CONTRA; inv CONTRA.
            assert (S (S n3) ≡ S (S n)).
            { eapply st_no_id_aliasing; eauto. }
            inv H0.
            apply protect_eq_true in NTH_σ_orig.
            inv NTH_σ_orig.
            { destruct i3.
              - eauto.
              - assert (lid_bound s1 id0) as LID_BOUND0 by (eapply Correctness_Invariants.st_gamma_bound; solve_lid_bound).
                cbn; erewrite <- local_scope_modif_bound_before with (s2:=s2); eauto.
            }
            { destruct i3.
              - eauto.
              - assert (lid_bound s1 id0) as LID_BOUND0 by (eapply Correctness_Invariants.st_gamma_bound; solve_lid_bound).
                cbn; erewrite <- local_scope_modif_bound_before with (s2:=s2); eauto.
            }
        - eapply no_llvm_ptr_aliasing_cons2; eauto.
          { cbn in Gamma_cst.
            rewrite Gamma_cst.
            apply ListUtil.tail_eq.
            apply ListUtil.tail_eq.
            solve_gamma.
          }
      }

      destruct POSTAEXPR. cbn in extends.
      cbn in Mono_IRState.

      split.
      { (* dst_ptr_id *)
        destruct Mono_IRState; subst; solve_alist_in.
      }

      split.
      { (* src_ptr_id *)
        destruct Mono_IRState; subst; solve_alist_in.
      }

      split.
      { eapply local_scope_modif_trans'. (* TODO: automate this? *)
        solve_local_scope_modif.

        eapply local_scope_modif_sub'_l with (r := src_val_id).
        solve_lid_bound_between.

        eapply local_scope_modif_sub'_l with (r := dst_val_id).
        solve_lid_bound_between.

        solve_local_scope_modif.
      }

      split.
      { cbn in is_almost_pure.
        destruct is_almost_pure as [_ [_ G]].
        subst.
        auto.
      }

      split.
      { eapply write_preserves_allocated; eauto.
      }

      split.
      { (* Returns... *)
        rewrite tfor_split with (i := 0) (j:= k) (k0:= S k); try lia.
        rewrite interp_helix_bind.
        eapply Returns_bind; eauto.
        cbn.

        rewrite tfor_unroll; [|lia].
        rewrite interp_helix_bind.

        eapply mem_lookup_err_inr_Some_eq in MEMLUP_xoff.
        erewrite MEMLUP_xoff.
        cbn.
        rewrite bind_ret_l.
        unfold denoteBinCType.

        eapply Returns_bind.

        { rewrite interp_helix_bind.
          eapply Returns_bind; eauto.
          unfold mem_lookup_err.
          rewrite LINV_HELIX_MB_NEW.
          cbn.
          rewrite interp_helix_ret.
          cbn.

          constructor.
          reflexivity.

          rewrite interp_helix_bind.
          eapply Returns_bind; eauto.
          cbn.

          rewrite interp_helix_ret.
          cbn.

          constructor.
          reflexivity.
        }

        cbn.
        rewrite tfor_0.
        rewrite interp_helix_ret.
        cbn.
        constructor.
        reflexivity.
      }

      split.
      { (* Helix memory old *)
        intros y H.
        rewrite mem_lookup_mem_add_neq; eauto.
      }

      exists t_Aexpr.
      split.
      { (* Helix memory extended *)
        rewrite mem_lookup_mem_add_eq; eauto.
      }

      { eapply write_correct in WRITE.
        destruct WRITE as [ALLOCATED WRITTEN].

        eapply ext_memory_trans; eauto.
        eapply WRITTEN. constructor.
      }

    - (* local_scope_modif sb1 sb2 li l *)
      destruct POSTAEXPR. cbn in extends.

      cbn in Mono_IRState.
      cbn in Gamma_cst.

      eapply local_scope_modif_sub'_l with (r:=src_val_id).
      solve_lid_bound_between.

      eapply local_scope_modif_sub'_l with (r:=dst_val_id).
      solve_lid_bound_between.

      solve_local_scope_modif.
  }

  (* TODO: Might want to do more forward reasoning first *)
  match goal with
  | H: _ |- eutt ?R ?x (interp_cfg ?y ?g ?l ?m)
    => rewrite <- (bind_ret_r y)
  end.

  setoid_rewrite interp_cfg3_bind.
  eapply eutt_clo_bind.
  eapply LOOPTFOR.

  all: solve_local_count.

  6: {
    intros [[mH_post mb_post]|] [mV_post [l_post [g_post x_pos]]] [POST [Q_POST LSM_POST]]; [|inv Q_POST].
    rewrite interp_helix_MemSet.
    cbn.
    vred.

    apply eutt_Ret.
    unfold genIR_post.
    split; cbn.

    cbn in Q_POST.
    { (* State invariant preserved *)
      split; eauto.
      eapply st_no_id_aliasing; eauto.
      eapply st_no_dshptr_aliasing; eauto.
      eapply st_no_llvm_ptr_aliasing; eauto.

      (* memory_invariant and id_allocated are the only things that care
             about the altered memory
       *)
      { unfold id_allocated.
        intros n addr0 val H.

        eapply st_id_allocated in Q_POST.
        eauto.
      }

      get_gamma_bounds; solve_gamma_bound.
    }

    split.
    { (* branches *)
      cbn.
      inv POST; eexists; eauto.
    }

    { (* local_scope_modif *)
      cbn.

      (* TODO: incorporate this into solve_local_scope_modif? *)
      repeat
        match goal with
        | POST: genNExpr_post _ _ _ _ _ _ _ _ |- _
          =>  apply Correctness_NExpr.extends in POST; cbn in POST
        end.

      eapply local_scope_modif_shrink with (s3:=s2) (s4:=s2) (s1:=i8) in LSM_POST; [|solve_local_count|solve_local_count].
      apply local_scope_modif_sub'_l in LSM_POST; [|solve_lid_bound_between].
      apply local_scope_modif_sub'_l in LSM_POST; [|solve_lid_bound_between].

      solve_local_scope_modif_trans.
    }
  }

  (* TODO: bunch of stuff to deal with here...

         Better nail down the other admits first so we're more
         confident in the loop invariant.
   *)

  { (* Invariant is stable under the administrative bookkeeping that the loop performs *)
    intros k a l' mV g id1 v BOUND HI.
    unfold I in *.
    destruct a; try inv HI.
    destruct p.
    destruct HI as [HI_SINV [HI_DST_PTR_ID [HI_SRC_PTR_ID [HI_LSM [HI_G [HI_ALLOC [HI_RET [HI_HELIX_MB_OLD [HI_v [HI_HELIX_MB_NEW HI_MEXT]]]]]]]]]].
    pose proof HI_MEXT as [HI_MEXT_NEW HI_MEXT_OLD].
    split.
    { destruct BOUND.
      - eapply state_invariant_same_Γ with (s1 := s2); eauto.

        (* No variables were bound between i21 and s2, so H should give us a contradiction *)
        eapply not_in_Gamma_Gamma_eq; eauto.
        eapply not_in_gamma_protect.
        eapply GAM.
        eapply lid_bound_between_shrink_down.
        2: eapply H.
        cbn.
        solve_local_count.
      - eapply state_invariant_same_Γ with (s1 := s2); eauto.

        (* No variables were bound between i21 and s2, so H should give us a contradiction *)
        eapply not_in_Gamma_Gamma_eq; eauto.
        eapply not_in_gamma_protect.
        eapply GAM.
        eapply lid_bound_between_shrink.
        eauto.
        solve_local_count.
        cbn; solve_local_count.
    }

    split.
    { destruct BOUND.
      solve_alist_in.
      erewrite alist_find_neq.
      solve_alist_in.

      (* TODO: automate this *)
      eapply state_bound_between_separate.
      eapply incLocalNamed_count_gen_injective.
      solve_lid_bound_between.
      solve_lid_bound_between.
      cbn; solve_local_count.
    }
    split.
    { destruct BOUND.
      solve_alist_in.
      erewrite alist_find_neq.
      solve_alist_in.

      (* TODO: automate this *)
      eapply state_bound_between_separate.
      eapply incLocalNamed_count_gen_injective.
      solve_lid_bound_between.
      solve_lid_bound_between.
      solve_local_count.
    }

    repeat split; auto.

    { destruct BOUND.
      - eapply local_scope_modif_add'.
        eapply lid_bound_between_shrink. (* TODO: fix lid_bound_between *)
        eauto.
        solve_local_count.
        solve_local_count.
        solve_local_scope_modif.
      - eapply local_scope_modif_add'.
        eapply lid_bound_between_shrink; [solve_lid_bound_between | | ]; eauto; solve_local_count.
        solve_local_scope_modif.
    }

    exists HI_v.
    auto.
  }

  (* TODO: May need to modify P / Q here *)
  { (* P -> I 0 *)
    unfold imp_rel. intros a b2 PR.
    red. red in PR.
    destruct a. 2: inv PR.
    destruct p as [mH mb].
    destruct b2 as [mV [l' g]].
    destruct PR as [SINV [DST [SRC [LSM [G [MH [MB MV]]]]]]].

    split.
    solve [eauto].

    subst.
    repeat split; eauto.

    { assert (allocated ptrll_yoff mV_yoff); [solve_allocated|].
      eapply write_preserves_allocated; eauto.
    }

    { rewrite tfor_0.
      rewrite interp_helix_ret. cbn.
      constructor.
      reflexivity.
    }

    { intros y H.
      rewrite mem_lookup_mem_add_neq; eauto.
    }

    { exists initial.
      pose proof (write_correct WRITE_INIT) as [WRITE_ALLOCATED WRITE_EXT].
      split.
      - apply mem_lookup_mem_add_eq.
      - (* extended LLVM memory *)
        specialize (WRITE_EXT DTYPE_Double).
        forward WRITE_EXT; [constructor|].
        destruct WRITE_EXT as [WRITE_NEW WRITE_OLD].
        split; eauto.
    }
  }

  { (* I loop_end -> Q *)
    unfold imp_rel. intros a b2 H.
    red. red in H.
    break_match; try inv H.
    break_match_hyp.
    break_match_hyp.
    break_match_hyp.
    destruct H as [SINV [DST [SRC [LSM [G [ALLOCI [RET [MEMH_OLD [v [MEMH_NEW EXT_MEM]]]]]]]]]].
    subst.

    eapply state_invariant_write_double_result with (sz:=sz0); eauto.
    3: { intros i v0 H H0.
         pose proof GETARRAYCELL_yoff.
         pose proof get_array_cell_mlup_ext.

         pose proof (write_correct WRITE_INIT) as [ALLOC WRITE_EXT].
         specialize (WRITE_EXT DTYPE_Double).
         forward WRITE_EXT; [constructor|].

         (* GETARRAYCELL_yoff starts at mV_yoff. mV_init extends that, and m1 extends mV_init *)
         epose proof get_array_cell_mlup_ext bkh_yoff ptrll_yoff _ _ _ _ WRITE_EXT.
         forward H3. solve_allocated.

         epose proof @get_array_cell_mlup_ext' bkh_yoff ptrll_yoff _ _ _ mV_init m1.
         epose proof @get_array_cell_mlup_ext' bkh_yoff ptrll_yoff _ _ _ mV_init m1 v H3.

         eapply H5; eauto.
         rewrite repr_of_nat_to_nat; eauto.
    }
    rewrite <- Γ_S1S2; eauto.
    eauto.

    { (* Should be able to use INLG_yoff *)
      cbn. cbn in INLG_yoff.

      (* TODO: another automation candidate. *)
      nexpr_modifs.
      epose proof local_scope_modif_trans'' PostLoopEndNExpr PostXoffNExpr.
      repeat (forward H; solve_local_count).
      epose proof local_scope_modif_trans'' H PostYoffNExpr.
      repeat (forward H0; solve_local_count).
      pose proof LSM.
      eapply local_scope_modif_shrink with (s1 := i8) (s4:= s2) in H1; solve_local_count.
      eapply local_scope_modif_sub'_l in H1; [|solve_lid_bound_between].
      eapply local_scope_modif_sub'_l in H1; [|solve_lid_bound_between].
      epose proof local_scope_modif_trans'' H0 H1.
      repeat (forward H2; solve_local_count).

      { destruct i3.
        - eauto.
        - assert (lid_bound s1 id) as LID_BOUND0 by (eapply Correctness_Invariants.st_gamma_bound; solve_lid_bound).
          cbn; erewrite <- local_scope_modif_bound_before with (s2:=s2); eauto.
          solve_lid_bound.
      }
    }
  }

  { (* IDENT *)
    intros x H; inv H.
    pose proof (genNExpr_ident_bound _ Heqs3 GBi5).
    repeat (rewrite alist_find_neq); try solve_id_neq.
    pose proof PostLoopEndNExpr.
    destruct H0.
    cbn in *.
    (* This is where I need exp_in_scope... *)
    pose proof (exp_in_scope x eq_refl).
    destruct H0 as [[INL BOUNDX] | [INL [BOUNDX LT]]]; unfold alist_In in INL.
    -

      edestruct lid_bound_before_bound_between with (s2 := i5) (id:=x).
      solve_lid_bound.
      solve_local_count.

      destruct Mono_IRState.
      + erewrite local_scope_preserve_modif.
        eauto.
        2: solve_local_scope_modif.
        solve_local_count.
        eauto.
      + subst.
        erewrite local_scope_preserve_modif; eauto.
    - nexpr_modifs.
      epose proof local_scope_modif_trans'' PostXoffNExpr PostYoffNExpr as LSM_yoff'.
      repeat (forward LSM_yoff'; solve_local_count).

      erewrite local_scope_preserve_modif.
      eauto.
      2: eauto.
      solve_local_scope_modif.
  }

  { (* P holds initially *)
    red.
    split.
    { (* State invariant *)
      repeat
        (eapply state_invariant_same_Γ'; cycle 1;
         [get_gamma_bounds; solve_gamma_bound | solve_not_in_gamma | | solve_gamma]).

      assert (Γ s2 ≡ Γ i8) as Γ_s2i8 by solve_gamma.
      eapply state_invariant_Γ' with (s1:=i8); [eauto|eauto|get_gamma_bounds; solve_gamma_bound].
      { destruct i3.
        { eapply write_state_invariant with (ptrll := ptrll_yoff) (dst_addr := dst_addr).
          eauto.
          assert (Γ s1 ≡ Γ i8) as Γ_s1i8 by solve_gamma.
          rewrite <- Γ_s1i8. eauto.
          eauto.
          eauto.
          eapply handle_gep_addr_array_same_block; eauto.
          eauto.
          constructor.
        }
        { eapply write_state_invariant with (ptrll := ptrll_yoff) (dst_addr := dst_addr).
          eauto.
          assert (Γ s1 ≡ Γ i8) as Γ_s1i8 by solve_gamma.
          rewrite <- Γ_s1i8. eauto.
          eauto.
          { (* another alist in thing *)
            assert (lid_bound s1 id) as LID_BOUND0 by (eapply Correctness_Invariants.st_gamma_bound; solve_lid_bound).
            cbn. cbn in INLG_yoff.

            nexpr_modifs.
            epose proof local_scope_modif_trans'' PostLoopEndNExpr PostXoffNExpr.
            repeat (forward H; solve_local_count).
            epose proof local_scope_modif_trans'' H PostYoffNExpr.
            repeat (forward H0; solve_local_count).
            cbn; erewrite <- local_scope_modif_bound_before with (s2:=i8); eauto.
            solve_lid_bound.
          }
          eapply handle_gep_addr_array_same_block; eauto.
          eauto.
          constructor.
        }
      }
    }

    (* Local environments *)
    repeat split; solve_alist_in.
  }

  Unshelve.
  all: eauto.
  all: eapply from_N_intval in EQsz0; subst; auto.
Qed.