Require Import VST.floyd.base2.
Require Import VST.floyd.client_lemmas.
Require Import VST.floyd.fieldlist.
Require Import VST.floyd.type_induction.
Require Import VST.floyd.nested_pred_lemmas.
Open Scope Z.

Module Type ACR_DEC.

  Parameter align_compatible_rec_dec:
    forall {cs: compspecs},
      forall t z, {align_compatible_rec cenv_cs t z} + {~ align_compatible_rec cenv_cs t z}.

End ACR_DEC.

Module align_compatible_rec_dec: ACR_DEC.

Section align_compatible_rec_dec.

Context {cs: compspecs}.

Definition dec_type := sigT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}).

Definition dec_by_value (ch: memory_chunk): dec_type :=
  existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => (Memdata.align_chunk ch | z)) (fun z => Zdivide_dec (Memdata.align_chunk ch) z (Memdata.align_chunk_pos _)).

Definition dec_False: dec_type :=
  existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => False) (fun z => right (fun H => H)).

Definition dec_True: dec_type :=
  existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => True) (fun z => left I).

Fixpoint cons_in_list {A} (a: A) (al' al: list A) (H: forall x, In x al' -> In x al) (bl: list {x:A| In x al'}) : list {x: A | In x al} :=
  match bl with
  | nil => nil
  | exist x i :: bl0 =>exist _ x (H x i)  :: cons_in_list a al' al H bl0
  end.

Fixpoint make_in_list {A} (al: list A) : list {x: A | In x al} :=
  match al as ax return (al = ax -> list {x : A | In x ax}) with
           | nil => fun _ => nil
           | a::al' => fun H: al = a::al' =>
                      exist _ a (or_introl eq_refl) ::
                         eq_rect al (fun l : list A => list {x : A | In x l})
                          (cons_in_list a al' al (fun (x : A) (H0 : In x al') =>
                                 eq_ind_r (fun al0 : list A => In x al0) (in_cons _ _ _ H0) H)
                               (make_in_list al'))
                        (a :: al') H
           end (eq_refl _).

Lemma in_make_in_list: forall {A} (a: A) (al: list A) H,
   In (exist (fun x => In x al) a H) (make_in_list al).
Proof.
induction al; intros.
inv H.
destruct H.
subst a0.
simpl.
left; auto.
unfold make_in_list; fold @make_in_list.
right.
specialize (IHal i).
unfold eq_rect.
forget (make_in_list al) as bl.
unfold eq_ind_r.
unfold eq_ind.
simpl.
induction bl.
inv IHal.
destruct IHal.
subst a1.
left.
apply exist_ext; auto.
specialize (IHbl H).
unfold cons_in_list; fold @cons_in_list.
destruct a1.
right. auto.
Qed.

Lemma field_type_in_members_strong:
 forall i t m, Ctypes.field_type i m = Errors.OK t ->
          In (i,t) m.
Proof.
induction m; intros.
inv H.
simpl in H.
destruct a. if_tac in H. subst. inv H. left; auto.
right. apply IHm; auto.
Qed.

Lemma align_compatible_dec_aux:
   forall n t, (rank_type cenv_cs t < n)%nat ->
    forall z, {align_compatible_rec cenv_cs t z} + {~ align_compatible_rec cenv_cs t z}.
Proof.
induction n; intros; [ omega | ].
rename H into Hrank.
destruct t  as [ | [ | | | ] [ | ]| [ | ] | [ | ] | | | | | ] eqn:Ht; intros;
try solve [
clear IHn Hrank;
match goal with |- context [align_compatible_rec _ ?t _] =>
evar (ch: memory_chunk);
assert (access_mode t = By_value ch) by (subst ch; reflexivity);
(destruct (Zdivide_dec (Memdata.align_chunk ch) z (Memdata.align_chunk_pos _));
   [left; econstructor; try reflexivity; eassumption
   |right;  contradict n; inv n; inv H0; auto])
end];
try solve [right; intro H; inv H; inv H0].
* (* Tarray *)
specialize (IHn t0).
simpl in Hrank. spec IHn; [omega | ]. clear Hrank.
pose proof (Zrange_pred_dec (fun ofs => align_compatible_rec cenv_cs t0 (z + sizeof t0 * ofs))).
spec H.
intro; apply IHn.
specialize (H 0 z0).
destruct H as [H|H]; [left|right].
+
eapply align_compatible_rec_Tarray; intros.
apply H; auto.
+
contradict H.
intros.
eapply align_compatible_rec_Tarray_inv in H.
apply H.
split; try omega.
* (* Tstruct *)
destruct (cenv_cs ! i) eqn:?H;
 [ | right; intro H0; inv H0; [inv H1 | congruence]].
simpl in Hrank. rewrite H in Hrank.
pose (FO id := match Ctypes.field_offset cenv_cs id (co_members c) with
                      | Errors.OK z0 => z0 | _ => 0 end).
pose (D := fun x: {it: ident*type | In it (co_members c)} =>
                align_compatible_rec cenv_cs (snd (proj1_sig x)) (z + FO (fst (proj1_sig x)))).
assert (H1: forall x, {D x} + {~ D x}). {
 subst D. intros. destruct x as [[id t0] ?]. simpl.
 apply IHn.
 assert (H1:= rank_union_member cenv_cs _ a _ _ _ cenv_consistent H i0).
 simpl in H1. rewrite H in H1. omega.
}
destruct (Forall_dec D H1 (make_in_list (co_members c))) as [H2|H2]; clear H1; [left|right].
+
 eapply align_compatible_rec_Tstruct.
 eassumption.
 assert (H1 := proj1 (Forall_forall _ _) H2); clear H2.
 intros.
 specialize (H1 (exist _ (i0,t0) (field_type_in_members_strong _ _ _ H0))).
 specialize (H1 (in_make_in_list _ _ _)).
 subst D.
 simpl in H1.
 replace z0 with (FO i0).
 apply H1.
 unfold FO. rewrite H2. auto.
+
 contradict H2.
 apply Forall_forall.
 intros.
 subst D. simpl.
 destruct x as [[id t0] ?].
 eapply align_compatible_rec_Tstruct_inv in H2; try eassumption.
 instantiate (1:=id). simpl.
 pose proof (get_co_members_no_replicate i).
 unfold get_co in H1. rewrite H in H1. unfold members_no_replicate in H1.
 clear - i0 H1.
 induction (co_members c). inv i0. simpl. destruct a.
 if_tac. subst.
 simpl in H1. destruct (id_in_list i (map fst m)) eqn:?; try discriminate.
 destruct i0. inv H. auto.
 apply id_in_list_false in Heqb.
 elimtype False. apply Heqb. apply (in_map fst) in H. apply H.
 apply IHm.
 destruct i0. inv H0. contradiction. auto.
 simpl in H1. destruct (id_in_list i (map fst m)) eqn:?; try discriminate.
 auto.
 unfold FO; simpl.
 clear - i0.
 destruct (Ctypes.field_offset cenv_cs id (co_members c) ) eqn:?H; auto.
 elimtype False.
 unfold Ctypes.field_offset in H. forget 0 as z.
 revert z i0 H; induction (co_members c); intros. inv i0.
 simpl in H. destruct a. if_tac in H. inv H.
 destruct i0. inv H1. contradiction. apply IHm in H. auto. auto.
* (* Tunion *)
destruct (cenv_cs ! i) eqn:?H;
 [ | right; intro H0; inv H0; [inv H1 | congruence]].
simpl in Hrank. rewrite H in Hrank.
pose (D := fun x: {it: ident*type | In it (co_members c)} =>
                align_compatible_rec cenv_cs (snd (proj1_sig x)) z).
assert (H1: forall x, {D x} + {~ D x}). {
 subst D. intros. destruct x as [[id t0] ?]. simpl.
 apply IHn.
 assert (H1:= rank_union_member cenv_cs _ a _ _ _ cenv_consistent H i0).
 simpl in H1. rewrite H in H1. omega.
}
destruct (Forall_dec D H1 (make_in_list (co_members c))) as [H2|H2]; clear H1; [left|right].
+
 eapply align_compatible_rec_Tunion.
 eassumption.
 assert (H1 := proj1 (Forall_forall _ _) H2); clear H2.
 intros.
 specialize (H1 (exist _ (i0,t0) (field_type_in_members_strong _ _ _ H0))).
 specialize (H1 (in_make_in_list _ _ _)).
 apply H1.
+
 contradict H2.
 apply Forall_forall.
 intros.
 subst D. simpl.
 destruct x as [[id t0] ?].
 eapply align_compatible_rec_Tunion_inv in H2; try eassumption.
 instantiate (1:=id). simpl.
 pose proof (get_co_members_no_replicate i).
 unfold get_co in H1. rewrite H in H1. unfold members_no_replicate in H1.
 clear - i0 H1.
 induction (co_members c). inv i0. simpl. destruct a.
 if_tac. subst.
 simpl in H1. destruct (id_in_list i (map fst m)) eqn:?; try discriminate.
 destruct i0. inv H. auto.
 apply id_in_list_false in Heqb.
 elimtype False. apply Heqb. apply (in_map fst) in H. apply H.
 apply IHm.
 destruct i0. inv H0. contradiction. auto.
 simpl in H1. destruct (id_in_list i (map fst m)) eqn:?; try discriminate.
 auto.
Qed.

Lemma align_compatible_rec_dec: forall t z, {align_compatible_rec cenv_cs t z} + {~ align_compatible_rec cenv_cs t z}.
Proof.
intros.
apply align_compatible_dec_aux with (S (rank_type cenv_cs t)).
omega.
Qed.

End align_compatible_rec_dec.

End align_compatible_rec_dec.

Lemma align_compatible_dec: forall {cs: compspecs} t p, {align_compatible t p} + {~ align_compatible t p}.
Proof.
  intros.
  destruct p; try solve [left; unfold align_compatible; simpl; tauto].
  simpl.
  apply align_compatible_rec_dec.align_compatible_rec_dec.
Qed.


Parameter T : Prop.
Parameter t : T.

Hint Extern 1 (T) => apply t.
Ltac diverge a := diverge a.
Hint Extern 2 (T) => diverge idtac.

Lemma test : T.
Proof.
  auto. (* executes the first hint, succeeds, and never executes
           the second hint. *)
Qed.

Lemma test2 : T.
Proof.
  eauto. (* executes the first and second hint;
            the latter of which results in a "stack overflow",
            and eauto does not solve the goal. *)
Abort.


Require Import CertiGraph.unionfind.env_unionfind_arr.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.UnionFind.
Require Import CertiGraph.msl_application.ArrayGraph.
Require Import CertiGraph.floyd_ext.share.
Require Import VST.floyd.library.
Require Import CertiGraph.unionfind.spatial_array_graph.

Local Coercion UFGraph_LGraph: UFGraph >-> LGraph.
Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.
#[export] Existing Instances maGraph finGraph liGraph.

Local Open Scope Z_scope.

(*There is a full definition in the verified malloc, but it's impl-specific*)
(*Parameter malloc_token': share -> Z -> val -> mpred.*)

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH sh:share, n: Z(*, gv:globals*)
  PRE [tint]
     PROP (writable_share sh;
            4 <= n <= Int.max_unsigned
          )
     PARAMS (Vint (Int.repr n))
     GLOBALS ((*gv*))
     SEP (
          )
  POST [ tptr tvoid ]
     EX v: pointer_val,
     PROP (malloc_compatible n (pointer_val_val v))
     LOCAL (temp ret_temp (pointer_val_val v))
     SEP (
          memory_block sh n (pointer_val_val v)
         ).
(*
Definition mallocK_spec :=
 DECLARE _mallocK
  WITH gv: globals, sh: share, n: Z
  PRE [tint]
     PROP (writable_share sh;
           4 <= n <= Ptrofs.max_unsigned - 12 (*we don't want to malloc 0. The 12 is just some constant from the verified malloc*)
          )
     PARAMS (Vptrofs (Ptrofs.repr n))
     GLOBALS (gv)
     SEP (mem_mgr gv)
  POST [ tptr tvoid ]
     EX v: _,
     PROP (malloc_compatible n v)
     LOCAL (temp ret_temp v)
     SEP (mem_mgr gv; malloc_token' sh n v; memory_block sh n v).
*)
(*Basically collapses everything into the mpred defined by SAG_VST
takes in a lst of rank-parent pairs(from where? g?)
  which is converted into the Cdata structures
sh is the only parameter needed
data_at sh (tarray vertex_type (Z.of_nat (length lst)))
                               (map vgamma2cdata lst) (pointer_val_val x)
*)
Definition whole_graph sh g x :=
  (@full_graph_at mpred SAGA_VST pointer_val (SAG_VST sh) g x).

Definition makeSet_spec :=
  DECLARE _makeSet
  WITH gv:globals, sh: share, V: Z
    PRE [tint]
      PROP (writable_share sh; readable_share sh;
            0 < V <= Int.max_signed / 8)
      PARAMS (Vint (Int.repr V))
      GLOBALS ()
      SEP ((*mem_mgr gv*))
    POST [tptr vertex_type]
      EX rt: pointer_val, (*creates a graph where*)
      PROP (forall i: Z, 0 <= i < V -> vvalid (makeSet_discrete_Graph (Z.to_nat V)) i) (*anything between 0 and V is a vertex*)
      LOCAL (temp ret_temp (pointer_val_val rt))
      SEP (
           (*mem_mgr gv; malloc_token' sh (V*4) (pointer_val_val rt);*)
           whole_graph sh (makeSet_discrete_Graph (Z.to_nat V)) rt). (*representation in heap...*)

Definition freeSet_spec :=
  DECLARE _freeSet
  WITH sh: share, p: pointer_val, g: ArrayGraph.UFGraph(*, gv: globals*)
    PRE [tptr vertex_type]
    PROP () PARAMS ((pointer_val_val p)) GLOBALS ((*gv*))
    SEP ((*mem_mgr gv;
          malloc_token' sh (Z.of_nat (numV' g)) (pointer_val_val p);*)
          whole_graph sh g p)
  POST [tvoid]
    PROP () LOCAL () SEP ((*mem_mgr gv*)).

Definition find_spec :=
  DECLARE _find
  WITH sh: share, g: UFGraph, subsets: pointer_val, i: Z
    PRE [tptr vertex_type, tint]
      PROP (writable_share sh; vvalid g i)
      PARAMS (pointer_val_val subsets; Vint (Int.repr i))
      GLOBALS ()
      SEP (whole_graph sh g subsets)
    POST [tint]
      EX g': UFGraph, EX rt: Z,
      PROP (uf_equiv g g' ; uf_root g' i rt)
      LOCAL (temp ret_temp (Vint (Int.repr rt)))
      SEP (whole_graph sh g' subsets).

Definition union_spec :=
 DECLARE _Union
  WITH sh: share, g: UFGraph, subsets: pointer_val, x: Z, y: Z
  PRE [tptr vertex_type, tint, tint]
          PROP  (writable_share sh; vvalid g x; vvalid g y)
          PARAMS (pointer_val_val subsets; Vint (Int.repr x); Vint (Int.repr y))
          GLOBALS ()
          SEP   (whole_graph sh g subsets)
  POST [ Tvoid ]
        EX g': UFGraph,
        PROP (uf_union g x y g')
        LOCAL ()
        SEP (whole_graph sh g' subsets).


(*
    Copyright (C) 2012  G. Gonthier, B. Ziliani, A. Nanevski, D. Dreyer

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*)

From mathcomp
Require Import ssreflect ssrbool seq ssrfun.
From LemmaOverloading
Require Import heaps rels hprop stmod stsep.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Lemma bnd_is_try (A B : Type) (s1 : spec A) (s2 : A -> spec B) i r :
        verify (try_s s1 s2 (fun y => fr (throw_s B y))) i r ->
        verify (bind_s s1 s2) i r.
Proof.
move=>H; apply: frame0=>D.
case: {H D} (H D) (D)=>[[i1]][i2][->][[H1 [H2 H3]]] _ T D.
split=>[|y m].
- split=>[|x m]; first by apply: fr_pre H1.
  by case/(locality D H1)=>m1 [->][_]; move/H2; apply: fr_pre.
move=>{D} H; apply: T=>h1 h2 E.
rewrite {i1 i2 H1 H2 H3}E in H * => D1 [H1][H2] H3.
case: H=>[[x][h][]|[e][->]]; move/(locality D1 H1);
case=>[m1][->][D2] T1; move: (T1); [move/H2 | move/H3]=>H4.
- move=>T2; case/(locality D2 H4): (T2)=>m3 [->][D3].
  by exists m3; do !split=>//; left; exists x; exists m1.
exists m1; do !split=>//; right; exists e; exists m1; split=>//.
move=>j1 j2 E D _; rewrite {m1 D2}E in T1 D H4 *.
exists j1; do !split=>//; move=>k1 k2 -> D2 ->.
by exists empty; rewrite un0h; do !split=>//; apply: defUnr D2.
Qed.

Local Notation cont A := (ans A -> heap -> Prop).

Section EvalDo.
Variables (A B : Type).

Lemma val_do (s : spec A) i j (r : cont A) :
         s.1 i ->
         (forall x m, s.2 (Val x) i m -> def (m :+ j) -> r (Val x) (m :+ j)) ->
         (forall e m, s.2 (Exn e) i m -> def (m :+ j) -> r (Exn e) (m :+ j)) ->
         verify s (i :+ j) r.
Proof.
move=>H1 H2 H3; apply: frame; apply: frame0; split=>//.
by case=>x m H4 D1 D2; [apply: H2 | apply: H3].
Qed.

Lemma try_do (s : spec A) s1 s2 i j (r : cont B) :
        s.1 i ->
        (forall x m, s.2 (Val x) i m -> verify (s1 x) (m :+ j) r) ->
        (forall e m, s.2 (Exn e) i m -> verify (s2 e) (m :+ j) r) ->
        verify (try_s s s1 s2) (i :+ j) r.
Proof.
move=>H1 H2 H3; apply: frame0=>D; split=>[|y m].
- split; first by apply: fr_pre; exists i; exists empty; rewrite unh0.
  by split=>y m; case/(_ i j (erefl _) D H1)=>m1 [->][D2]; [case/H2 | case/H3].
by case=>[[x]|[e]][h][]; case/(_ i j (erefl _) D H1)=>m1 [->][D2];
   [case/H2 | case/H3]=>// _; apply.
Qed.

Lemma bnd_do (s : spec A) s2 i j (r : cont B) :
        s.1 i ->
        (forall x m, s.2 (Val x) i m -> verify (s2 x) (m :+ j) r) ->
        (forall e m, s.2 (Exn e) i m -> def (m :+ j) -> r (Exn e) (m :+ j)) ->
        verify (bind_s s s2) (i :+ j) r.
Proof.
move=>H1 H2 H3; apply: bnd_is_try.
apply: try_do=>// e m H4; apply: frame0; apply: frame1=>_.
by split=>// y m1 [->] -> _; rewrite un0h; apply: H3.
Qed.

End EvalDo.

Section EvalReturn.
Variables (A B : Type).

Lemma val_ret v i (r : cont A) :
       (def i -> r (Val v) i) -> verify (ret_s v) i r.
Proof.
by rewrite -[i]un0h=>H; apply: val_do=>// x m [->] // [->].
Qed.

Lemma try_ret s1 s2 (v : A) i (r : cont B) :
        verify (s1 v) i r -> verify (try_s (ret_s v) s1 s2) i r.
Proof.
by rewrite -[i]un0h=>H; apply: try_do=>// x m [->] // [->].
Qed.

Lemma bnd_ret s (v : A) i (r : cont B) :
        verify (s v) i r -> verify (bind_s (ret_s v) s) i r.
Proof. by move=>H; apply: bnd_is_try; apply: try_ret. Qed.

End EvalReturn.

Section EvalRead.
Variables (A B : Type).

Lemma val_read v x i (r : cont A) :
        (def (x :-> v :+ i) -> r (Val v) (x :-> v :+ i)) ->
        verify (read_s A x) (x :-> v :+ i) r.
Proof.
move=>*; apply: val_do; first by [exists v];
by move=>y m [<-]; move/(_ v (erefl _))=>// [->].
Qed.

Lemma try_read s1 s2 v x i (r : cont B) :
        verify (s1 v) (x :-> v :+ i) r ->
        verify (try_s (read_s A x) s1 s2) (x :-> v :+ i) r.
Proof.
move=>*; apply: try_do; first by [exists v];
by move=>y m [<-]; move/(_ v (erefl _))=>// [->].
Qed.

Lemma bnd_read s v x i (r : cont B) :
        verify (s v) (x :-> v :+ i) r ->
        verify (bind_s (read_s A x) s) (x :-> v :+ i) r.
Proof. by move=>*; apply: bnd_is_try; apply: try_read. Qed.

End EvalRead.

Section EvalWrite.
Variables (A B C : Type).

Lemma val_write (v : A) (w : B) x i (r : cont unit) :
        (def (x :-> v :+ i) -> r (Val tt) (x :-> v :+ i)) ->
        verify (write_s x v) (x :-> w :+ i) r.
Proof.
move=>*; apply: val_do; first by [exists B; exists w];
by move=>y m [// [->] ->].
Qed.

Lemma try_write s1 s2 (v: A) (w : C) x i (r : cont B) :
        verify (s1 tt) (x :-> v :+ i) r ->
        verify (try_s (write_s x v) s1 s2) (x :-> w :+ i) r.
Proof.
move=>*; apply: try_do; first by [exists C; exists w];
by move=>y m [// [->] ->].
Qed.

Lemma bnd_write s (v : A) (w : C) x i (r : cont B) :
        verify (s tt) (x :-> v :+ i) r ->
        verify (bind_s (write_s x v) s) (x :-> w :+ i) r.
Proof. by move=>*; apply: bnd_is_try; apply: try_write. Qed.

End EvalWrite.

Section EvalAlloc.
Variables (A B : Type).

Lemma val_alloc (v : A) i (r : cont ptr) :
        (forall x, def (x :-> v :+ i) -> r (Val x) (x :-> v :+ i)) ->
        verify (alloc_s v) i r.
Proof.
move=>H; rewrite -[i]un0h; apply: val_do=>//;
by move=>y m [x][//][-> ->]; apply: H.
Qed.

Lemma try_alloc s1 s2 (v : A) i (r : cont B) :
        (forall x, verify (s1 x) (x :-> v :+ i) r) ->
        verify (try_s (alloc_s v) s1 s2) i r.
Proof.
move=>H; rewrite -[i]un0h; apply: try_do=>//;
by move=>y m [x][//][-> ->]; apply: H.
Qed.

Lemma bnd_alloc s (v : A) i (r : cont B) :
        (forall x, verify (s x) (x :-> v :+ i) r) ->
        verify (bind_s (alloc_s v) s) i r.
Proof. by move=>*; apply: bnd_is_try; apply: try_alloc. Qed.

End EvalAlloc.

Section EvalBlockAlloc.
Variables (A B : Type).

Lemma val_allocb (v : A) n i (r : cont ptr) :
        (forall x, def (updi x (nseq n v) :+ i) ->
           r (Val x) (updi x (nseq n v) :+ i)) ->
        verify (allocb_s v n) i r.
Proof.
move=>H; rewrite -[i]un0h; apply: val_do=>//;
by move=>y m [x][//][->]->; apply: H.
Qed.

Lemma try_allocb s1 s2 (v : A) n i (r : cont B) :
        (forall x, verify (s1 x) (updi x (nseq n v) :+ i) r) ->
        verify (try_s (allocb_s v n) s1 s2) i r.
Proof.
move=>H; rewrite -[i]un0h; apply: try_do=>//;
by move=>y m [x][//][->]->; apply: H.
Qed.

Lemma bnd_allocb s (v : A) n i (r : cont B) :
        (forall x, verify (s x) (updi x (nseq n v) :+ i) r) ->
        verify (bind_s (allocb_s v n) s) i r.
Proof. by move=>*; apply: bnd_is_try; apply: try_allocb. Qed.

End EvalBlockAlloc.

Section EvalDealloc.
Variables (A B : Type).

Lemma val_dealloc (v : A) x i (r : cont unit) :
        (def i -> r (Val tt) i) ->
        verify (dealloc_s x) (x :-> v :+ i) r.
Proof.
move=>H; apply: val_do; first by [exists A; exists v];
by move=>y m [//][->] ->; rewrite un0h.
Qed.

Lemma try_dealloc s1 s2 (v : B) x i (r : cont A) :
        verify (s1 tt) i r ->
        verify (try_s (dealloc_s x) s1 s2) (x :-> v :+ i) r.
Proof.
move=>H; apply: try_do; first by [exists B; exists v];
by move=>y m [//][->] ->; rewrite un0h.
Qed.

Lemma bnd_dealloc s (v : B) x i (r : cont A) :
        verify (s tt) i r ->
        verify (bind_s (dealloc_s x) s) (x :-> v :+ i) r.
Proof. by move=>*; apply: bnd_is_try; apply: try_dealloc. Qed.

End EvalDealloc.

Section EvalThrow.
Variables (A B : Type).

Lemma val_throw e i (r : cont A) :
        (def i -> r (Exn e) i) -> verify (throw_s A e) i r.
Proof.
move=>H; rewrite -[i]un0h; apply: val_do=>//;
by move=>y m [->] // [->]; rewrite un0h.
Qed.

Lemma try_throw s1 s2 e i (r : cont B) :
        verify (s2 e) i r ->
        verify (try_s (throw_s A e) s1 s2) i r.
Proof.
move=>H; rewrite -[i]un0h; apply: try_do=>//;
by move=>y m [->] // [->]; rewrite un0h.
Qed.

Lemma bnd_throw s e i (r : cont B) :
        (def i -> r (Exn e) i) ->
        verify (bind_s (throw_s A e) s) i r.
Proof.
move=>H; apply: bnd_is_try; apply: try_throw; apply: frame0.
by rewrite -[i]un0h; apply: val_do=>// y m [->] // [->]; rewrite un0h.
Qed.

End EvalThrow.

(* specialized versions of do lemmas, to handle ghost variables. *)

Section EvalGhost.
Variables (A B C : Type) (t : C) (p : C -> Pred heap) (q : C -> post A).
Variables (s1 : A -> spec B) (s2 : exn -> spec B) (i j : heap) (P : Pred heap).

Lemma val_gh (r : cont A) :
        let: s := (fun i => exists x, i \In p x,
                   fun y i m => forall x, i \In p x -> q x y i m) in
        (forall x m, q t (Val x) i m -> def (m :+ j) -> r (Val x) (m :+ j)) ->
        (forall e m, q t (Exn e) i m -> def (m :+ j) -> r (Exn e) (m :+ j)) ->
        i \In p t ->
        verify s (i :+ j) r.
Proof. by move=>*; apply: val_do=>/=; eauto. Qed.

Lemma val_gh1 (r : cont A) :
        let: Q := fun y i m => forall x, i \In p x -> q x y i m in
        (i \In p t -> P i) ->
        (forall x m, q t (Val x) i m -> def (m :+ j) -> r (Val x) (m :+ j)) ->
        (forall e m, q t (Exn e) i m -> def (m :+ j) -> r (Exn e) (m :+ j)) ->
        i \In p t ->
        verify (P, Q) (i :+ j) r.
Proof. by move=>*; apply: val_do=>/=; eauto. Qed.

Lemma try_gh (r : cont B) :
        let: s := (fun i => exists x, i \In p x,
                   fun y i m => forall x, i \In p x -> q x y i m) in
        (forall x m, q t (Val x) i m -> verify (s1 x) (m :+ j) r) ->
        (forall e m, q t (Exn e) i m -> verify (s2 e) (m :+ j) r) ->
        i \In p t ->
        verify (try_s s s1 s2) (i :+ j) r.
Proof. by move=>*; apply: try_do=>/=; eauto. Qed.

Lemma try_gh1 (r : cont B) :
        let: Q := fun y i m => forall x, i \In p x -> q x y i m in
        (i \In p t -> P i) ->
        (forall x m, q t (Val x) i m -> verify (s1 x) (m :+ j) r) ->
        (forall e m, q t (Exn e) i m -> verify (s2 e) (m :+ j) r) ->
        i \In p t ->
        verify (try_s (P, Q) s1 s2) (i :+ j) r.
Proof. by move=>*; apply: try_do=>/=; eauto. Qed.

Lemma bnd_gh (r : cont B) :
        let: s := (fun i => exists x, i \In p x,
                   fun y i m => forall x, i \In p x -> q x y i m) in
        (forall x m, q t (Val x) i m -> verify (s1 x) (m :+ j) r) ->
        (forall e m, q t (Exn e) i m -> def (m :+ j) -> r (Exn e) (m :+ j)) ->
        i \In p t ->
        verify (bind_s s s1) (i :+ j) r.
Proof. by move=>*; apply: bnd_do=>/=; eauto. Qed.

Lemma bnd_gh1 (r : cont B) :
        let: Q := fun y i m => forall x, i \In p x -> q x y i m in
        (i \In p t -> P i) ->
        (forall x m, q t (Val x) i m -> verify (s1 x) (m :+ j) r) ->
        (forall e m, q t (Exn e) i m -> def (m :+ j) -> r (Exn e) (m :+ j)) ->
        i \In p t ->
        verify (bind_s (P, Q) s1) (i :+ j) r.
Proof. by move=>*; apply: bnd_do=>/=; eauto. Qed.

End EvalGhost.

(*****************************************************************************)
(* associativity lemmas should go here, but I don't want to bother right now *)
(*****************************************************************************)

(* packaging up the lemmas into a tactic that selects them appropriately *)

Definition pull (A : Type) x (v:A) := (unC (x :-> v), unCA (x :-> v)).
Definition push (A : Type) x (v:A) := (unCA (x :-> v), unC (x :-> v)).

Ltac hstep :=
  match goal with
    | |- verify ?h (ret_s _) _ =>
      apply: val_ret
    | |- verify ?h (try_s (ret_s _) _ _) _ =>
      apply: try_ret
    | |- verify ?h (bind_s (ret_s _) _) _ =>
      apply: bnd_ret

    | |- verify ?h (read_s _ ?l) _ =>
      rewrite -?(pull l); apply: val_read
    | |- verify ?h (try_s (read_s _ ?l) _ _) _ =>
      rewrite -?(pull l); apply: try_read
    | |- verify (?h) (bind_s (read_s _ ?l) _) _ =>
      rewrite -?(pull l); apply: bnd_read

    | |- verify (?h) (write_s ?l _) _ =>
      rewrite -?(pull l); apply: val_write
    | |- verify (?h) (try_s (write_s ?l _) _ _) _ =>
      rewrite -?(pull l); apply: try_write
    | |- verify (?h) (bind_s (write_s ?l _) _) _ =>
      rewrite -?(pull l); apply: bnd_write

    | |- verify ?h (alloc_s _) _ =>
      apply: val_alloc
    | |- verify ?h (try_s (alloc_s _) _ _) _ =>
      apply: try_alloc
    | |- verify ?h (bind_s (alloc_s _) _) _ =>
      apply: bnd_alloc

    | |- verify ?h (allocb_s _ _) _ =>
      apply: val_allocb
    | |- verify ?h (try_s (allocb_s _ _) _ _) _ =>
      apply: try_allocb
    | |- verify ?h (bind_s (allocb_s _ _) _) _ =>
      apply: bnd_allocb

    | |- verify ?h (dealloc_s ?l) _ =>
      rewrite -?(pull l); apply: val_dealloc
    | |- verify ?h (try_s (dealloc_s ?l) _ _) _ =>
      rewrite -?(pull l); apply: try_dealloc
    | |- verify ?h (bind_s (dealloc_s ?l) _) _ =>
      rewrite -?(pull l); apply: bnd_dealloc

    | |- verify ?h (throw_s _ _) _ =>
      apply: val_throw
    | |- verify ?h (try_s (throw_s _ _) _ _) _ =>
      apply: try_throw
    | |- verify ?h (bind_s (throw_s _ _) _) _ =>
      apply: bnd_throw
  end.

Lemma swp : forall (A : Type) (v : A) x h, h \In x :--> v <-> h = x :-> v.
Proof. by move=>A v x h; split; rewrite InE /pts /=; unlock. Qed.

Lemma opn : forall (A : Type) (v : A) x h, h \In x :--> v <-> x :-> v = h.
Proof. by move=>A v x h; split=>[|H]; rewrite InE /= /pts; unlock. Qed.

Prenex Implicits swp opn.

Lemma blah (A : Type) (p : ptr) (l : A) : def (p :-> l) -> (p :-> l) \In p :--> l.
Proof. by move=>H; apply/swp. Qed.

Hint Immediate blah : core.

Lemma blah2 (A : Type) (v1 v2 : A) q :
        def (q :-> v1) -> v1 = v2 -> q :-> v1 \In q :--> v2.
Proof. by move=>D E; apply/swp; rewrite E. Qed.

Hint Immediate blah2 : core.

Ltac hauto := (do ?econstructor=>//;
                try by [defcheck; auto |
                       eapply blah2; defcheck; auto])=>//.

Ltac hhauto := (do ?econstructor=>//; try by [heap_congr])=>//.
Ltac hdone := repeat progress hhauto=>//=.
Ltac heval := do ![hstep | by hhauto].


(* Distributed under the terms of the MIT license. *)
From Coq Require Import CRelationClasses ProofIrrelevance ssreflect ssrbool.
From MetaCoq.Template Require Import config Universes utils BasicAst.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction
     PCUICReflect PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICUnivSubstitutionConv
     PCUICUnivSubstitutionTyp
     PCUICCumulativity PCUICPosition PCUICEquality PCUICSigmaCalculus
     PCUICInversion PCUICCumulativity PCUICReduction
     PCUICConfluence PCUICConversion PCUICContextConversion
     PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICClosed PCUICClosedTyp PCUICSubstitution PCUICWfUniverses
     PCUICWeakeningConv PCUICWeakeningTyp PCUICGeneration PCUICUtils PCUICContexts
     PCUICWellScopedCumulativity PCUICConversion PCUICOnFreeVars.

Require Import Equations.Prop.DepElim.
Require Import Equations.Type.Relation_Properties.
From Equations Require Import Equations.

Implicit Types cf : checker_flags.

Notation isWAT := (isWfArity typing).

Lemma isType_Sort {cf:checker_flags} {Σ Γ s} :
  wf_universe Σ s ->
  wf_local Σ Γ ->
  isType Σ Γ (tSort s).
Proof.
  intros wfs wfΓ.
  eexists; econstructor; eauto.
Qed.
#[global] Hint Resolve isType_Sort : pcuic.

Definition wf_typing_spine {cf} {Σ Γ T args T'} :=
  isType Σ Γ T × typing_spine Σ Γ T args T'.

Lemma isArity_it_mkProd_or_LetIn Γ t : isArity t -> isArity (it_mkProd_or_LetIn Γ t).
Proof.
  intros isA. induction Γ using rev_ind; simpl; auto.
  rewrite it_mkProd_or_LetIn_app. simpl; auto.
  destruct x as [? [?|] ?]; simpl; auto.
Qed.

Inductive typing_spine {cf} Σ (Γ : context) : term -> list term -> term -> Type :=
| type_spine_nil ty ty' :
    isType Σ Γ ty ->
    isType Σ Γ ty' ->
    Σ ;;; Γ ⊢ ty ≤ ty' ->
    typing_spine Σ Γ ty [] ty'

| type_spine_cons ty hd tl na A B B' :
    isType Σ Γ ty ->
    isType Σ Γ (tProd na A B) ->
    Σ ;;; Γ ⊢ ty ≤ tProd na A B ->
    Σ ;;; Γ |- hd : A ->
    typing_spine Σ Γ (subst10 hd B) tl B' ->
    typing_spine Σ Γ ty (hd :: tl) B'.

Derive Signature NoConfusion for typing_spine.

Lemma typing_spine_isType_codom {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ T args U} :
  typing_spine Σ Γ T args U -> isType Σ Γ U.
Proof.
  induction 1; auto.
Qed.

Lemma subslet_inds_gen {cf} {Σ : global_env} {wfΣ : wf Σ} ind mdecl idecl :
  declared_inductive Σ ind mdecl idecl ->
  let u := abstract_instance (ind_universes mdecl) in
  subslet (Σ, ind_universes mdecl) [] (inds (inductive_mind ind) u (ind_bodies mdecl))
    (arities_context (ind_bodies mdecl)).
Proof.
  intros isdecl u.
  unfold inds.
  pose proof (proj1 isdecl) as declm'.
  apply on_declared_minductive in declm' as [oind oc]; auto.
  clear oc.
  assert (Alli (fun i x =>
  (Σ, ind_universes mdecl) ;;; [] |- tInd {| inductive_mind := inductive_mind ind; inductive_ind := i |} u : (ind_type x)) 0 (ind_bodies mdecl)).
  { apply forall_nth_error_Alli. intros.
    eapply Alli_nth_error in oind; eauto. simpl in oind.
    destruct oind. destruct onArity as [s Hs].
    eapply type_Cumul; eauto.
    econstructor; eauto. split; eauto with pcuic.
    eapply consistent_instance_ext_abstract_instance; eauto.
    eapply declared_inductive_wf_global_ext; eauto with pcuic.
    rewrite (subst_instance_ind_type_id Σ _ {| inductive_mind := inductive_mind ind; inductive_ind := i |}); eauto.
    destruct isdecl. split; eauto. reflexivity. }
  clear oind.
  revert X. clear onNpars.
  generalize (le_n #|ind_bodies mdecl|).
  generalize (ind_bodies mdecl) at 1 3 4 5.
  induction l using rev_ind; simpl; first constructor.
  rewrite /subst_instance /= /map_context.
  simpl. rewrite /arities_context rev_map_spec /=.
  rewrite map_app /= rev_app_distr /=.
  rewrite /= app_length /= Nat.add_1_r.
  constructor.
  - rewrite -rev_map_spec. apply IHl; try lia.
    eapply Alli_app in X; intuition auto.
  - eapply Alli_app in X as [oind Hx].
    depelim Hx. clear Hx.
    rewrite Nat.add_0_r in t.
    rewrite subst_closedn; auto.
    + eapply typecheck_closed in t as [? ?]; auto.
      destruct p as [? ?].
      now move/andb_and: i0=> [? ?].
Qed.

Section WfEnv.
  Context {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}.

  Lemma ws_cumul_ctx_pb_vass {Γ Γ' na na' A A'} le :
    eq_binder_annot na na' ->
    Σ ⊢ Γ ≤[le] Γ' ->
    Σ ;;; Γ ⊢ A ≤[le] A' ->
    Σ ⊢ Γ ,, vass na A ≤[le] Γ' ,, vass na' A'.
  Proof using Type.
    repeat (constructor; auto).
  Qed.

  Lemma ws_cumul_ctx_pb_app {le Γ Γ' Δ Δ'} :
    #|Δ| = #|Δ'| ->
    Σ ⊢ Γ ,,, Δ ≤[le] Γ' ,,, Δ' <~>
    Σ ⊢ Γ ≤[le] Γ' × ws_cumul_ctx_pb_rel le Σ Γ Δ Δ'.
  Proof using wfΣ.
    move => hlen; split.
    - move/All2_fold_app_inv. move/(_ hlen) => [] onΓ onΔ; split => //.
      split; eauto with fvs.
    - move=> [] onΓ [_ onΔ].
      apply All2_fold_app; auto.
  Qed.

  Lemma invert_cumul_arity_l (Γ : context) (C : term) T :
    Σ;;; Γ ⊢ C ≤ T ->
    match destArity [] C with
    | Some (ctx, s) =>
      ∑ T' ctx' s',
        [× Σ ;;; Γ ⊢ T ⇝ T', (destArity [] T' = Some (ctx', s')),
          Σ ⊢ Γ ,,, smash_context [] ctx = Γ ,,, ctx' &
          leq_universe (global_ext_constraints Σ) s s']
    | None => unit
    end.
  Proof using wfΣ.
    intros CT.
    generalize (destArity_spec [] C). destruct destArity as [[ctx p]|].
    simpl. intros ->. 2:intros _; exact tt.
    revert Γ T CT.
    generalize (@le_n #|ctx|).
    generalize (#|ctx|) at 2. intros n; revert ctx.
    induction n; intros ctx Hlen Γ T HT.
    - destruct ctx; simpl in Hlen; try lia.
      eapply ws_cumul_pb_Sort_l_inv in HT as [u' [redT leqT]].
      exists (tSort u'), [], u'; split; auto.
      cbn. eapply ws_cumul_ctx_pb_refl; eauto with fvs.
    - destruct ctx using rev_ind.
      * eapply ws_cumul_pb_Sort_l_inv in HT as [u' [redT leqT]].
        exists (tSort u'), [], u'; split; auto; cbn.
        apply ws_cumul_ctx_pb_refl; eauto with fvs.
      * rewrite it_mkProd_or_LetIn_app in HT; simpl in HT.
        destruct x as [na [b|] ty]; unfold mkProd_or_LetIn in HT; simpl in *.
        + eapply ws_cumul_pb_LetIn_l_inv in HT; auto.
          unfold subst1 in HT; rewrite subst_it_mkProd_or_LetIn in HT.
          rewrite app_length /= Nat.add_1_r in Hlen.
          simpl in HT. specialize (IHn (subst_context [b] 0 ctx) ltac:(rewrite
          subst_context_length; lia) Γ T HT).
          destruct IHn as [T' [ctx' [s' [redT destT convctx leq]]]].
          clear IHctx.
          exists T', ctx', s'. split; auto.
          rewrite smash_context_app. simpl.
          now rewrite -smash_context_subst_empty.
        + eapply ws_cumul_pb_Prod_l_inv in HT; auto.
          rewrite -> app_length in Hlen.
          rewrite Nat.add_1_r in Hlen.
          destruct HT as [na' [A' [B' [redT convT HT]]]].
          specialize (IHn ctx ltac:(lia) (Γ ,, vass na' A') B').
          forward IHn. eapply ws_cumul_pb_ws_cumul_ctx; eauto.
          { apply ws_cumul_ctx_pb_vass; eauto. now symmetry.
            eapply ws_cumul_ctx_pb_refl. eauto with fvs.
            now symmetry. }
          clear IHctx.
          destruct IHn as [T' [ctx' [s' [redT' destT convctx leq]]]].
          exists (tProd na' A' T'), (ctx' ++ [vass na' A']), s'. split; auto. 2:simpl.
          -- transitivity (tProd na' A' B'); auto.
            split.
            3:eapply red_prod; [reflexivity|apply redT'].
            all:eauto with fvs.
          -- now rewrite destArity_app destT.
          -- rewrite smash_context_app /= .
            rewrite !app_context_assoc.
            assert (#|smash_context [] ctx| = #|ctx'|).
            { apply All2_fold_length in convctx.
              autorewrite with len in convctx |- *.
              simpl in convctx. simpl. lia. }
            etransitivity; tea.
            apply ws_cumul_ctx_pb_app; auto.
            split. apply ws_cumul_ctx_pb_vass; auto.
            apply ws_cumul_ctx_pb_refl; eauto with fvs.
            eapply ws_cumul_ctx_pb_app; eauto.
            eapply ws_cumul_ctx_pb_refl; eauto with fvs.
            eapply ws_cumul_ctx_pb_closed_left in convctx.
            move: convctx.
            rewrite !on_free_vars_ctx_app. autorewrite with fvs.
            move/andP => [] /andP[] -> /=; cbn; rewrite andb_true_r => onA' ->.
            rewrite shiftnP0 andb_true_r; eauto with fvs.
  Qed.

  Lemma isType_tProd {Γ} {na A B} :
    isType Σ Γ (tProd na A B) <~> (isType Σ Γ A × isType Σ (Γ,, vass na A) B).
  Proof.
    split; intro HH.
    - destruct HH as [s H].
      apply inversion_Prod in H; tas. destruct H as [s1 [s2 [HA [HB Hs]]]].
      split.
      * eexists; tea.
      * eexists; tea.
    - destruct HH as [HA HB].
      destruct HA as [sA HA], HB as [sB HB].
      eexists. econstructor; eassumption.
  Defined.

  Lemma isType_subst {Γ Δ A} s :
    subslet Σ Γ s Δ ->
    isType Σ (Γ ,,, Δ) A ->
    isType Σ Γ (subst0 s A).
  Proof using wfΣ.
    intros sub HT.
    apply infer_typing_sort_impl with id HT; intros Hs.
    have wf := typing_wf_local Hs.
    now eapply (substitution (Δ := []) (T := tSort _)).
  Qed.

  Lemma isType_subst_gen {Γ Δ Δ'} {A} s :
    subslet Σ Γ s Δ ->
    isType Σ (Γ ,,, Δ ,,, Δ') A ->
    isType Σ (Γ ,,, subst_context s 0 Δ') (subst s #|Δ'| A).
  Proof using wfΣ.
    intros sub HT.
    apply infer_typing_sort_impl with id HT; intros Hs.
    now eapply (substitution (T:=tSort _)).
  Qed.

  Lemma type_ws_cumul_pb {pb Γ t} T {U} :
    Σ ;;; Γ |- t : T ->
    isType Σ Γ U ->
    Σ ;;; Γ ⊢ T ≤[pb] U ->
    Σ ;;; Γ |- t : U.
  Proof using Type.
    intros.
    eapply type_Cumul; tea. apply X0.π2.
    destruct pb.
    - eapply ws_cumul_pb_eq_le in X1.
      now eapply cumulAlgo_cumulSpec in X1.
    - now eapply cumulAlgo_cumulSpec.
  Qed.

  Lemma isType_tLetIn_red {Γ} (HΓ : wf_local Σ Γ) {na t A B}
    : isType Σ Γ (tLetIn na t A B) -> isType Σ Γ (B {0:=t}).
  Proof using wfΣ.
    intro HH.
    apply infer_typing_sort_impl with id HH; intros H.
    assert (Hs := typing_wf_universe _ H).
    apply inversion_LetIn in H; tas. destruct H as (s1 & A' & HA & Ht & HB & H).
    eapply (type_ws_cumul_pb (pb:=Cumul)) with (A' {0 := t}). eapply substitution_let in HB; eauto.
    * econstructor; eauto with pcuic. econstructor; eauto.
    * eapply ws_cumul_pb_Sort_r_inv in H as [s' [H H']].
      transitivity (tSort s'); eauto.
      eapply red_ws_cumul_pb.
      apply invert_red_letin in H as [H|H] => //.
      destruct H as (d' & ty' & b' & [reds ]).
      discriminate.
      repeat constructor; eauto with fvs.
  Qed.

  Lemma isType_tLetIn_dom {Γ} (HΓ : wf_local Σ Γ) {na t A B}
    : isType Σ Γ (tLetIn na t A B) -> Σ ;;; Γ |- t : A.
  Proof using wfΣ.
    intros (s & H).
    apply inversion_LetIn in H; tas. now destruct H as (s1 & A' & HA & Ht & HB & H).
  Qed.

  Lemma wf_local_ass {Γ na A} :
    wf_local Σ Γ ->
    isType Σ Γ A ->
    wf_local Σ (Γ ,, vass na A).
  Proof using Type.
    constructor; eauto with pcuic.
  Qed.

  Lemma wf_local_def {Γ na d ty} :
    wf_local Σ Γ ->
    isType Σ Γ ty ->
    Σ ;;; Γ |- d : ty ->
    wf_local Σ (Γ ,, vdef na d ty).
  Proof using Type.
    constructor; eauto with pcuic.
  Qed.

  Hint Resolve wf_local_ass wf_local_def : pcuic.
  Hint Transparent snoc : pcuic.

  Lemma isType_apply {Γ na A B t} :
    isType Σ Γ (tProd na A B) ->
    Σ ;;; Γ |- t : A ->
    isType Σ Γ (B {0 := t}).
  Proof using wfΣ.
    move/isType_tProd => [hA hB] ht.
    eapply (isType_subst (Δ:= [vass na A])); eauto with pcuic.
  Qed.

  Hint Resolve isType_wf_local : pcuic.

  Lemma typing_spine_letin_inv {Γ na b B T args S} :
    typing_spine Σ Γ (tLetIn na b B T) args S ->
    typing_spine Σ Γ (T {0 := b}) args S.
  Proof using wfΣ.
    intros Hsp.
    depelim Hsp.
    constructor; auto.
    eapply isType_tLetIn_red in i; eauto with pcuic.
    now eapply ws_cumul_pb_LetIn_l_inv in w.
    econstructor; eauto.
    eapply isType_tLetIn_red in i; eauto with pcuic.
    now eapply ws_cumul_pb_LetIn_l_inv in w.
  Qed.

  Lemma typing_spine_letin {Γ na b B T args S} :
    isType Σ Γ (tLetIn na b B T) ->
    typing_spine Σ Γ (T {0 := b}) args S ->
    typing_spine Σ Γ (tLetIn na b B T) args S.
  Proof using wfΣ.
    intros Hty Hsp.
    depelim Hsp.
    constructor; auto.
    - etransitivity; tea. eapply into_ws_cumul_pb.
      eapply red_cumul, red1_red, red_zeta. all:eauto with fvs.
    - econstructor; eauto.
      etransitivity; tea.
      eapply into_ws_cumul_pb.
      eapply red_cumul. eapply red1_red, red_zeta.
      all:eauto with fvs.
  Qed.

  Lemma typing_spine_weaken_concl {Γ T args S S'} :
    typing_spine Σ Γ T args S ->
    Σ ;;; Γ ⊢ S ≤ S' ->
    isType Σ Γ S' ->
    typing_spine Σ Γ T args S'.
  Proof using wfΣ.
    induction 1 in S' => cum.
    constructor; auto. transitivity ty'; auto.
    intros isType.
    econstructor; eauto.
  Qed.

  Lemma typing_spine_prod {Γ na b B T args S} :
    typing_spine Σ Γ (T {0 := b}) args S ->
    isType Σ Γ (tProd na B T) ->
    Σ ;;; Γ |- b : B ->
    typing_spine Σ Γ (tProd na B T) (b :: args) S.
  Proof using wfΣ.
    intros Hsp.
    depelim Hsp.
    econstructor; eauto with pcuic.
    - constructor; auto with pcuic.
    - intros Har.
      destruct (fst isType_tProd Har) as [? ?]; eauto using typing_wf_local.
      intros Hb.
      econstructor; eauto with pcuic.
      econstructor; revgoals; eauto with pcuic.
  Qed.

  Lemma typing_spine_WAT_concl {Γ T args S} :
    typing_spine Σ Γ T args S ->
    isType Σ Γ S.
  Proof using Type.
    induction 1; auto.
  Qed.

  Lemma typing_spine_isType_dom {Γ T args S} :
    typing_spine Σ Γ T args S ->
    isType Σ Γ T.
  Proof using Type.
    induction 1; auto.
  Qed.

  Lemma type_mkProd_or_LetIn {Γ} d {u t s} :
    Σ ;;; Γ |- decl_type d : tSort u ->
    Σ ;;; Γ ,, d |- t : tSort s ->
    match decl_body d return Type with
    | Some b => Σ ;;; Γ |- mkProd_or_LetIn d t : tSort s
    | None => Σ ;;; Γ |- mkProd_or_LetIn d t : tSort (Universe.sort_of_product u s)
    end.
  Proof using wfΣ.
    destruct d as [na [b|] dty] => [Hd Ht|Hd Ht]; rewrite /mkProd_or_LetIn /=.
    - have wf := typing_wf_local Ht.
      depelim wf. clear l.
      eapply type_Cumul. econstructor; eauto.
      econstructor; eauto. now eapply typing_wf_universe in Ht; pcuic.
      eapply convSpec_cumulSpec, red1_cumulSpec. constructor.
    - have wf := typing_wf_local Ht.
      depelim wf; clear l.
      eapply type_Prod; eauto.
  Qed.

  Lemma type_it_mkProd_or_LetIn {Γ Γ' u t s} :
    wf_universe Σ u ->
    type_local_ctx (lift_typing typing) Σ Γ Γ' u ->
    Σ ;;; Γ ,,, Γ' |- t : tSort s ->
    Σ ;;; Γ |- it_mkProd_or_LetIn Γ' t : tSort (Universe.sort_of_product u s).
  Proof using wfΣ.
    revert Γ u s t.
    induction Γ'; simpl; auto; move=> Γ u s t wfu equ Ht.
    - eapply type_Cumul; eauto.
      econstructor; eauto using typing_wf_local with pcuic.
      eapply typing_wf_universe in Ht; auto with pcuic.
      eapply cumul_Sort. eapply leq_universe_product.
    - specialize (IHΓ' Γ  u (Universe.sort_of_product u s)); auto.
      unfold app_context in Ht.
      eapply type_Cumul.
      eapply IHΓ'; auto.
      destruct a as [na [b|] ty]; intuition auto.
      destruct a as [na [b|] ty]; intuition auto.
      { apply typing_wf_local in Ht as XX. inversion XX; subst.
        eapply (type_mkProd_or_LetIn {| decl_body := Some b |}); auto.
        + simpl. exact X0.π2.
        + eapply type_Cumul; eauto.
          econstructor; eauto with pcuic.
          eapply cumul_Sort. eapply leq_universe_product. }
      eapply (type_mkProd_or_LetIn {| decl_body := None |}) => /=; eauto.
      econstructor; eauto with pcuic.
      eapply typing_wf_local in Ht.
      depelim Ht; eapply All_local_env_app_inv in Ht; intuition auto.
      now rewrite sort_of_product_twice.
  Qed.

  Fixpoint sort_of_products us s :=
    match us with
    | [] => s
    | u :: us => sort_of_products us (Universe.sort_of_product u s)
    end.

  Lemma leq_universe_sort_of_products_mon {u u' v v'} :
    Forall2 (leq_universe Σ) u u' ->
    leq_universe Σ v v' ->
    leq_universe Σ (sort_of_products u v) (sort_of_products u' v').
  Proof using Type.
    intros hu; induction hu in v, v' |- *; simpl; auto with pcuic.
    intros lev. eapply IHhu.
    eapply leq_universe_product_mon => //.
  Qed.

  Lemma type_it_mkProd_or_LetIn_sorts {Γ Γ' us t s} :
    sorts_local_ctx (lift_typing typing) Σ Γ Γ' us ->
    Σ ;;; Γ ,,, Γ' |- t : tSort s ->
    Σ ;;; Γ |- it_mkProd_or_LetIn Γ' t : tSort (sort_of_products us s).
  Proof using wfΣ.
    revert Γ us s t.
    induction Γ'; simpl; auto; move=> Γ us s t equ Ht.
    - destruct us => //.
    - destruct a as [na [b|] ty]; intuition auto.
      * destruct a0 as [s' Hs].
        eapply IHΓ'; eauto.
        eapply (type_mkProd_or_LetIn {| decl_body := Some b |}); auto.
        simpl. exact Hs.
      * destruct us => //. destruct equ.
        simpl.
        eapply IHΓ'; eauto.
        apply (type_mkProd_or_LetIn {| decl_body := None |}) => /=; eauto.
  Qed.

  Lemma isType_it_mkProd_or_LetIn {Γ Γ' us t} :
    sorts_local_ctx (lift_typing typing) Σ Γ Γ' us ->
    isType Σ (Γ ,,, Γ') t ->
    isType Σ Γ (it_mkProd_or_LetIn Γ' t).
  Proof using cf Σ wfΣ.
    move=> equs [s ttyp]; exists (sort_of_products us s).
    apply: type_it_mkProd_or_LetIn_sorts=> //.
  Qed.

  Lemma app_context_push Γ Δ Δ' d : (Γ ,,, Δ ,,, Δ') ,, d = (Γ ,,, Δ ,,, (Δ' ,, d)).
  Proof using Type.
    reflexivity.
  Qed.

  Hint Extern 4 (_ ;;; _ |- _ <= _) => reflexivity : pcuic.
  Ltac pcuic := eauto 5 with pcuic.

  Lemma subslet_app_closed {Γ s s' Δ Δ'} :
    subslet Σ Γ s Δ ->
    subslet Σ Γ s' Δ' ->
    closed_ctx Δ ->
    subslet Σ Γ (s ++ s') (Δ' ,,, Δ).
  Proof using Type.
    induction 1 in s', Δ'; simpl; auto; move=> sub' => /andb_and [clctx clt];
    try constructor; auto.
    - pose proof (subslet_length X). rewrite Nat.add_0_r in clt.
      rewrite /= -H in clt.
      rewrite subst_app_simpl /= (subst_closedn s') //.
    - pose proof (subslet_length X). rewrite Nat.add_0_r in clt.
      rewrite /= -H in clt. move/andb_and: clt => [clt clT].
      replace (subst0 s t) with (subst0 (s ++ s') t).
      + constructor; auto.
        rewrite !subst_app_simpl /= !(subst_closedn s') //.
      + rewrite !subst_app_simpl /= !(subst_closedn s') //.
  Qed.

  Hint Constructors subslet : core pcuic.

  Lemma subslet_app_inv {Γ Δ Δ' s} :
    subslet Σ Γ s (Δ ,,, Δ') ->
    subslet Σ Γ (skipn #|Δ'| s) Δ *
    subslet Σ Γ (firstn #|Δ'| s) (subst_context (skipn #|Δ'| s) 0 Δ').
  Proof using Type.
    intros sub. split.
    - induction Δ' in Δ, s, sub |- *; simpl; first by rewrite skipn_0.
      depelim sub; rewrite skipn_S; auto.
    - induction Δ' in Δ, s, sub |- *; simpl; first by constructor.
      destruct s; depelim sub.
      * rewrite subst_context_snoc. constructor; eauto.
        rewrite skipn_S Nat.add_0_r /=.
        assert(#|Δ'| = #|firstn #|Δ'| s|).
        { pose proof (subslet_length sub).
          rewrite app_context_length in H.
          rewrite firstn_length_le; lia. }
        rewrite {3}H.
        rewrite -subst_app_simpl.
        now rewrite firstn_skipn.
      * rewrite subst_context_snoc.
        rewrite skipn_S Nat.add_0_r /=.
        rewrite /subst_decl /map_decl /=.
        specialize (IHΔ' _ _ sub).
        epose proof (cons_let_def _ _ _ _ _ (subst (skipn #|Δ'| s0) #|Δ'| t0)
        (subst (skipn #|Δ'| s0) #|Δ'| T) IHΔ').
        assert(#|Δ'| = #|firstn #|Δ'| s0|).
        { pose proof (subslet_length sub).
          rewrite app_context_length in H.
          rewrite firstn_length_le; lia. }
        rewrite {3 6}H in X.
        rewrite - !subst_app_simpl in X.
        rewrite !firstn_skipn in X.
        specialize (X t1).
        rewrite {3}H in X.
        now rewrite - !subst_app_simpl firstn_skipn in X.
  Qed.

  Lemma subslet_inds {ind u mdecl idecl} :
    declared_inductive Σ.1 ind mdecl idecl ->
    consistent_instance_ext Σ (ind_universes mdecl) u ->
    subslet Σ [] (inds (inductive_mind ind) u (ind_bodies mdecl))
      (subst_instance u (arities_context (ind_bodies mdecl))).
  Proof using wfΣ.
    intros isdecl univs.
    unfold inds.
    pose proof (proj1 isdecl) as declm.
    apply on_declared_minductive in declm as [oind oc]; auto.
    clear oc.
    assert (Alli (fun i x =>
      Σ ;;; [] |- tInd {| inductive_mind := inductive_mind ind; inductive_ind := i |} u : subst_instance u (ind_type x)) 0 (ind_bodies mdecl)).
    { apply forall_nth_error_Alli.
      econstructor; eauto. split; eauto. simpl. eapply isdecl. }
    clear oind.
    revert X. clear onNpars.
    generalize (le_n #|ind_bodies mdecl|).
    generalize (ind_bodies mdecl) at 1 3 4 5.
    induction l using rev_ind; simpl; first constructor.
    rewrite /subst_instance /= /map_context.
    simpl. rewrite /arities_context rev_map_spec /=.
    rewrite map_app /= rev_app_distr /=.
    rewrite {1}/map_decl /= app_length /= Nat.add_1_r.
    constructor.
    - rewrite -rev_map_spec. apply IHl; try lia.
      eapply Alli_app in X; intuition auto.
    - eapply Alli_app in X as [oind Hx].
      depelim Hx. clear Hx.
      rewrite Nat.add_0_r in t.
      rewrite subst_closedn; auto.
      + now eapply type_closed in t.
  Qed.

  Lemma weaken_subslet {s Δ Γ} :
    wf_local Σ Γ ->
    subslet Σ [] s Δ -> subslet Σ Γ s Δ.
  Proof using wfΣ.
    intros wfΔ.
    induction 1; constructor; auto.
    + eapply (weaken_ctx (Γ:=[]) Γ); eauto.
    + eapply (weaken_ctx (Γ:=[]) Γ); eauto.
  Qed.

  Set Default Goal Selector "1".

  Lemma isType_substitution_it_mkProd_or_LetIn {Γ Δ T s} :
    subslet Σ Γ s Δ ->
    isType Σ Γ (it_mkProd_or_LetIn Δ T) ->
    isType Σ Γ (subst0 s T).
  Proof using wfΣ.
    intros sub HT.
    apply infer_typing_sort_impl with id HT; intros Hs.
    destruct HT as (s' & t); cbn in Hs |- *; clear t.
    revert Γ s sub Hs.
    generalize (le_n #|Δ|).
    generalize #|Δ| at 2.
    induction n in Δ, T |- *.
    - destruct Δ; simpl; intros; try (elimtype False; lia).
      depelim sub.
      rewrite subst_empty; auto.
    - destruct Δ using rev_ind; try clear IHΔ.
      + intros Hn Γ s sub; now depelim sub; rewrite subst_empty.
      + rewrite app_length Nat.add_1_r /= => Hn Γ s sub.
      pose proof (subslet_length sub). rewrite app_length /= Nat.add_1_r in H.
      have Hl : #|l| = #|firstn #|l| s|.
      { rewrite firstn_length_le; lia. }
      destruct x as [na [b|] ty] => /=;
      rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=.

      intros Hs.
      assert (wfs' := typing_wf_universe wfΣ Hs).
      eapply inversion_LetIn in Hs as (? & ? & ? & ? & ? & ?); auto.
      eapply substitution_let in t1; auto.
      eapply ws_cumul_pb_LetIn_l_inv in w; auto.
      pose proof (subslet_app_inv sub) as [subl subr].
      depelim subl. depelim subl. rewrite subst_empty in H0. rewrite H0 in subr.
      specialize (IHn (subst_context [b] 0 l) (subst [b] #|l| T) ltac:(rewrite subst_context_length; lia)).
      specialize (IHn _ _ subr).
      rewrite /subst1 subst_it_mkProd_or_LetIn Nat.add_0_r in t1.
      rewrite !subst_empty in t3.
      forward IHn.
      eapply type_Cumul. eapply t1. econstructor; intuition eauto using typing_wf_local with pcuic.
      eapply (cumulAlgo_cumulSpec _ (pb:=Cumul)), w. rewrite {2}Hl in IHn.
      now rewrite -subst_app_simpl -H0 firstn_skipn in IHn.

      intros Hs.
      assert (wfs' := typing_wf_universe wfΣ Hs).
      eapply inversion_Prod in Hs as (? & ? & ? & ? & ?); auto.
      pose proof (subslet_app_inv sub) as [subl subr].
      depelim subl; depelim subl. rewrite subst_empty in t2. rewrite H0 in subr.
      epose proof (substitution0 t0 t2).
      specialize (IHn (subst_context [t1] 0 l) (subst [t1] #|l| T)).
      forward IHn. rewrite subst_context_length; lia.
      specialize (IHn _ _ subr).
      rewrite /subst1 subst_it_mkProd_or_LetIn Nat.add_0_r in X.
      forward IHn.
      eapply type_Cumul. simpl in X. eapply X.
      econstructor; eauto with pcuic.
      eapply ws_cumul_pb_Sort_inv in w. eapply cumul_Sort.
      transitivity (Universe.sort_of_product x x0).
      eapply leq_universe_product. auto.
      rewrite {2}Hl in IHn.
      now rewrite -subst_app_simpl -H0 firstn_skipn in IHn.
  Qed.

  Lemma on_minductive_wf_params {ind mdecl} {u} :
    declared_minductive Σ.1 ind mdecl ->
    consistent_instance_ext Σ (ind_universes mdecl) u ->
    wf_local Σ (subst_instance u (ind_params mdecl)).
  Proof using wfΣ.
    intros. eapply (wf_local_instantiate (decl := InductiveDecl mdecl)); eauto.
    eapply on_declared_minductive in H; auto.
    now apply onParams in H.
  Qed.

  Lemma it_mkProd_or_LetIn_wf_local {Γ Δ T U} :
    Σ ;;; Γ |- it_mkProd_or_LetIn Δ T : U -> wf_local Σ (Γ ,,, Δ).
  Proof using wfΣ.
    move: Γ T U.
    induction Δ using rev_ind => Γ T U.
    + simpl. intros. now eapply typing_wf_local in X.
    + rewrite it_mkProd_or_LetIn_app.
      destruct x as [na [b|] ty]; cbn; move=> H.
      * apply inversion_LetIn in H as (s1 & A & H0 & H1 & H2 & H3); auto.
        eapply All_local_env_app; split; pcuic.
        eapply All_local_env_app. split. repeat constructor. now exists s1.
        auto. apply IHΔ in H2.
        eapply All_local_env_app_inv in H2. intuition auto.
        eapply All_local_env_impl; eauto. simpl. intros.
        now rewrite app_context_assoc.
      * apply inversion_Prod in H as (s1 & A & H0 & H1 & H2); auto.
        eapply All_local_env_app; split; pcuic.
        eapply All_local_env_app. split. repeat constructor. now exists s1.
        apply IHΔ in H1.
        eapply All_local_env_app_inv in H1. intuition auto.
        eapply All_local_env_impl; eauto. simpl. intros.
        now rewrite app_context_assoc.
  Qed.

  Lemma isType_it_mkProd_or_LetIn_wf_local {Γ Δ T} :
    isType Σ Γ (it_mkProd_or_LetIn Δ T) -> wf_local Σ (Γ ,,, Δ).
  Proof using wfΣ.
    move=> [s Hs].
    now eapply it_mkProd_or_LetIn_wf_local in Hs.
  Qed.

  Lemma isType_weaken {Γ T} :
    wf_local Σ Γ ->
    isType Σ [] T ->
    isType Σ Γ T.
  Proof using wfΣ.
    intros wfΓ HT.
    apply infer_typing_sort_impl with id HT; intros hs.
    unshelve epose proof (subject_closed hs); eauto.
    eapply (weakening _ _ Γ) in hs => //.
    rewrite lift_closed in hs => //.
    now rewrite app_context_nil_l in hs.
    now rewrite app_context_nil_l.
  Qed.

  Lemma subst_telescope_subst_instance u s k Γ :
    subst_telescope (map (subst_instance u) s) k
      (subst_instance u Γ) =
    subst_instance u (subst_telescope s k Γ).
  Proof using Type.
    rewrite /subst_telescope /subst_instance /= /subst_instance_context /map_context.
    rewrite map_mapi mapi_map. apply mapi_ext.
    intros. rewrite !compose_map_decl; apply map_decl_ext => ?.
    now rewrite -subst_instance_subst.
  Qed.
End WfEnv.


Require Import oeuf.Common.
Require oeuf.StepLib.
Require Import Psatz.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.

Require Export oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.

Inductive insn :=
| Block (code : list insn)
| Arg
| Self
| Deref (off : nat)
| Call
| MkConstr (tag : nat) (nargs : nat)
| Switch (cases : list (list insn))
| MkClose (f : function_name) (nfree : nat)
| OpaqueOp (op : opaque_oper_name) (nargs : nat)
.

Definition env := list (list insn).

(* Continuation-based step relation *)

Record frame := Frame {
    arg : value;
    self : value;
    stack : list value
}.

Definition push f v :=
    Frame (arg f) (self f) (v :: stack f).

Inductive state :=
| Run (i : list insn) (f : frame) (k : value -> state)
| Stop (v : value).

Inductive sstep (E : env) : state -> state -> Prop :=
| SBlock : forall code is f k,
        sstep E (Run (Block code :: is) f k)
                (Run code (Frame (arg f) (self f) []) (fun v => Run is (push f v) k))

| SArg : forall f k,
        stack f = [] ->
        sstep E (Run [Arg] f k) (k (arg f))
| SSelf : forall f k,
        stack f = [] ->
        sstep E (Run [Self] f k) (k (self f))

| SDerefinateConstr : forall off f k  tag args v,
        stack f = [Constr tag args] ->
        nth_error args off = Some v ->
        sstep E (Run [Deref off] f k) (k v)
| SDerefinateClose : forall off f k  fname free v,
        stack f = [Close fname free] ->
        nth_error free off = Some v ->
        sstep E (Run [Deref off] f k) (k v)

| SConstrDone : forall tag nargs f k,
        length (stack f) = nargs ->
        sstep E (Run [MkConstr tag nargs] f k)
                (k (Constr tag (rev (stack f))))
| SCloseDone : forall fname nfree f k,
        length (stack f) = nfree ->
        sstep E (Run [MkClose fname nfree] f k)
                (k (Close fname (rev (stack f))))
| SOpaqueOpDone : forall op nargs f k v,
        length (stack f) = nargs ->
        opaque_oper_denote_higher op (rev (stack f)) = Some v ->
        sstep E (Run [OpaqueOp op nargs] f k)
                (k v)

| SMakeCall : forall f k  fname free body argv,
        stack f = [argv; Close fname free] ->
        nth_error E fname = Some body ->
        sstep E (Run [Call] f k)
                (Run body (Frame argv (Close fname free) []) k)

(* NB: `Switch` still has an implicit target of `Arg` *)
| SSwitchinate : forall cases f k  tag args case,
        stack f = [] ->
        arg f = Constr tag args ->
        nth_error cases tag = Some case ->
        sstep E (Run [Switch cases] f k)
                (Run case (Frame (arg f) (self f) []) k)
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

Require Import oeuf.Metadata.
Require oeuf.Semantics.

Definition prog_type : Type := env * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body,
        nth_error (fst prog) fname = Some body ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body
                 (Frame av fv [])
                 Stop).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition insn_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HBlock :   forall code, Pl code -> P (Block code))
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Pll cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (i : insn) : P i :=
    let fix go i :=
        let fix go_list is :=
            match is as is_ return Pl is_ with
            | [] => Hnil
            | i :: is => Hcons i is (go i) (go_list is)
            end in
        let fix go_list_list iss :=
            match iss as iss_ return Pll iss_ with
            | [] => Hnil2
            | is :: iss => Hcons2 is iss (go_list is) (go_list_list iss)
            end in
        match i as i_ return P i_ with
        | Block code => HBlock code (go_list code)
        | Arg => HArg
        | Self => HSelf
        | Deref off => HDeref off
        | Call => HCall
        | MkConstr tag nargs => HConstr tag nargs
        | Switch cases => HSwitch cases (go_list_list cases)
        | MkClose fname nfree => HClose fname nfree
        | OpaqueOp op nargs => HOpaqueOp op nargs
        end in go i.

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition insn_ind' (P : insn -> Prop)
    (HBlock :   forall code, Forall P code -> P (Block code))
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Forall (Forall P) cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (i : insn) : P i :=
    ltac:(refine (@insn_rect_mut P (Forall P) (Forall (Forall P))
        HBlock HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp _ _ _ _ i); eauto).

Definition insn_list_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HBlock :   forall code, Pl code -> P (Block code))
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Pll cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (is : list insn) : Pl is :=
    let go := insn_rect_mut P Pl Pll
            HBlock HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp
            Hnil Hcons Hnil2 Hcons2 in
    let fix go_list is :=
        match is as is_ return Pl is_ with
        | [] => Hnil
        | i :: is => Hcons i is (go i) (go_list is)
        end in go_list is.


From Mtac2 Require Import Mtac2.

Class Test := { val : nat }.

#[global] Instance Zero : Test := {| val := 0 |}.

Import M.notations.

Definition CouldntFindTC : Exception. exact exception. Qed.

Definition fail_solve_tc A :=
  M.solve_typeclass A >>= fun x=>
  match x with
  | mSome v => M.ret v
  | mNone => M.raise CouldntFindTC
  end.

Definition zero := ltac:(mrun (fail_solve_tc Test >>= fun x=>M.ret (@val x))).

Goal zero = 0.
MProof.
  T.reflexivity.
Qed.

Class TestFail := { valF : nat }.

Definition fail_but_caught := ltac: (mrun (
  mtry fail_solve_tc TestFail;; M.ret 1
  with CouldntFindTC => M.ret 0 end)).

Goal fail_but_caught = 0.
MProof.
  T.reflexivity.
Qed.


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

(** Correctness proof for code linearization *)

Require Import FSets.
Require Import Coqlib Maps Ordered Errors Lattice Kildall Integers.
Require Import AST Linking.
Require Import Values Memory Events Globalenvs Smallstep.
Require Import Op Locations LTL Linear.
Require Import Linearize.

Module NodesetFacts := FSetFacts.Facts(Nodeset).

Definition match_prog (p: LTL.program) (tp: Linear.program) :=
  match_program (fun ctx f tf => transf_fundef f = OK tf) eq p tp.

Lemma transf_program_match:
  forall p tp, transf_program p = OK tp -> match_prog p tp.
Proof.
  intros. eapply match_transform_partial_program; eauto.
Qed.

Section LINEARIZATION.

Variable fn_stack_requirements: ident -> Z.
Variable prog: LTL.program.
Variable tprog: Linear.program.

Hypothesis TRANSF: match_prog prog tprog.

Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Lemma functions_translated:
  forall v f,
  Genv.find_funct ge v = Some f ->
  exists tf,
  Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf.
Proof (Genv.find_funct_transf_partial TRANSF).

Lemma function_ptr_translated:
  forall v f,
  Genv.find_funct_ptr ge v = Some f ->
  exists tf,
  Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf.
Proof (Genv.find_funct_ptr_transf_partial TRANSF).

Lemma symbols_preserved:
  forall id,
  Genv.find_symbol tge id = Genv.find_symbol ge id.
Proof (Genv.find_symbol_transf_partial TRANSF).

Lemma senv_preserved:
  Senv.equiv ge tge.
Proof (Genv.senv_transf_partial TRANSF).

Lemma sig_preserved:
  forall f tf,
  transf_fundef f = OK tf ->
  Linear.funsig tf = LTL.funsig f.
Proof.
  unfold transf_fundef, transf_partial_fundef; intros.
  destruct f. monadInv H. monadInv EQ. reflexivity.
  inv H. reflexivity.
Qed.

Lemma stacksize_preserved:
  forall f tf,
  transf_function f = OK tf ->
  Linear.fn_stacksize tf = LTL.fn_stacksize f.
Proof.
  intros. monadInv H. auto.
Qed.

Lemma find_function_translated:
  forall ros ls f,
  LTL.find_function ge ros ls = Some f ->
  exists tf,
  find_function tge ros ls = Some tf /\ transf_fundef f = OK tf.
Proof.
  unfold LTL.find_function; intros; destruct ros; simpl.
  apply functions_translated; auto.
  rewrite symbols_preserved. destruct (Genv.find_symbol ge i).
  apply function_ptr_translated; auto.
  congruence.
Qed.

(** * Correctness of reachability analysis *)

(** The entry point of the function is reachable. *)

Lemma reachable_entrypoint:
  forall f, (reachable f)!!(f.(fn_entrypoint)) = true.
Proof.
  intros. unfold reachable.
  caseEq (reachable_aux f).
  unfold reachable_aux; intros reach A.
  assert (LBoolean.ge reach!!(f.(fn_entrypoint)) true).
  eapply DS.fixpoint_entry. eexact A. auto.
  unfold LBoolean.ge in H. tauto.
  intros. apply PMap.gi.
Qed.

(** The successors of a reachable instruction are reachable. *)

Lemma reachable_successors:
  forall f pc pc' b,
  f.(LTL.fn_code)!pc = Some b -> In pc' (successors_block b) ->
  (reachable f)!!pc = true ->
  (reachable f)!!pc' = true.
Proof.
  intro f. unfold reachable.
  caseEq (reachable_aux f).
  unfold reachable_aux. intro reach; intros.
  assert (LBoolean.ge reach!!pc' reach!!pc).
  change (reach!!pc) with ((fun pc r => r) pc (reach!!pc)).
  eapply DS.fixpoint_solution; eauto. intros; apply DS.L.eq_refl.
  elim H3; intro. congruence. auto.
  intros. apply PMap.gi.
Qed.

(** * Properties of node enumeration *)

(** An enumeration of CFG nodes is correct if the following conditions hold:
- All nodes for reachable basic blocks must be in the list.
- The list is without repetition (so that no code duplication occurs).

We prove that the result of the [enumerate] function satisfies both
conditions. *)

Lemma nodeset_of_list_correct:
  forall l s s',
  nodeset_of_list l s = OK s' ->
  list_norepet l
  /\ (forall pc, Nodeset.In pc s' <-> Nodeset.In pc s \/ In pc l)
  /\ (forall pc, In pc l -> ~Nodeset.In pc s).
Proof.
  induction l; simpl; intros.
  inv H. split. constructor. split. intro; tauto. intros; tauto.
  generalize H; clear H; caseEq (Nodeset.mem a s); intros.
  inv H0.
  exploit IHl; eauto. intros [A [B C]].
  split. constructor; auto. red; intro. elim (C a H1). apply Nodeset.add_1. hnf. auto.
  split. intros. rewrite B. rewrite NodesetFacts.add_iff.
  unfold Nodeset.E.eq. unfold OrderedPositive.eq. tauto.
  intros. destruct H1. subst pc. rewrite NodesetFacts.not_mem_iff. auto.
  generalize (C pc H1). rewrite NodesetFacts.add_iff. tauto.
Qed.

Lemma check_reachable_correct:
  forall f reach s pc i,
  check_reachable f reach s = true ->
  f.(LTL.fn_code)!pc = Some i ->
  reach!!pc = true ->
  Nodeset.In pc s.
Proof.
  intros f reach s.
  assert (forall l ok,
    List.fold_left (fun a p => check_reachable_aux reach s a (fst p) (snd p)) l ok = true ->
    ok = true /\
    (forall pc i,
     In (pc, i) l ->
     reach!!pc = true ->
     Nodeset.In pc s)).
  induction l; simpl; intros.
  split. auto. intros. destruct H0.
  destruct a as [pc1 i1]. simpl in H.
  exploit IHl; eauto. intros [A B].
  unfold check_reachable_aux in A.
  split. destruct (reach!!pc1). elim (andb_prop _ _ A). auto. auto.
  intros. destruct H0. inv H0. rewrite H1 in A. destruct (andb_prop _ _ A).
  apply Nodeset.mem_2; auto.
  eauto.

  intros pc i. unfold check_reachable. rewrite PTree.fold_spec. intros.
  exploit H; eauto. intros [A B]. eapply B; eauto.
  apply PTree.elements_correct. eauto.
Qed.

Lemma enumerate_complete:
  forall f enum pc i,
  enumerate f = OK enum ->
  f.(LTL.fn_code)!pc = Some i ->
  (reachable f)!!pc = true ->
  In pc enum.
Proof.
  intros until i. unfold enumerate.
  set (reach := reachable f).
  intros. monadInv H.
  generalize EQ0; clear EQ0. caseEq (check_reachable f reach x); intros; inv EQ0.
  exploit check_reachable_correct; eauto. intro.
  exploit nodeset_of_list_correct; eauto. intros [A [B C]].
  rewrite B in H2. destruct H2. elim (Nodeset.empty_1 H2). auto.
Qed.

Lemma enumerate_norepet:
  forall f enum,
  enumerate f = OK enum ->
  list_norepet enum.
Proof.
  intros until enum. unfold enumerate.
  set (reach := reachable f).
  intros. monadInv H.
  generalize EQ0; clear EQ0. caseEq (check_reachable f reach x); intros; inv EQ0.
  exploit nodeset_of_list_correct; eauto. intros [A [B C]]. auto.
Qed.

(** * Properties related to labels *)

(** If labels are globally unique and the Linear code [c] contains
  a subsequence [Llabel lbl :: c1], then [find_label lbl c] returns [c1].
*)

Fixpoint unique_labels (c: code) : Prop :=
  match c with
  | nil => True
  | Llabel lbl :: c => ~(In (Llabel lbl) c) /\ unique_labels c
  | i :: c => unique_labels c
  end.

Lemma find_label_unique:
  forall lbl c1 c2 c3,
  is_tail (Llabel lbl :: c1) c2 ->
  unique_labels c2 ->
  find_label lbl c2 = Some c3 ->
  c1 = c3.
Proof.
  induction c2.
  simpl; intros; discriminate.
  intros c3 TAIL UNIQ. simpl.
  generalize (is_label_correct lbl a). case (is_label lbl a); intro ISLBL.
  subst a. intro. inversion TAIL. congruence.
  elim UNIQ; intros. elim H4. apply is_tail_in with c1; auto.
  inversion TAIL. congruence. apply IHc2. auto.
  destruct a; simpl in UNIQ; tauto.
Qed.

(** Correctness of the [starts_with] test. *)

Lemma starts_with_correct:
  forall lbl c1 c2 c3 s f sp ls m,
  is_tail c1 c2 ->
  unique_labels c2 ->
  starts_with lbl c1 = true ->
  find_label lbl c2 = Some c3 ->
  plus (step fn_stack_requirements) tge (State s f sp c1 ls m)
             E0 (State s f sp c3 ls m).
Proof.
  induction c1.
  simpl; intros; discriminate.
  simpl starts_with. destruct a; try (intros; discriminate).
  intros.
  apply plus_left with E0 (State s f sp c1 ls m) E0.
  simpl. constructor.
  destruct (peq lbl l).
  subst l. replace c3 with c1. constructor.
  apply find_label_unique with lbl c2; auto.
  apply plus_star.
  apply IHc1 with c2; auto. eapply is_tail_cons_left; eauto.
  traceEq.
Qed.

(** Connection between [find_label] and linearization. *)

Lemma find_label_add_branch:
  forall lbl k s,
  find_label lbl (add_branch s k) = find_label lbl k.
Proof.
  intros. unfold add_branch. destruct (starts_with s k); auto.
Qed.

Lemma find_label_lin_block:
  forall lbl k b,
  find_label lbl (linearize_block b k) = find_label lbl k.
Proof.
  intros lbl k. generalize (find_label_add_branch lbl k); intro.
  induction b; simpl; auto. destruct a; simpl; auto.
  case (starts_with s1 k); simpl; auto.
Qed.

Remark linearize_body_cons:
  forall f pc enum,
  linearize_body f (pc :: enum) =
  match f.(LTL.fn_code)!pc with
  | None => linearize_body f enum
  | Some b => Llabel pc :: linearize_block b (linearize_body f enum)
  end.
Proof.
  intros. unfold linearize_body. rewrite list_fold_right_eq.
  unfold linearize_node. destruct (LTL.fn_code f)!pc; auto.
Qed.

Lemma find_label_lin_rec:
  forall f enum pc b,
  In pc enum ->
  f.(LTL.fn_code)!pc = Some b ->
  exists k, find_label pc (linearize_body f enum) = Some (linearize_block b k).
Proof.
  induction enum; intros.
  elim H.
  rewrite linearize_body_cons.
  destruct (peq a pc).
  subst a. exists (linearize_body f enum).
  rewrite H0. simpl. rewrite peq_true. auto.
  assert (In pc enum). simpl in H. tauto.
  destruct (IHenum pc b H1 H0) as [k FIND].
  exists k. destruct (LTL.fn_code f)!a.
  simpl. rewrite peq_false. rewrite find_label_lin_block. auto. auto.
  auto.
Qed.

Lemma find_label_lin:
  forall f tf pc b,
  transf_function f = OK tf ->
  f.(LTL.fn_code)!pc = Some b ->
  (reachable f)!!pc = true ->
  exists k,
  find_label pc (fn_code tf) = Some (linearize_block b k).
Proof.
  intros. monadInv H. simpl.
  rewrite find_label_add_branch. apply find_label_lin_rec.
  eapply enumerate_complete; eauto. auto.
Qed.

Lemma find_label_lin_inv:
  forall f tf pc b k,
  transf_function f = OK tf ->
  f.(LTL.fn_code)!pc = Some b ->
  (reachable f)!!pc = true ->
  find_label pc (fn_code tf) = Some k ->
  exists k', k = linearize_block b k'.
Proof.
  intros. exploit find_label_lin; eauto. intros [k' FIND].
  exists k'. congruence.
Qed.

(** Unique label property for linearized code. *)

Lemma label_in_add_branch:
  forall lbl s k,
  In (Llabel lbl) (add_branch s k) -> In (Llabel lbl) k.
Proof.
  intros until k; unfold add_branch.
  destruct (starts_with s k); simpl; intuition congruence.
Qed.

Lemma label_in_lin_block:
  forall lbl k b,
  In (Llabel lbl) (linearize_block b k) -> In (Llabel lbl) k.
Proof.
  induction b; simpl; intros. auto.
  destruct a; simpl in H; try (intuition congruence).
  apply label_in_add_branch with s; intuition congruence.
  destruct (starts_with s1 k); simpl in H.
  apply label_in_add_branch with s1; intuition congruence.
  apply label_in_add_branch with s2; intuition congruence.
Qed.

Lemma label_in_lin_rec:
  forall f lbl enum,
  In (Llabel lbl) (linearize_body f enum) -> In lbl enum.
Proof.
  induction enum.
  simpl; auto.
  rewrite linearize_body_cons. destruct (LTL.fn_code f)!a.
  simpl. intros [A|B]. left; congruence.
  right. apply IHenum. eapply label_in_lin_block; eauto.
  intro; right; auto.
Qed.

Lemma unique_labels_add_branch:
  forall lbl k,
  unique_labels k -> unique_labels (add_branch lbl k).
Proof.
  intros; unfold add_branch.
  destruct (starts_with lbl k); simpl; intuition.
Qed.

Lemma unique_labels_lin_block:
  forall k b,
  unique_labels k -> unique_labels (linearize_block b k).
Proof.
  induction b; intros; simpl. auto.
  destruct a; auto; try (apply unique_labels_add_branch; auto).
  case (starts_with s1 k); simpl; apply unique_labels_add_branch; auto.
Qed.

Lemma unique_labels_lin_rec:
  forall f enum,
  list_norepet enum ->
  unique_labels (linearize_body f enum).
Proof.
  induction enum.
  simpl; auto.
  rewrite linearize_body_cons.
  intro. destruct (LTL.fn_code f)!a.
  simpl. split. red. intro. inversion H. elim H3.
  apply label_in_lin_rec with f.
  apply label_in_lin_block with b. auto.
  apply unique_labels_lin_block. apply IHenum. inversion H; auto.
  apply IHenum. inversion H; auto.
Qed.

Lemma unique_labels_transf_function:
  forall f tf,
  transf_function f = OK tf ->
  unique_labels (fn_code tf).
Proof.
  intros. monadInv H. simpl.
  apply unique_labels_add_branch.
  apply unique_labels_lin_rec. eapply enumerate_norepet; eauto.
Qed.

(** Correctness of [add_branch]. *)

Lemma is_tail_find_label:
  forall lbl c2 c1,
  find_label lbl c1 = Some c2 -> is_tail c2 c1.
Proof.
  induction c1; simpl.
  intros; discriminate.
  case (is_label lbl a). intro. injection H; intro. subst c2.
  constructor. constructor.
  intro. constructor. auto.
Qed.

Lemma is_tail_add_branch:
  forall lbl c1 c2, is_tail (add_branch lbl c1) c2 -> is_tail c1 c2.
Proof.
  intros until c2. unfold add_branch. destruct (starts_with lbl c1).
  auto. eauto with coqlib.
Qed.

Lemma is_tail_lin_block:
  forall b c1 c2,
  is_tail (linearize_block b c1) c2 -> is_tail c1 c2.
Proof.
  induction b; simpl; intros.
  auto.
  destruct a; eauto with coqlib.
  eapply is_tail_add_branch; eauto.
  destruct (starts_with s1 c1); eapply is_tail_add_branch; eauto with coqlib.
Qed.

Lemma add_branch_correct:
  forall lbl c k s f tf sp ls m,
  transf_function f = OK tf ->
  is_tail k tf.(fn_code) ->
  find_label lbl tf.(fn_code) = Some c ->
  plus (step fn_stack_requirements) tge (State s tf sp (add_branch lbl k) ls m)
             E0 (State s tf sp c ls m).
Proof.
  intros. unfold add_branch.
  caseEq (starts_with lbl k); intro SW.
  eapply starts_with_correct; eauto.
  eapply unique_labels_transf_function; eauto.
  apply plus_one. apply exec_Lgoto. auto.
Qed.

(** * Correctness of linearization *)

(** The proof of semantic preservation is a simulation argument of the "star" kind:
<<
           st1 --------------- st2
            |                   |
           t|                  t| + or ( 0 \/ |st1'| < |st1| )
            |                   |
            v                   v
           st1'--------------- st2'
>>
  The invariant (horizontal lines above) is the [match_states]
  predicate defined below.  It captures the fact that the flow
  of data is the same in the source and linearized codes.
  Moreover, whenever the source state is at node [pc] in its
  control-flow graph, the transformed state is at a code
  sequence [c] that starts with the label [pc]. *)

Inductive match_stackframes: LTL.stackframe -> Linear.stackframe -> Prop :=
  | match_stackframe_intro:
      forall f sp bb ls tf c,
      transf_function f = OK tf ->
      (forall pc, In pc (successors_block bb) -> (reachable f)!!pc = true) ->
      is_tail c tf.(fn_code) ->
      match_stackframes
        (LTL.Stackframe f sp ls bb)
        (Linear.Stackframe tf sp ls (linearize_block bb c)).

Inductive match_states: LTL.state -> Linear.state -> Prop :=
  | match_states_add_branch:
      forall s f sp pc ls m tf ts c
        (STACKS: list_forall2 match_stackframes s ts)
        (TRF: transf_function f = OK tf)
        (REACH: (reachable f)!!pc = true)
        (TAIL: is_tail c tf.(fn_code)),
      match_states (LTL.State s f sp pc ls m)
                   (Linear.State ts tf sp (add_branch pc c) ls m)
  | match_states_cond_taken:
      forall s f sp pc ls m tf ts cond args c
        (STACKS: list_forall2 match_stackframes s ts)
        (TRF: transf_function f = OK tf)
        (REACH: (reachable f)!!pc = true)
        (JUMP: eval_condition cond (reglist ls args) m = Some true),
      match_states (LTL.State s f sp pc (undef_regs (destroyed_by_cond cond) ls) m)
                   (Linear.State ts tf sp (Lcond cond args pc :: c) ls m)
  | match_states_jumptable:
      forall s f sp pc ls m tf ts arg tbl c n
        (STACKS: list_forall2 match_stackframes s ts)
        (TRF: transf_function f = OK tf)
        (REACH: (reachable f)!!pc = true)
        (ARG: ls (R arg) = Vint n)
        (JUMP: list_nth_z tbl (Int.unsigned n) = Some pc),
      match_states (LTL.State s f sp pc (undef_regs destroyed_by_jumptable ls) m)
                   (Linear.State ts tf sp (Ljumptable arg tbl :: c) ls m)
  | match_states_block:
      forall s f sp bb ls m tf ts c
        (STACKS: list_forall2 match_stackframes s ts)
        (TRF: transf_function f = OK tf)
        (REACH: forall pc, In pc (successors_block bb) -> (reachable f)!!pc = true)
        (TAIL: is_tail c tf.(fn_code)),
      match_states (LTL.Block s f sp bb ls m)
                   (Linear.State ts tf sp (linearize_block bb c) ls m)
  | match_states_call:
      forall s f ls m tf ts id,
      list_forall2 match_stackframes s ts ->
      transf_fundef f = OK tf ->
      match_states (LTL.Callstate s f ls m id)
                   (Linear.Callstate ts tf ls m id)
  | match_states_return:
      forall s ls m ts,
      list_forall2 match_stackframes s ts ->
      match_states (LTL.Returnstate s ls m)
                   (Linear.Returnstate ts ls m).

Definition measure (S: LTL.state) : nat :=
  match S with
  | LTL.State s f sp pc ls m => 0%nat
  | LTL.Block s f sp bb ls m => 1%nat
  | _ => 0%nat
  end.

Remark match_parent_locset:
  forall s ts, list_forall2 match_stackframes s ts -> parent_locset ts = LTL.parent_locset s.
Proof.
  induction 1; simpl. auto. inv H; auto.
Qed.

Theorem transf_step_correct:
  forall s1 t s2, LTL.step fn_stack_requirements ge s1 t s2 ->
  forall s1' (MS: match_states s1 s1'),
  (exists s2', plus (Linear.step fn_stack_requirements) tge s1' t s2' /\ match_states s2 s2')
  \/ (measure s2 < measure s1 /\ t = E0 /\ match_states s2 s1')%nat.
Proof.
  induction 1; intros; try (inv MS).

  (* start of block, at an [add_branch] *)
  exploit find_label_lin; eauto. intros [k F].
  left; econstructor; split.
  eapply add_branch_correct; eauto.
  econstructor; eauto.
  intros; eapply reachable_successors; eauto.
  eapply is_tail_lin_block; eauto. eapply is_tail_find_label; eauto.

  (* start of block, target of an [Lcond] *)
  exploit find_label_lin; eauto. intros [k F].
  left; econstructor; split.
  apply plus_one. eapply exec_Lcond_true; eauto.
  econstructor; eauto.
  intros; eapply reachable_successors; eauto.
  eapply is_tail_lin_block; eauto. eapply is_tail_find_label; eauto.

  (* start of block, target of an [Ljumptable] *)
  exploit find_label_lin; eauto. intros [k F].
  left; econstructor; split.
  apply plus_one. eapply exec_Ljumptable; eauto.
  econstructor; eauto.
  intros; eapply reachable_successors; eauto.
  eapply is_tail_lin_block; eauto. eapply is_tail_find_label; eauto.

  (* Lop *)
  left; econstructor; split. simpl.
  apply plus_one. econstructor; eauto.
  instantiate (1 := v); rewrite <- H; apply eval_operation_preserved.
  exact symbols_preserved.
  econstructor; eauto.

  (* Lload *)
  left; econstructor; split. simpl.
  apply plus_one. econstructor.
  instantiate (1 := a). rewrite <- H; apply eval_addressing_preserved.
  exact symbols_preserved. eauto. eauto.
  econstructor; eauto.

  (* Lgetstack *)
  left; econstructor; split. simpl.
  apply plus_one. econstructor; eauto.
  econstructor; eauto.

  (* Lsetstack *)
  left; econstructor; split. simpl.
  apply plus_one. econstructor; eauto.
  econstructor; eauto.

  (* Lstore *)
  left; econstructor; split. simpl.
  apply plus_one. econstructor.
  instantiate (1 := a). rewrite <- H; apply eval_addressing_preserved.
  exact symbols_preserved. eauto. eauto.
  econstructor; eauto.

  (* Lcall *)
  exploit find_function_translated; eauto. intros [tfd [A B]].
  left; econstructor; split. simpl.
  apply plus_one. econstructor; eauto.
  symmetry; eapply sig_preserved; eauto.
  econstructor; eauto. constructor; auto. econstructor; eauto.

  (* Ltailcall *)
  exploit find_function_translated; eauto. intros [tfd [A B]].
  left; econstructor; split. simpl.
  apply plus_one. econstructor; eauto.
  destruct ros; simpl in *; eauto.
  rewrite (match_parent_locset _ _ STACKS). eauto.
  rewrite (match_parent_locset _ _ STACKS). eauto.
  symmetry; eapply sig_preserved; eauto.
  rewrite (stacksize_preserved _ _ TRF); eauto.
  rewrite (match_parent_locset _ _ STACKS).
  econstructor; eauto.

  (* Lbuiltin *)
  left; econstructor; split. simpl.
  apply plus_one. eapply exec_Lbuiltin; eauto.
  eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
  eapply external_call_symbols_preserved; eauto. apply senv_preserved.
  econstructor; eauto.

  (* Lbranch *)
  assert ((reachable f)!!pc = true). apply REACH; simpl; auto.
  right; split. simpl; lia. split. auto. simpl. econstructor; eauto.

  (* Lcond *)
  assert (REACH1: (reachable f)!!pc1 = true) by (apply REACH; simpl; auto).
  assert (REACH2: (reachable f)!!pc2 = true) by (apply REACH; simpl; auto).
  simpl linearize_block.
  destruct (starts_with pc1 c).
  (* branch if cond is false *)
  assert (DC: destroyed_by_cond (negate_condition cond) = destroyed_by_cond cond).
    destruct cond; reflexivity.
  destruct b.
  (* cond is true: no branch *)
  left; econstructor; split.
  apply plus_one. eapply exec_Lcond_false.
  rewrite eval_negate_condition. rewrite H. auto. eauto.
  rewrite DC. econstructor; eauto.
  (* cond is false: branch is taken *)
  right; split. simpl; lia. split. auto.  rewrite <- DC. econstructor; eauto.
  rewrite eval_negate_condition. rewrite H. auto.
  (* branch if cond is true *)
  destruct b.
  (* cond is true: branch is taken *)
  right; split. simpl; lia. split. auto. econstructor; eauto.
  (* cond is false: no branch *)
  left; econstructor; split.
  apply plus_one. eapply exec_Lcond_false. eauto. eauto.
  econstructor; eauto.

  (* Ljumptable *)
  assert (REACH': (reachable f)!!pc = true).
    apply REACH. simpl. eapply list_nth_z_in; eauto.
  right; split. simpl; lia. split. auto. econstructor; eauto.

  (* Lreturn *)
  left; econstructor; split.
  simpl. apply plus_one. econstructor; eauto.
  rewrite (stacksize_preserved _ _ TRF). eauto.
  rewrite (match_parent_locset _ _ STACKS). econstructor; eauto.

  (* internal functions *)
  assert (REACH: (reachable f)!!(LTL.fn_entrypoint f) = true).
    apply reachable_entrypoint.
  monadInv H10.
  left; econstructor; split.
  apply plus_one. eapply exec_function_internal; eauto.
  rewrite (stacksize_preserved _ _ EQ). eauto.
  generalize EQ; intro EQ'; monadInv EQ'. simpl.
  econstructor; eauto. simpl. eapply is_tail_add_branch. constructor.

  (* external function *)
  monadInv H9. left; econstructor; split.
  apply plus_one. eapply exec_function_external; eauto.
  eapply external_call_symbols_preserved; eauto. apply senv_preserved.
  econstructor; eauto.

  (* return *)
  inv H3. inv H1.
  left; econstructor; split.
  apply plus_one. econstructor.
  econstructor; eauto.
Qed.

Lemma transf_initial_states:
  forall st1, LTL.initial_state prog st1 ->
  exists st2, Linear.initial_state tprog st2 /\ match_states st1 st2.
Proof.
  intros. inversion H.
  exploit function_ptr_translated; eauto. intros [tf [A B]].
  exists (Callstate nil tf (Locmap.init Vundef) m1 (prog_main tprog)); split.
  econstructor; eauto. eapply (Genv.init_mem_transf_partial TRANSF); eauto.
  rewrite (match_program_main TRANSF).
  rewrite symbols_preserved. eauto.
  rewrite <- H3. apply sig_preserved. auto.
  rewrite (match_program_main TRANSF).
  constructor. constructor. auto.
Qed.

Lemma transf_final_states:
  forall st1 st2 r,
  match_states st1 st2 -> LTL.final_state st1 r -> Linear.final_state st2 r.
Proof.
  intros. inv H0. inv H. inv H5. econstructor; eauto.
Qed.

Theorem transf_program_correct:
  forward_simulation (LTL.semantics fn_stack_requirements prog)
                     (Linear.semantics fn_stack_requirements tprog).
Proof.
  eapply forward_simulation_star.
  apply senv_preserved.
  eexact transf_initial_states.
  eexact transf_final_states.
  eexact transf_step_correct.
Qed.

End LINEARIZATION.