(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto.
Require Import VST.progs64.union.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Import Memdata.

Definition Gprog : funspecs := nil.

Definition g_spec :=
 DECLARE _g
 WITH i: Z
 PRE [ size_t]
   PROP() PARAMS(Vptrofs (Ptrofs.repr i)) SEP()
 POST [ size_t ]
   PROP() RETURN (Vptrofs (Ptrofs.repr i)) SEP().

Lemma body_g: semax_body Vprog Gprog f_g g_spec.
Proof.
start_function.
forward.
forward.
forward.
cancel.
Qed.

Definition unconst_spec :=
 DECLARE _unconst
 WITH p: val
 PRE [ tptr tschar ]
   PROP() PARAMS(p) SEP()
 POST [ tptr tschar ]
   PROP() RETURN (p) SEP().

Lemma unconst_aux:
  forall (x: val) v,
      data_at Tsh (Tunion _const_or_not noattr) (inl x) v =
      data_at Tsh (Tunion _const_or_not noattr) (inr x) v.
Proof. reflexivity. Qed.

Lemma body_unconst: semax_body Vprog Gprog f_unconst unconst_spec.
Proof.
start_function.
forward.
rewrite unconst_aux.
forward.
forward.
cancel.
Qed.

Lemma decode_float32_int32:
  forall (bl: list memval) (x: float32),
 size_chunk Mfloat32 = Z.of_nat (Datatypes.length bl) ->
 decode_val Mfloat32 bl = Vsingle x ->
 decode_val Mint32 bl = Vint (Float32.to_bits x).
Proof.
intros.
unfold decode_val,decode_int,rev_if_be in *.
destruct (proj_bytes bl) eqn:?H.
inv H0.
rewrite Float32.to_of_bits. auto.
inv H0.
Qed.

Lemma NOT_decode_int32_float32:
  Archi.ptr64=false ->
 ~ (forall (bl: list memval) (x: float32),
     size_chunk Mfloat32 = Z.of_nat (Datatypes.length bl) ->
     decode_val Mint32 bl = Vint (Float32.to_bits x) ->
     decode_val Mfloat32 bl = Vsingle x).
(* This lemma illustrates a problem: it is NOT the case that
   if (bl: list memval) decodes to Vint (Float32.to_bits x)
  then it also decodes to  Vsingle x.
  See https://github.com/AbsInt/CompCert/issues/207  for a description
  of the problem; and see https://github.com/PrincetonUniversity/VST/issues/429
  for a description of the solution,  forward_store_union_hack  *)
Proof.
intro Hp.
intro.
set (x := Float32.zero). (* nothing special about zero, any value would do *)
set (i := Float32.to_bits x).
set (bl := [Fragment (Vint i) Q32 3; Fragment (Vint i) Q32 2; Fragment (Vint i) Q32 1; Fragment (Vint i) Q32 0]).
specialize (H bl x).
specialize (H (eq_refl _)).
assert (decode_val Mint32 bl = Vint (Float32.to_bits x)).
unfold decode_val, bl.
rewrite Hp.
simpl.
destruct (Val.eq (Vint i) (Vint i)); [ | congruence].
destruct (quantity_eq Q32 Q32); [ | congruence].
simpl.
reflexivity.
specialize (H H0).
clear - H. subst bl i.
unfold decode_val in H.
simpl in H. inversion H.
Qed.

Module FABS_STUFF.

Lemma shift_pos_succ:
  forall k j, (shift_pos (Pos.succ k) j = (shift_pos k j)~0)%positive.
Proof.
intros.
change ((shift_pos k j)~0)%positive
with (2 * (shift_pos k j))%positive.
apply Pos2Z.inj.
rewrite Pos2Z.inj_mul.
rewrite !shift_pos_correct.
rewrite Z.mul_assoc.
f_equal.
rewrite <- !two_power_pos_correct.
rewrite <- Pos.add_1_l.
rewrite two_power_pos_is_exp.
reflexivity.
Qed.

Lemma nan_pl_range:
 forall k p, Binary.nan_pl k p = true ->
 Z.pos p < 2 ^ (k-1).
Proof.
intros.
unfold Binary.nan_pl in H.
apply Z.ltb_lt in H.
revert k H; induction p; simpl; intros.
-
rewrite Pos2Z.inj_succ in H.
specialize (IHp (k-1)).
spec IHp; [lia | ].
replace (2^(k-1)) with (2^1 * 2^(k-1-1)).
2:{ rewrite <- Z.pow_add_r by lia. f_equal. lia. }
rewrite Pos2Z.inj_xI.
lia.
-
rewrite Pos2Z.inj_succ in H.
specialize (IHp (k-1)).
spec IHp; [lia | ].
replace (2^(k-1)) with (2^1 * 2^(k-1-1)).
2:{ rewrite <- Z.pow_add_r by lia. f_equal. lia. }
rewrite Pos2Z.inj_xO.
lia.
-
replace (2^(k-1)) with (2^1 * 2^(k-1-1)).
2:{ rewrite <- Z.pow_add_r by lia. f_equal. lia. }
change (2^1) with 2.
assert (0 < 2 ^ (k-1-1)).
apply Z.pow_pos_nonneg; lia.
lia.
Qed.

Definition abs_nan (any_nan: {x : Bits.binary32 | Binary.is_nan 24 128 x = true}) (f: Binary.binary_float 24 128)   :=
match f with
| @Binary.B754_nan _ _ _ p H =>
    exist (fun x : Binary.binary_float 24 128 => Binary.is_nan 24 128 x = true)
      (Binary.B754_nan 24 128 false p H) eq_refl
| _ => any_nan
end.

Lemma bounded_mantissa:
  forall prec emax m e, Binary.bounded prec emax m e = true ->
    Z.pos m < 2 ^ prec.
Proof.
intros.
unfold Binary.bounded in H.
rewrite andb_true_iff in H.
destruct H as [H H0].
apply Z.leb_le in H0.
unfold Binary.canonical_mantissa in H.
apply Zeq_bool_eq in H.
unfold FLT.FLT_exp in H.
rewrite Digits.Zpos_digits2_pos in H.
pose proof (Z.max_lub_l (Digits.Zdigits Zaux.radix2 (Z.pos m) + e - prec)
      (3 - emax - prec) e).
spec H1; [ lia | ].
clear H.
assert (Digits.Zdigits Zaux.radix2 (Z.pos m) <= prec) by lia.
clear - H.
apply Digits.Zpower_gt_Zdigits in H.
apply H.
Qed.

Lemma binary32_abs_lemma:
 forall (x : Bits.binary32)
      (any_nan : {x : Bits.binary32 | Binary.is_nan 24 128 x = true}),
  Bits.b32_of_bits (Bits.bits_of_b32 x mod 2 ^ 31) =
  Binary.Babs 24 128 (abs_nan any_nan) x.
Proof.
intros.
destruct x.
- (* B754_zero *)
destruct s; reflexivity.
- (* B754_infinity *)
destruct s; reflexivity.
- (* B754_nan *)
assert (Hpl := nan_pl_range _ _ e).
unfold Bits.b32_of_bits, Binary.Babs, Bits.bits_of_b32, Bits.bits_of_binary_float.
assert (Bits.join_bits 23 8 s (Z.pos pl) (2 ^ 8 - 1) mod 2 ^ 31 =
            Bits.join_bits 23 8 false (Z.pos pl) (2 ^ 8 - 1)).  {
 unfold Bits.join_bits.
rewrite !Z.shiftl_mul_pow2 by computable.
rewrite Z.add_0_l.
rewrite Z.mul_add_distr_r.
rewrite <- Z.add_assoc.
rewrite Z.add_mod by (compute; lia).
replace (((if s then 2 ^ 8 else 0) * 2 ^ 23) mod 2 ^ 31) with 0
  by (destruct s; reflexivity).
rewrite Z.add_0_l.
rewrite Z.mod_mod by lia.
apply Z.mod_small.
lia.
}
rewrite H; clear H.
transitivity (Binary.B754_nan 24 128 false pl e); [ | reflexivity].
clear.
replace (Bits.join_bits 23 8 false (Z.pos pl) (2 ^ 8 - 1))
   with (Bits.bits_of_binary_float 23 8 (Binary.B754_nan 24 128 false pl e)).
apply (Bits.binary_float_of_bits_of_binary_float 23 8 eq_refl eq_refl eq_refl).
reflexivity.
- (* B754_finite *)
unfold Binary.Babs.
clear.
unfold Bits.b32_of_bits, Binary.Babs, Bits.bits_of_b32, Bits.bits_of_binary_float.
pose proof (bounded_mantissa _ _ _ _ e0).
destruct (0 <=? Z.pos m - 2 ^ 23) eqn:?H.
+
apply Z.leb_le in H0.
assert (Z.pos m - 2^23 < 2^23) by lia.
replace (Bits.join_bits 23 8 s (Z.pos m - 2 ^ 23)
                 (e - (3 - 2 ^ (8 - 1) - (23 + 1)) + 1) mod  2 ^ 31)
   with (Bits.bits_of_binary_float 23 8 (Binary.B754_finite 24 128 false m e e0)).
apply (Bits.binary_float_of_bits_of_binary_float 23 8 eq_refl eq_refl eq_refl).
unfold Bits.bits_of_binary_float.
pose proof H0.
apply Z.leb_le in H2. rewrite H2. clear H2.
forget (Z.pos m - 2^23)  as i.
unfold Binary.bounded in e0.
rewrite andb_true_iff in e0.
destruct e0 as [H' ?H].
assert (-149 <= e). {
 clear - H'.
 unfold Binary.canonical_mantissa in H'.
apply Zeq_bool_eq in H'.
unfold FLT.FLT_exp in H'.
rewrite Digits.Zpos_digits2_pos in H'.
pose proof (Z.max_lub_r (Digits.Zdigits Zaux.radix2 (Z.pos m) + e - 24)
      (3 - 128 - 24) e).
spec H; lia.
}
clear H'.
apply Z.leb_le in H2.
simpl Z.sub.
replace (e - -149 + 1) with (e+150) by lia.
unfold Bits.join_bits.
rewrite !Z.shiftl_mul_pow2 by lia.
rewrite Z.add_0_l.
set (e' := e+150).
rewrite Z.mul_add_distr_r.
rewrite <- Z.add_assoc.
rewrite Z.add_mod by (compute; lia).
replace (((if s then 2 ^ 8 else 0) * 2 ^ 23) mod 2 ^ 31)
  with 0 by (destruct s; reflexivity).
rewrite Z.add_0_l.
rewrite Z.mod_mod by lia.
rewrite (Z.mod_small); auto.
subst e'.
lia.
+
replace (Bits.join_bits 23 8 s (Z.pos m) 0 mod 2 ^ 31)
 with (Bits.join_bits 23 8 false (Z.pos m) 0).
replace (Bits.join_bits 23 8 false (Z.pos m) 0)
   with (Bits.bits_of_binary_float 23 8 (Binary.B754_finite 24 128 false m e e0)).
apply (Bits.binary_float_of_bits_of_binary_float 23 8 eq_refl eq_refl eq_refl).
unfold Bits.bits_of_binary_float.
rewrite H0. auto.
clear H0.
unfold Bits.join_bits.
rewrite Z.add_mod by (compute; lia).
rewrite (Z.mod_small (Z.pos m)) by lia.
rewrite !Z.add_0_r.
replace (Z.shiftl (if s then 2 ^ 8 else 0) 23 mod 2 ^ 31) with 0 by (destruct s; reflexivity).
simpl Z.shiftl.
symmetry.
apply Z.mod_small.
lia.
Qed.

Lemma fabs_float32_lemma:
  forall x: float32,
  Float32.of_bits (Int.and (Float32.to_bits x) (Int.repr 2147483647)) =
  Float32.abs x.
Proof.
intros.
Transparent Float32.of_bits.
Transparent Float32.to_bits.
Transparent Float32.abs.
unfold Float32.of_bits, Float32.to_bits, Float32.abs.
Opaque Float32.of_bits.
Opaque Float32.to_bits.
Opaque Float32.abs.
rewrite and_repr.
change 2147483647 with (Z.ones 31).
rewrite Z.land_ones by computable.
rewrite Int.unsigned_repr
 by (pose proof (Z_mod_lt (Bits.bits_of_b32 x) (2 ^ 31) (eq_refl _)); rep_lia).
apply binary32_abs_lemma.
Qed.

End FABS_STUFF.

Module Single.

Definition fabs_single_spec :=
 DECLARE _fabs_single
 WITH x: float32
 PRE [ Tfloat F32 noattr]
   PROP() PARAMS (Vsingle x) SEP()
 POST [ Tfloat F32 noattr ]
   PROP() RETURN (Vsingle (Float32.abs x)) SEP().

Lemma body_fabs_single: semax_body Vprog Gprog f_fabs_single fabs_single_spec.
Proof.
start_function.
forward.
forward.
forward.
forward.
forward.
entailer!.
f_equal.
apply FABS_STUFF.fabs_float32_lemma.
Qed.
End Single.

Module Float.

 (* This experiment shows what kind of error message you get
   if you put the wrong LOCAL precondition.
   In fact, Vfloat x is wrong, leading to an unsatisfying precondition,
   it must be Vsingle. *)

Definition fabs_single_spec :=
 DECLARE _fabs_single
 WITH x: float
 PRE [ Tfloat F32 noattr]
   PROP() PARAMS (Vfloat x) SEP()
 POST [ Tfloat F32 noattr ]
   PROP() RETURN (Vfloat (Float.abs x)) SEP().

Lemma body_fabs_single: semax_body Vprog Gprog f_fabs_single fabs_single_spec.
Proof.
try (start_function; fail 99).
Abort.

End Float.


Require Import Coq.Lists.List.
Import ListNotations.

Require Import Tactics.
Require Import Sequence.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Promote.
Require Import Hygiene.
Require Import Rules.
Require Import DerivedRules.
Require Defs.
Require Import Obligations.
Require Import Morphism.
Require Import DefsEquiv.
Require Import Equivalence.

Require Import ValidationUtil.

Lemma futureKind_valid : futureKind_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G i k triv0 triv1 H0 H1.
  valid_rewrite.
  constructor.
  apply tr_fut_kind_formation; eauto using deq_intro.
  Qed.

Lemma futureKindEq_valid : futureKindEq_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G i k l triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  apply tr_fut_kind_formation; eauto using deq_intro; eauto using deq.
Qed.

Lemma futureForm_valid : futureForm_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a triv0 H.
  valid_rewrite.
  constructor; eauto using deqtype_intro.
  Qed.

Lemma futureEq_valid : futureEq_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b triv0 H.
  valid_rewrite.
  constructor; eauto using deqtype_intro.
  Qed.

Lemma futureFormUniv_valid : futureFormUniv_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a i triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  eapply tr_fut_formation_univ; eauto using deq_intro.
  Qed.

Lemma futureEqUniv_valid : futureEqUniv_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b i triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  eapply tr_fut_formation_univ; eauto using deq_intro.
  Qed.

Lemma futureIntroOf_valid : futureIntroOf_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G  a m triv0 H.
  valid_rewrite.
  constructor.
  eapply tr_fut_intro; eauto using deq_intro.
Qed.

Lemma futureIntroEq_valid : futureIntroEq_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G  a m triv0 H.
  valid_rewrite.
  constructor.
  eapply tr_fut_intro; eauto using deq_intro.
Qed.

Lemma futureIntro_valid : futureIntro_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a m H.
  valid_rewrite.
  eapply tr_fut_intro; eauto using deq_intro.
Qed.

Lemma futureElimOf_valid : futureElimOf_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b m p triv0 triv1 triv2 H0 H1 H2.
  valid_rewrite.
  constructor.
  eapply tr_fut_elim; eauto using deq_intro; eauto using deqtype_intro.
Qed.

Lemma futureElimEq_valid : futureElimEq_obligation.
 unfoldtop. autounfold with valid_hint.
  intros G a b m n p q triv0 triv1 triv2 H0 H1 H2.
  valid_rewrite.
  constructor.
  eapply tr_fut_elim; eauto using deq_intro; eauto using deqtype_intro.
Qed.

Lemma futureElimIstype_valid : futureElimIstype_obligation.
 unfoldtop. autounfold with valid_hint.
  intros G a b m triv0 triv1 triv2 H0 H1 H2.
  valid_rewrite.
  eapply tr_fut_elim_eqtype; eauto using deq_intro; eauto using deqtype_intro.
Qed.

Lemma futureElimEqtype_valid : futureElimEqtype_obligation.
 unfoldtop. autounfold with valid_hint.
  intros G a b c m n triv0 triv1 triv2 H0 H1 H2.
  valid_rewrite.
  eapply tr_fut_elim_eqtype; eauto using deq_intro; eauto using deqtype_intro.
Qed.

Lemma futureEta_valid : futureEta_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a m triv0 H.
  valid_rewrite.
  constructor.
  eapply tr_fut_eta; eauto using deq_intro.
Qed.

Lemma futureLeft_valid : futureLeft_obligation.
 unfoldtop. autounfold with valid_hint.
  intros G1 G2 a b triv0 m H0 H1.
  valid_rewrite.
  match goal with |- tr ?G ?J =>
                  assert (equivctx G
    (G2 ++
     hyp_tm (fut a) :: G1)
                         ) as Hctx end.

  { apply equivctx_refl. }
  apply tr_fut_eta_hyp; auto.
  eauto using deqtype_intro.
Qed.

Lemma tr_future_sub :
  forall G a b,
    tr (promote G) (dsubtype a b)
    -> tr G (dsubtype (fut a) (fut b)).
Proof.
intros G a b Ha.
apply tr_subtype_intro.
  {
  apply tr_fut_formation.
  eapply tr_subtype_istype1; eauto.
  }

  {
  apply tr_fut_formation.
  eapply tr_subtype_istype2; eauto.
  }
simpsub.
apply (tr_fut_ext _ _ (subst sh1 a) (subst sh1 a)).
  {
  eapply hypothesis; eauto using index_0.
  }

  {
  eapply hypothesis; eauto using index_0.
  }
replace (next (prev (var 0))) with (@subst1 obj (prev (var 0)) (next (var 0))).
2:{
  simpsub.
  auto.
  }
replace (fut (subst sh1 b)) with (subst1 (prev (var 0)) (fut (subst (sh 2) b))).
2:{
  simpsub.
  auto.
  }
apply (tr_fut_elim _ (var 0) (var 0) (subst sh1 a) (next (var 0)) (next (var 0)) (fut (subst (sh 2) b))).
  {
  eapply hypothesis; eauto using index_0.
  }

  {
  cbn.
  fold (promote G).
  eapply (weakening _ [_] []).
    {
    cbn [length Dots.unlift].
    simpsub.
    auto.
    }

    {
    cbn [length Dots.unlift].
    simpsub.
    auto.
    }
  cbn [length Dots.unlift].
  simpsub.
  cbn [List.app].
  eapply tr_subtype_istype1; eauto.
  }
apply tr_fut_intro.
cbn.
fold (promote G).
eapply (weakening _ [_] [_]).
  {
  cbn [length Dots.unlift].
  simpsub.
  auto.
  }

  {
  cbn [length Dots.unlift].
  simpsub.
  auto.
  }
cbn [length Dots.unlift].
simpsub.
cbn [List.app].
apply (tr_subtype_elim _ (subst sh1 a)).
  {
  eapply (weakening _ [_] []).
    {
    cbn [length Dots.unlift].
    simpsub.
    auto.
    }

    {
    cbn [length Dots.unlift].
    simpsub.
    auto.
    }
  cbn [length Dots.unlift].
  simpsub.
  cbn [List.app].
  exact Ha.
  }

  {
  eapply hypothesis; eauto using index_0.
  }
Qed.

Hint Rewrite def_fut def_letnext : prepare.

Lemma futureSub_valid : futureSub_obligation.
Proof.
prepare.
intros G a b ext0 H.
apply tr_future_sub; auto.
Qed.

Lemma futureElimOfLetnext_valid : futureElimOfLetnext_obligation.
Proof.
prepare.
intros G a b m p ext2 ext1 ext0 Ha Hm Hp.
eapply tr_fut_elim; eauto.
Qed.

Lemma futureElimOfLetnextNondep_valid : futureElimOfLetnextNondep_obligation.
Proof.
prepare.
intros G a b m p ext2 ext1 ext0 Ha Hm Hp.
replace b with (subst1 (prev m) (subst sh1 b)) by (simpsub; reflexivity).
eapply tr_fut_elim; eauto.
Qed.

Lemma futureElimIstypeLetnext_valid : futureElimIstypeLetnext_obligation.
Proof.
prepare.
intros G a b m ext2 ext1 ext0 Ha Hm Hb.
eapply tr_fut_elim_eqtype; eauto.
Qed.

Lemma futureExt_valid : futureExt_obligation.
Proof.
prepare.
intros G a m n ext2 ext1 ext0 Hm Hn Hmn.
eapply tr_fut_ext; eauto.
apply tr_fut_intro; auto.
Qed.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Maps.
Require Import compcert.lib.Integers.

Require Import compcert.common.AST.
Require Import compcert.common.Values.
Require Import compcert.common.Globalenvs.
Require Import compcert.common.Memory.
Require Import compcert.common.Events.
Require Import compcert.common.Errors.
Require Import compcert.common.Switch.
Require Import compcert.common.Smallstep.

Require Import List.
Import ListNotations.
Require Import Arith.
Require Import Ring.

Require Import StructTact.StructTactics.
Require Import StructTact.Util.

Require Import oeuf.Metadata.
Require Import oeuf.OpaqueTypes.
Require Import oeuf.MemInjProps.

Require Import oeuf.EricTact.
Require Import oeuf.StuartTact.

(* Computation will be over higher level values, i.e. Constr and Close *)
(* We will need a way to relate those to lower level values *)
(* That relation will have type hval -> rval -> mem -> Prop *)
(* since high level values will have to live in memory *)

Definition function_name := ident.

Inductive value :=
| Constr (tag : int) (args : list value) (* A constructor applied to some values *)
(* At this level we have a Z tag  *)
(* corresponds with lower level switch semantics nicely *)
| Close (f : function_name) (free : list value) (* a closure value *)
(* free is the list of values closed over, referred to inside as upvars *)
| Opaque (ty : opaque_type_name) (v : opaque_type_denote ty)
.

(* Thanks Stuart *)
Definition value_rect_mut (P : value -> Type) (Pl : list value -> Type)
           (HConstr : forall tag args, Pl args -> P (Constr tag args))
           (HClose : forall fname args, Pl args -> P (Close fname args))
           (HOpaque :  forall ty v, P (Opaque ty v))
    (Hnil :     Pl [])
    (Hcons :    forall e es, P e -> Pl es -> Pl (e :: es))
    (v : value) : P v :=
    let fix go v :=
        let fix go_list vs :=
            match vs as vs_ return Pl vs_ with
            | [] => Hnil
            | v :: vs => Hcons v vs (go v) (go_list vs)
            end in
        match v as v_ return P v_ with
        | Constr tag args => HConstr tag args (go_list args)
        | Close f args => HClose f args (go_list args)
        | Opaque ty v => HOpaque ty v
        end in go v.

Definition value_rect_mut'
        (P : value -> Type)
        (Pl : list value -> Type)
    (HConstr :  forall tag args, Pl args -> P (Constr tag args))
    (HClose :   forall fname free, Pl free -> P (Close fname free))
    (HOpaque :  forall ty v, P (Opaque ty v))
    (Hnil :     Pl [])
    (Hcons :    forall v vs, P v -> Pl vs -> Pl (v :: vs)) :
    (forall v, P v) * (forall vs, Pl vs) :=
    let fix go v :=
        let fix go_list vs :=
            match vs as vs_ return Pl vs_ with
            | [] => Hnil
            | v :: vs => Hcons v vs (go v) (go_list vs)
            end in
        match v as v_ return P v_ with
        | Constr tag args => HConstr tag args (go_list args)
        | Close fname free => HClose fname free (go_list free)
        | Opaque ty v => HOpaque ty v
        end in
    let fix go_list vs :=
        match vs as vs_ return Pl vs_ with
        | [] => Hnil
        | v :: vs => Hcons v vs (go v) (go_list vs)
        end in
    (go, go_list).

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition value_ind' (P : value -> Prop)
           (HConstr : forall tag args, Forall P args -> P (Constr tag args))
           (HClose : forall fname args, Forall P args -> P (Close fname args))
           (HOpaque :  forall ty v, P (Opaque ty v))
    (v : value) : P v :=
    ltac:(refine (@value_rect_mut P (Forall P)
        HConstr HClose HOpaque _ _ v); eauto).

(* given an address, addresses of the nested values *)
Fixpoint arg_addrs (b : block) (ofs : int) (l : list value) : list (value * val) :=
  match l with
  | nil => nil
  | v :: vs =>
    let ofs' := Int.add ofs (Int.repr 4) in
    (v, Vptr b ofs) :: arg_addrs b ofs' vs
  end.

Fixpoint load_all (l : list (value * val)) (m : mem) : option (list (value * val)) :=
  match l with
  | nil => Some nil
  | (hval,vaddr) :: rest =>
    match Mem.loadv Mint32 m vaddr with
    | None => None
    | Some v' =>
      match load_all rest m with
      | None => None
      | Some res => Some ((hval,v') :: res)
      end
    end
  end.

(* mapping of high level values to low level values *)
(* everything is one pointer *)
Inductive value_inject {A B} (ge : Genv.t A B) (m : mem) : value -> val -> Prop :=
| inj_constr :
    (* a constructor is a pointer to the correct tag *)
    (* and every value following that in memory is a value for that constructor *)
    (* *(b,ofs) = tag *)
    (* *(b,ofs+4) = pointer to first field *)
    forall b ofs n values l',
      Mem.loadv Mint32 m (Vptr b ofs) = Some (Vint n) -> (* correct tag *)
      load_all (arg_addrs b (Int.add ofs (Int.repr 4)) values) m = Some l' -> (* one more deref for args *)
      (forall a b, In (a,b) l' -> value_inject ge m a b) -> (* all args inject *)
      value_inject ge m (Constr n values) (Vptr b ofs)
| inj_closure :
    forall b ofs bcode f fname values l',
      Mem.loadv Mint32 m (Vptr b ofs) = Some (Vptr bcode Int.zero) ->
      Genv.find_funct_ptr ge bcode = Some f -> (* legit pointer to some code *)
      Genv.find_symbol ge fname = Some bcode -> (* name we have points to same code *)
      load_all (arg_addrs b (Int.add ofs (Int.repr 4)) values) m = Some l' -> (* one more deref for args *)
      (forall a b, In (a,b) l' -> value_inject ge m a b) -> (* all args inject *)
      value_inject ge m (Close fname values) (Vptr b ofs)
| inj_opaque : forall oty ov cv,
        opaque_type_value_inject oty ov cv m ->
        value_inject ge m (Opaque oty ov) cv
.

Lemma load_all_inject :
    forall l b ofs k args b' mi m m',
      load_all (arg_addrs b (Int.add ofs k) args) m = Some l ->
      Mem.inject mi m m' ->
      mi b = Some (b',0) ->
      exists l',
        load_all (arg_addrs b' (Int.add ofs k) args) m' = Some l' /\ list_forall2 (fun x y => fst x = fst y /\ Val.inject mi (snd x) (snd y)) l l'.
Proof.
  induction l; intros.
  destruct args; simpl in H; inv H. simpl.
  exists nil. split; eauto. econstructor; eauto.
  repeat (break_match_hyp; try congruence).
  destruct args. simpl in H. inv H.
  simpl in H. repeat (break_match_hyp; try congruence).
  invc H.
  simpl. app Mem.load_inject Mem.load. rewrite Z.add_0_r in *.
  collapse_match.
  eapply IHl in Heqo0; eauto.
  break_exists; break_and.
  collapse_match.
  eexists; split; eauto.
  econstructor; eauto.
Qed.

Lemma list_forall2_in_backwards :
  forall {A B : Type} (P : A -> B -> Prop) l l',
    list_forall2 P l l' ->
    forall elem',
      In elem' l' ->
      exists elem,
        In elem l /\ P elem elem'.
Proof.
  induction 1; intros.
  simpl in H. inv H.
  simpl in H1. destruct H1. subst b1. eexists; split; eauto. simpl. left. reflexivity.
  simpl. apply IHlist_forall2 in H1. break_exists. break_and.
  eexists; split; eauto; right; eauto.
Qed.

Lemma load_all_hval_in :
  forall args l b ofs m,
    load_all (arg_addrs b ofs args) m = Some l ->
    forall a x,
      In (a,x) l ->
      In a args.
Proof.
  induction args; intros.
  simpl in H. inv H. simpl in H0. inv H0.
  simpl in H. repeat break_match_hyp; try congruence.
  inv H. simpl in H0. destruct H0. inv H0.
  simpl; left; reflexivity.
  simpl; right; eauto.
Qed.

Lemma value_val_inject :
  forall {F} (ge : Genv.t F unit) m v v',
    value_inject ge m v v' ->
    forall mi m' v0,
      Val.inject mi v' v0 ->
      Mem.inject mi m m' ->
      same_offsets mi ->
      globals_inj_same ge mi ->
      value_inject ge m' v v0.
Proof.
  induction v using value_ind'; intros; cycle 2.

  { on >@value_inject, invc. fix_existT.  subst. econstructor.
    on >Mem.inject, invc.  eapply opaque_type_value_val_inject; eauto. }

  all: try solve [inv H]; (* handle opaque *)
    inv H0; inv H1;
      app Mem.loadv_inject Mem.loadv;
      inv H7; app H3 (mi b); subst delta;
        app load_all_inject load_all; repeat break_and;
          econstructor; eauto; repeat rewrite Int.add_zero in *; try eassumption.

  Focus 2.
  rewrite Int.add_commut in *.
  repeat rewrite Int.add_zero in *.
  unfold same_offsets in *.
  app H3 (mi bcode). subst delta0.
  erewrite H4 in H16; eauto. inv H16. assumption.

  intros.
  eapply list_forall2_in_backwards in H12; eauto.
  break_exists. repeat break_and. destruct x0. simpl in H14. subst.
  eapply H10 in H12.
  rewrite Forall_forall in H. simpl in H15. eapply H; eauto.
  eapply load_all_hval_in; eauto.

  intros.
  eapply list_forall2_in_backwards in H14; eauto.
  break_exists. repeat break_and. destruct x0. simpl in H17. subst.
  eapply H12 in H14.
  rewrite Forall_forall in H. simpl in H18. eapply H; eauto.
  eapply load_all_hval_in; eauto.

  Grab Existential Variables.
  repeat (econstructor; eauto).
Qed.

Lemma value_inject_swap_ge :
  forall {F F' V} (ge1 : Genv.t F V) (ge2 : Genv.t F' V),
    forall m v v',
      value_inject ge1 m v v' ->
    (forall b f,
        Genv.find_funct_ptr ge1 b = Some f ->
        exists f',
          Genv.find_funct_ptr ge2 b = Some f') ->
    (forall fname b,
        Genv.find_symbol ge1 fname = Some b ->
        Genv.find_symbol ge2 fname = Some b) ->
      value_inject ge2 m v v'.
Proof.
  induction 1; intros.
  econstructor; eauto.
  eapply H5 in H0.
  break_exists.
  econstructor; eauto.
  econstructor; eauto.
Qed.

Definition global_blocks_valid {A B : Type} (ge : Genv.t A B) (b : block) :=
  Plt (Genv.genv_next ge) b.

Lemma global_block_find_symbol :
  forall {A B} (ge : Genv.t A B) id b m,
    Genv.find_symbol ge id = Some b ->
    global_blocks_valid ge (Mem.nextblock m) ->
    Plt b (Mem.nextblock m).
Proof.
  intros.
  unfold global_blocks_valid in *.
  unfold Genv.find_symbol in H.
  eapply Genv.genv_symb_range in H.
  eapply Plt_trans; eauto.
Qed.

Lemma genv_next_ind :
  forall {A B V} l l',
    length l = length l' ->
    forall  (ge : Genv.t A V) (tge : Genv.t B V),
      Genv.genv_next ge = Genv.genv_next tge ->
      Genv.genv_next (Genv.add_globals ge l) = Genv.genv_next (Genv.add_globals tge l').
Proof.
  induction l; intros;
    destruct l' eqn:?; simpl in *; try omega;
      eauto.
  subst.
  eapply IHl; eauto.
  unfold Genv.add_global. simpl. congruence.
Qed.

Lemma genv_next_transf :
  forall {A B V} (p : AST.program A V) (tp : AST.program B V) (tf : A -> B),
    transform_program tf p = tp ->
    Genv.genv_next (Genv.globalenv p) = Genv.genv_next (Genv.globalenv tp).
Proof.
  intros. unfold Genv.globalenv.
  erewrite genv_next_ind; try reflexivity.
  unfold transform_program in *.
  subst tp. simpl.
  rewrite list_length_map; reflexivity.
Qed.

Lemma transf_globdefs_length :
  forall {A B V W} l l' (tf : A -> Errors.res B) (tv : V -> Errors.res W),
    transf_globdefs tf tv l = Errors.OK l' ->
    length l = length l'.
Proof.
  induction l; intros.
  simpl in H. inv H. reflexivity.
  simpl in *. repeat (break_match_hyp; try congruence; inv H).
  eapply Errors.bind_inversion in H3. break_exists. break_and.
  inv H3. simpl.
  erewrite IHl; eauto.
  eapply Errors.bind_inversion in H3. break_exists. break_and.
  inv H3. simpl.
  erewrite IHl; eauto.
Qed.

Lemma genv_next_transf_partial :
  forall {A B V} (p : AST.program A V) (tp : AST.program B V) (tf : A -> Errors.res B),
    transform_partial_program tf p = Errors.OK tp ->
    Genv.genv_next (Genv.globalenv p) = Genv.genv_next (Genv.globalenv tp).
Proof.
  intros. unfold Genv.globalenv.
  erewrite genv_next_ind; try reflexivity.
  unfold transform_partial_program in *.
  unfold transform_partial_program2 in *.
  eapply Errors.bind_inversion in H.
  break_exists. break_and.
  inv H0. simpl.
  eapply transf_globdefs_length; eauto.
Qed.

(*Definition global_blocks_valid {A B} (ge : Genv.t A B) (m : mem) : Prop :=
  forall b f v,
    Genv.find_funct_ptr ge b = Some f \/ Genv.find_var_info ge b = Some v -> Plt b (Mem.nextblock m).*)

Definition no_future_pointers (m : mem) : Prop :=
  forall b ofs b' ofs' q n,
    Plt b (Mem.nextblock m) ->
    ZMap.get ofs (Mem.mem_contents m) !! b = Fragment (Vptr b' ofs') q n ->
    Plt b' (Mem.nextblock m).

Lemma load_all_extends :
  forall {F V} (ge : Genv.t F V) l m l',
    load_all l m = Some l' ->
    (forall a b, In (a,b) l' -> value_inject ge m a b) ->
    forall m',
      Mem.extends m m' ->
      (forall a b, In (a,b) l' -> value_inject ge m' a b) ->
      exists l0,
        load_all l m' = Some l0 /\ (forall a b, In (a,b) l0 -> value_inject ge m' a b).
Proof.
    induction l; intros.
  - simpl in H. inv H. exists nil.
    simpl. split; auto.
  - simpl in H.
    repeat (break_match_hyp; try congruence).
    subst.
    invc H.
    eapply IHl in Heqo0; eauto.

    + app Mem.loadv_extends Mem.loadv.
      break_exists; break_and. eexists; split.
        { simpl. repeat collapse_match. reflexivity. }

      intros. simpl in H7. destruct H7; cycle 1.
        { eapply H6. assumption. }
      invc H7.
      assert (value_inject ge m' a v1). {
        eapply H2. simpl. left. auto.
      }
      assert (v1 = b). {
        inv H7; inv H5; try congruence.
        - (* opaque case *)
          on >@value_inject, invc.
          fwd eapply opaque_type_inject_defined; eauto.  congruence.
      } subst.
      assumption.

    + intros. eapply H0. simpl. right. assumption.

    + intros. eapply H2. simpl. right. auto.
Qed.

Lemma load_all_result_decomp :
  forall args b ofs m l,
    load_all (arg_addrs b ofs args) m = Some l ->
    exists r',
      split l = (args,r') /\ length args = length r'.
Proof.
  induction args; intros.
  simpl in *. inv H. simpl. eauto.
  simpl in *. repeat (break_match_hyp; try congruence).
  inv H. simpl.
  eapply IHargs in Heqo0.
  break_exists. break_and. rewrite H0.
  eexists; split; eauto. simpl. eauto.
Qed.

Lemma list_forall2_combine :
  forall {A B : Type}  l r,
    length l = length r ->
  forall (P : A -> B -> Prop),
    (list_forall2 P l r <->
    (forall (x : A) (y : B),
      In (x,y) (combine l r) ->
      P x y)).
Proof.
  intros; split.
  induction 1; intros.
  simpl in H0. inversion H0. simpl.
  simpl in H2. destruct H2; try inv H2;
                 eauto.
  generalize dependent r.
  induction l; intros;
  destruct r; simpl in H; try congruence;
  econstructor; eauto.
  eapply H0. simpl. left. auto.
  eapply IHl. inv H. eauto.
  intros. eapply H0. simpl. right. auto.
Qed.

Lemma value_inject_mem_extends :
  forall {F V} (ge : Genv.t F V) m m' v v',
    value_inject ge m v v' ->
    Mem.extends m m' ->
    value_inject ge m' v v'.
Proof.
  intros until v.
  induction v using value_rect_mut with (Pl := fun vs => forall vs',
                                                   list_forall2 (value_inject ge m) vs vs' ->
                                                   Mem.extends m m' ->
                                                   list_forall2 (value_inject ge m') vs vs'
                                        ); intros;
    inv H;
    try solve [econstructor; eauto].

  Focus 3. {
    on >Mem.extends, invc. on >@value_inject, invc. fix_existT. subst.
    assert (same_offsets inject_id).
      { unfold same_offsets, inject_id. simpl. intros. congruence. }
    econstructor.
    eapply opaque_type_value_val_inject; eauto.
    - destruct v'; econstructor; eauto.
      + reflexivity.
      + rewrite Int.add_zero. reflexivity.
  } Unfocus.

  all: app Mem.loadv_extends Mem.loadv;
    app (@load_all_extends F V) load_all;
  try solve [econstructor; eauto;
             inv H3; eauto].

  intros.
  eapply load_all_result_decomp in H5.
  break_exists. break_and.
  specialize (IHv x0).
  copy (split_combine l').
  rewrite H5 in H9. subst l'.
  eapply list_forall2_combine; eauto.
  eapply IHv; eauto.
  erewrite list_forall2_combine; eauto.

  intros.
  eapply load_all_result_decomp in H6.
  break_exists. break_and.
  specialize (IHv x0).
  copy (split_combine l').
  rewrite H6 in H11. subst l'.
  eapply list_forall2_combine; eauto.
  eapply IHv; eauto.
  erewrite list_forall2_combine; eauto.
Qed.

Definition env_inject {A B} (hlenv : PTree.t value) (llenv : PTree.t val) (ge : Genv.t A B)(m : mem) : Prop :=
  forall id v,
    PTree.get id hlenv = Some v ->
    exists v',
      PTree.get id llenv = Some v' /\ value_inject ge m v v'.

Lemma load_all_val :
  forall l b ofs m l' n v,
    nth_error l n = Some v ->
    load_all (arg_addrs b ofs l) m = Some l' ->
    exists v',
      Mem.loadv Mint32 m (Vptr b (Int.add ofs (Int.repr (4 * Z.of_nat n)))) = Some v' /\ In (v,v') l'.
Proof.
  induction l; intros;
    destruct n; simpl in H; inv H; subst.
  * simpl in H0.
    repeat break_match_hyp; try congruence.
    simpl. replace (Int.add ofs (Int.repr 0)) with ofs by ring.
    eexists; split; eauto. invc H0. simpl.
    left. auto.
  * simpl in H0. repeat break_match_hyp; try congruence.
    inv H0.
    eapply IHl in H; eauto.
    repeat break_exists; repeat break_and.
    replace (Int.add (Int.add ofs (Int.repr 4)) (Int.repr (4 * Z.of_nat n)))
    with  (Int.add ofs (Int.repr (4 * Z.of_nat (S n)))) in H.

    eexists. split. eauto.
    simpl. right. auto.

    (* rest is annoying math over Z/nat/int *)
    replace (4 * Z.of_nat (S n)) with (4 + 4 * Z.of_nat n)%Z.
    rewrite Int.add_assoc.
    f_equal.
    rewrite Int.add_unsigned.
    rewrite (Int.unsigned_repr 4).
    rewrite Int.unsigned_repr_eq.
    eapply Int.eqm_samerepr.
    unfold Int.eqm.
    assert (Int.modulus > 0).
    unfold Int.modulus, two_power_nat, Int.wordsize, Wordsize_32.wordsize.
    simpl. omega.
    remember (Int.eqmod_mod Int.modulus H3) as ie.
    eapply Int.eqmod_add. econstructor; eauto. instantiate (1 := 0).
    omega.
    eapply Int.eqmod_mod.
    omega. unfold Int.max_unsigned.
    simpl. omega.
    rewrite Nat2Z.inj_succ.
    omega.
Qed.

(* (* number of bytes to store a value *) *)
Definition size_bytes (v : value) : Z :=
  match v with
  | Close _ l => (4 * Z.of_nat (length l)) + 4
  | Constr _ l => (4 * Z.of_nat (length l)) + 4
  | Opaque _ _ => 0
  end.

Definition rest (v : value ) : list value :=
  match v with
  | Close _ l => l
  | Constr _ l => l
  | Opaque _ _ => []
  end.

Fixpoint store_list (b : block) (ofs : Z) (l : list val) (m : mem) : option mem :=
  match l with
  | nil => Some m
  | v :: vs =>
    match Mem.storev Mint32 m (Vptr b (Int.repr ofs)) v with
    | Some m' => store_list b (ofs + 4) vs m'
    | None => None
    end
  end.

Definition first_byte {A B} (ge : Genv.t A B) (v : value) : option val :=
  match v with
  | Close fname _ =>
    match Genv.find_symbol ge fname with
    | Some b =>
      match Genv.find_funct_ptr ge b with
      | Some _ => Some (Vptr b Int.zero)
      | None => None
      end
    | None => None
    end
  | Constr tag _ => Some (Vint tag)
  | Opaque _ _ => None
  end.

Definition store_value {A B} (ge : Genv.t A B) (v : value) (m : mem) (l : list val) : option (val * mem) :=
  let sz := size_bytes v in (* find total size for value *)
  let (m',b) := Mem.alloc m 0 sz in (* allocate that much space *)
  match first_byte ge v with
  | Some v' =>
    match Mem.storev Mint32 m' (Vptr b Int.zero) v' with
    | Some m'' =>
      match store_list b 4 l m'' with
      | Some m''' =>
        Some (Vptr b Int.zero, m''')
      | None => None
      end
    | None => None
    end
  | None => None
  end.

Ltac clean :=
  match goal with
  | [ H : Some _ = Some _ |- _ ] => invc H
  | [ H : False |- _ ] => inv H
  end; try congruence.

Definition meta_map := list (ident * metadata).

Inductive public_value {F V} (P : AST.program F V) (M : meta_map) : value -> Prop :=
| PvConstr : forall tag args,
        Forall (public_value P M) args ->
        public_value P M (Constr tag args)
| PvClose : forall fname free m,
        In fname (prog_public P) ->
        Forall (public_value P M) free ->
        In (fname, m) M ->
        length free = m_nfree m ->
        public_value P M (Close fname free)
| PvOpaque : forall ty v, public_value P M (Opaque ty v).

Lemma prog_public_public_value : forall F V F' V'
        (p : AST.program F V) (p' : AST.program F' V') M,
    prog_public p = prog_public p' ->
    forall v,
    public_value p M v ->
    public_value p' M v.
intros until v.
induction v using value_rect_mut with
    (Pl := fun vs =>
        Forall (public_value p M) vs ->
        Forall (public_value p' M) vs);
intros Apub; invc Apub; econstructor; eauto.
- find_rewrite. auto.
Qed.

Lemma prog_public_public_value' : forall F V F' V'
        (p : AST.program F V) (p' : AST.program F' V') M,
    prog_public p = prog_public p' ->
    forall v,
    public_value p' M v ->
    public_value p M v.
intros until v.
induction v using value_rect_mut with
    (Pl := fun vs =>
        Forall (public_value p' M) vs ->
        Forall (public_value p M) vs);
intros Bpub; invc Bpub; econstructor; eauto.
- find_rewrite. auto.
Qed.

Lemma transf_public_value : forall A B V (f : A -> B) (p : AST.program A V) M v,
    public_value p M v ->
    public_value (AST.transform_program f p) M v.
intros.
eapply prog_public_public_value; try eassumption; eauto.
Qed.

Lemma transf_public_value' : forall A B V (f : A -> B) (p : AST.program A V) M v,
    public_value (AST.transform_program f p) M v ->
    public_value p M v.
intros.
eapply prog_public_public_value'; try eassumption; eauto.
Qed.

Lemma transf_partial_public_value : forall A B V (f : A -> res B)
        (p : AST.program A V) p' M,
    AST.transform_partial_program f p = OK p' ->
    forall v,
    public_value p M v ->
    public_value p' M v.
intros.
eapply prog_public_public_value; try eassumption.
symmetry. eauto using transform_partial_program_public.
Qed.

Lemma transf_partial_public_value' : forall A B V (f : A -> res B)
        (p : AST.program A V) p' M,
    AST.transform_partial_program f p = OK p' ->
    forall v,
    public_value p' M v ->
    public_value p M v.
intros.
eapply prog_public_public_value'; try eassumption.
symmetry. eauto using transform_partial_program_public.
Qed.

Definition change_only_fnames (P : function_name -> function_name -> Prop) :
        value -> value -> Prop :=
    let fix go v1 v2 :=
        let fix go_list vs1 vs2 :=
            match vs1, vs2 with
            | [], [] => True
            | v1 :: vs1, v2 :: vs2 => go v1 v2 /\ go_list vs1 vs2
            | _, _ => False
            end in
        match v1, v2 with
        | Constr tag1 args1, Constr tag2 args2 =>
                tag1 = tag2 /\ go_list args1 args2
        | Close f1 free1, Close f2 free2 =>
                P f1 f2 /\ go_list free1 free2
        | Opaque oty1 ov1, Opaque oty2 ov2 =>
                existT _ oty1 ov1 = existT _ oty2 ov2
        | _, _ => False
        end in go.

Definition change_only_fnames_list (P : function_name -> function_name -> Prop) :=
    let go := change_only_fnames P in
    let fix go_list vs1 vs2 :=
        match vs1, vs2 with
        | [], [] => True
        | v1 :: vs1, v2 :: vs2 => go v1 v2 /\ go_list vs1 vs2
        | _, _ => False
        end in go_list.

Ltac refold_change_only_fnames P := fold (change_only_fnames P) in *.

Lemma change_only_fnames_list_Forall : forall P vs1 vs2,
    change_only_fnames_list P vs1 vs2 <->
    Forall2 (change_only_fnames P) vs1 vs2.
induction vs1; destruct vs2; split; intro HH; invc HH.
- constructor.
- constructor.
- constructor; eauto. firstorder.
- constructor; eauto. firstorder.
Qed.

Lemma ptr_block_valid : forall A B (ge : Genv.t A B) m hv b ofs,
    value_inject ge m hv (Vptr b ofs) ->
    Mem.valid_block m b.
inversion 1.

- eapply Mem.valid_access_valid_block.
  eapply Mem.valid_access_implies.
  + eapply Mem.load_valid_access. eauto.
  + constructor.

- eapply Mem.valid_access_valid_block.
  eapply Mem.valid_access_implies.
  + eapply Mem.load_valid_access. eauto.
  + constructor.

- eapply opaque_type_ptr_block_valid; eauto.
Qed.


Require Import CoqlibC Errors.
Require Import Integers Floats AST Linking.
Require Import ValuesC Memory Events Globalenvs Smallstep.
Require Import Op Locations MachC Conventions ConventionsC AsmC.
Require Import Asmgen Asmgenproof0.
Require Import sflib.
(* newly added *)
Require Export Asmgenproof.
Require Import SimModSem SimMemExt SimSymbId MemoryC ValuesC MemdataC LocationsC StoreArguments Conventions1C.

Require Import Skeleton Mod ModSem SimMod SimSymb SimMem AsmregsC MatchSimModSem.
Require Import JunkBlock StoreArgumentsProps.
Require SoundTop.

Local Opaque Z.mul.
Local Existing Instance main_args_some.

Set Implicit Arguments.

Section PRESERVATION.

Variable skenv_link: SkEnv.t.
Variable prog: Mach.program.
Variable tprog: Asm.program.
Let md_src: Mod.t := (MachC.module prog return_address_offset).
Let md_tgt: Mod.t := (AsmC.module tprog).
Hypothesis (INCLSRC: SkEnv.includes skenv_link (Mod.sk md_src)).
Hypothesis (INCLTGT: SkEnv.includes skenv_link (Mod.sk md_tgt)).
Hypothesis (WF: SkEnv.wf skenv_link).

Hypothesis TRANSF: match_prog prog tprog.

Let ge := (SkEnv.revive (SkEnv.project skenv_link (Mod.sk md_src)) prog).
Let tge := (SkEnv.revive (SkEnv.project skenv_link (Mod.sk md_tgt)) tprog).

Variable sm_link: SimMem.t.

Definition msp: ModSemPair.t :=
  ModSemPair.mk (SM := SimMemExt)
                (Mod.modsem (md_src) skenv_link)
                (Mod.modsem (md_tgt) skenv_link)
                (SimSymbId.mk md_src md_tgt) sm_link.

Definition get_rs (ms: Mach.state) : Mach.regset :=
  match ms with
  | Mach.State _ _ _ _ rs _ => rs
  | Callstate _ _ rs _ => rs
  | Returnstate _ rs _ => rs
  end.

Record agree_eq (ms: Mach.regset) (sp: val) (rs: Asm.regset) (sg: signature): Prop :=
  mkagree
    { agree_sp: rs#SP = sp;
      agree_sp_def: sp <> Vundef;
      agree_mregs_less:
        forall (r: mreg) (IN: In (R r) (regs_of_rpairs (loc_arguments sg))),
          Val.lessdef (ms r) (rs#(preg_of r));
      agree_mregs_eq:
        forall (r: mreg) (NOTIN: ~ In (R r) (regs_of_rpairs (loc_arguments sg))),
          (ms r) = (rs#(preg_of r));
    }.

Definition set_regset (rs0 rs1: Mach.regset) (sg: signature) (mr: mreg) : val :=
  if Loc.notin_dec (R mr) (regs_of_rpairs (loc_arguments sg)) then rs1 mr else rs0 mr.

Definition set_regset_undef (rs: Mach.regset) (sg: signature) (mr: mreg) : val :=
  if Loc.notin_dec (R mr) (regs_of_rpairs (loc_arguments sg)) then Vundef else rs mr.

Inductive match_init_data init_sp init_ra
          init_rs_src init_sg_src init_rs_tgt : Prop :=
| match_init_data_intro
    (INITRA: init_ra = init_rs_tgt RA)
    (INITRAPTR: <<TPTR: Val.has_type (init_ra) Tptr>> /\ <<RADEF: init_ra <> Vundef>>)
    (INITRS: agree_eq init_rs_src init_sp init_rs_tgt init_sg_src )
    (SIG: exists fd, (Genv.find_funct tge) (init_rs_tgt PC) = Some (Internal fd) /\ fd.(fn_sig) = init_sg_src /\ init_sg_src.(sig_cstyle)).

Inductive stack_base (initial_parent_sp initial_parent_ra: val): list Mach.stackframe -> Prop :=
| stack_base_dummy:
    stack_base initial_parent_sp initial_parent_ra
      ((dummy_stack initial_parent_sp initial_parent_ra)::[])
| stack_base_cons
    fr ls
    (TL: stack_base initial_parent_sp initial_parent_ra ls):
    stack_base initial_parent_sp initial_parent_ra (fr::ls).

Inductive match_states
          (idx: nat) (st_src0: MachC.state) (st_tgt0: AsmC.state)
          (sm0: SimMem.t): Prop :=
| match_states_intro
    init_sp init_ra
    (* (initial_parent_sp_ptr : ValuesC.is_real_ptr (init_sp)) *)
    (initial_parent_ra_ptr: Val.has_type init_ra Tptr)
    (initial_parent_ra_def: init_ra <> Vundef)
    (initial_parent_ra_junk: forall blk ofs (RAVAL: init_ra = Vptr blk ofs),
        ~ Plt blk (Genv.genv_next skenv_link))
    (* (initial_parent_ra_junk1: tge.(Genv.find_funct) init_ra = None) *)
    (STACKWF: stack_base init_sp init_ra (get_stack st_src0.(MachC.st)))
    (INITDATA: match_init_data
                 init_sp init_ra st_src0.(MachC.init_rs) st_src0.(init_sg) st_tgt0.(init_rs))
    (MATCHST: Asmgenproof.match_states ge st_src0.(MachC.st) st_tgt0)
    (* (SPPTR: ValuesC.is_real_ptr (st_tgt0.(init_rs) RSP)) *)
    (MCOMPATSRC: (MachC.get_mem st_src0.(MachC.st)) = sm0.(SimMem.src))
    (MCOMPATTGT: (get_mem st_tgt0) = sm0.(SimMem.tgt))
    (IDX: measure st_src0.(MachC.st) = idx).

Lemma asm_step_dstep init_rs st0 st1 tr
      (STEP: Asm.step skenv_link tge st0 tr st1):
    Simulation.DStep (modsem skenv_link tprog) (mkstate init_rs st0) tr (mkstate init_rs st1).
Proof.
  econs.
  - eapply modsem_determinate; et.
  - econs; auto.
Qed.

Lemma asm_star_dstar init_rs st0 st1 tr
      (STEP: star Asm.step skenv_link tge st0 tr st1):
    Simulation.DStar (modsem skenv_link tprog) (mkstate init_rs st0) tr (mkstate init_rs st1).
Proof.
  induction STEP; econs; eauto. eapply asm_step_dstep; auto.
Qed.

Lemma asm_plus_dplus init_rs st0 st1 tr
      (STEP: plus Asm.step skenv_link tge st0 tr st1):
    Simulation.DPlus (modsem skenv_link tprog) (mkstate init_rs st0) tr (mkstate init_rs st1).
Proof.
  inv STEP. econs; eauto.
  - eapply asm_step_dstep; eauto.
  - eapply asm_star_dstar; eauto.
Qed.

Theorem make_match_genvs :
  SimSymbId.sim_skenv (SkEnv.project skenv_link (Mod.sk md_src))
                      (SkEnv.project skenv_link (Mod.sk md_tgt)) ->
  Genv.match_genvs (match_globdef (fun _ f tf => transf_fundef f = OK tf) eq prog) ge tge.
Proof. subst_locals. eapply SimSymbId.sim_skenv_revive; eauto. Qed.

Lemma transf_function_sig
      fd_src fd_tgt
      (TRANS: transf_function fd_src = OK fd_tgt):
  fd_src.(Mach.fn_sig) = fd_tgt.(fn_sig).
Proof. repeat unfold transf_function, bind, transl_function in *. des_ifs. Qed.

Theorem sim_modsem: ModSemPair.sim msp.
Proof.
  eapply match_states_sim with (match_states := match_states)
                               (match_states_at := top4); eauto; ii; ss.

  - apply lt_wf.
  - eapply SoundTop.sound_state_local_preservation.

  - inv INITTGT; cycle 1.
    { ss. des_safe. inv SAFESRC. inv SIMARGS; ss. }
    des. inv SAFESRC. destruct sm_arg, args_src; ss. inv SIMARGS; ss. clarify.
    exploit make_match_genvs; eauto. { apply SIMSKENV. } intro SIMGE. des.

    assert (SRCSTORE: exists rs_src m_src,
               StoreArguments.store_arguments src rs_src (typify_list vs_src (sig_args (fn_sig fd))) (fn_sig fd) m_src /\
           agree_eq rs_src (Vptr (Mem.nextblock src)
                          Ptrofs.zero) rs (fn_sig fd) /\ Mem.extends m_src m0).
    { inv TYP.
      exploit store_arguments_parallel_extends.
      - eapply typify_has_type_list. eauto.
      - exploit SkEnv.revive_incl_skenv; try eapply INCLTGT; eauto. i. des. inv WF.
        eapply WFPARAM in H; eauto.
      - instantiate (1:= typify_list vs_src (sig_args (fn_sig fd))).
        eapply lessdef_list_typify_list; eauto. erewrite lessdef_list_length; eauto.
      - eapply MWF.
      - inv STORE. eauto.
      - i. des. exists (set_regset rs_src (to_mregset rs) (fn_sig fd)).
        esplits; eauto.
        + clear - ARGTGT. inv ARGTGT. econs; eauto.
          eapply extcall_arguments_same; eauto.
          i. unfold set_regset. des_ifs.
          eapply Loc.notin_not_in in n. contradiction.
        + inv STORE. econs; eauto.
          * inv MWF. rewrite mext_next. eauto.
          * intros X. inv X.
          * i. unfold set_regset. des_ifs.
            eapply val_inject_id. eapply AGREE.
          * i. unfold set_regset. des_ifs.
            eapply LocationsC.Loc_not_in_notin_R in NOTIN. contradiction.
    }

    destruct SRCSTORE as [rs_src [m_src [SRCSTORE [AGREE EXTENDS]]]]. inv AGREE.
    exists (MachC.mkstate
              rs_src (fn_sig fd)
              (Callstate
                 [dummy_stack (Vptr (Mem.nextblock src) Ptrofs.zero) (rs RA)]
                 fptr_src rs_src (assign_junk_blocks m_src n))).
    inv FPTR; ss.
    esplits; auto; ss.
    + inv TYP0. clear_tac.
      assert(SIG2: fn_sig fd = (Mach.fn_sig fd0)).
      { hexploit (Genv.find_funct_transf_partial_genv SIMGE); eauto. i; des.
        folder. ss; try unfold bind in *; des_ifs.
        symmetry. eapply transf_function_sig; eauto.
      }
      econs; eauto; ss.
      * econs; eauto; ss; eauto with congruence.
      * ii. erewrite (agree_mregs_eq0 mr) in *; auto. unfold NW. apply NNPP. intro T.
        exploit PTRFREE; eauto.
        { instantiate (1:= preg_of mr). intro U. contradict T.
          unfold is_junk_value in U. unfold is_junk_value. des_ifs. des. split; ss.
          - erewrite Mem.valid_block_extends; eauto.
          - erewrite Mem.valid_block_extends; eauto. eapply assign_junk_block_extends; et.
        }
        i. des; try (by destruct mr; clarify). rewrite Asm.to_preg_to_mreg in *. clarify.
    + instantiate (1:= SimMemExt.mk (assign_junk_blocks m_src n) (assign_junk_blocks m0 n)).
      econs; try eapply RADEF; ss; eauto.
      * econs; eauto.
      * econs; ss; eauto.
      * econs; eauto; ss; try by (econs; eauto).
        { eapply assign_junk_block_extends; et. }
        econs; eauto. i.
        destruct (classic (In (R r) (regs_of_rpairs (loc_arguments (fn_sig fd))))); eauto.
        erewrite agree_mregs_eq0; auto.

  - ss. des. inv SAFESRC. inv SIMARGS; ss. destruct sm_arg; ss. clarify.
    exploit make_match_genvs; eauto. { apply SIMSKENV. } intro SIMGE.
    hexploit (Genv.find_funct_transf_partial_genv SIMGE); eauto. i; des. ss; unfold bind in *; des_ifs. rename f into fd_tgt.
    inv TYP.
    assert(SIG: fn_sig fd_tgt = (Mach.fn_sig fd)).
    { hexploit (Genv.find_funct_transf_partial_genv SIMGE); eauto. i; des.
      folder. ss; try unfold bind in *; des_ifs.
      symmetry. eapply transf_function_sig; eauto.
    }
    assert (exists rs_tgt m_tgt,
               (<<STORE: AsmC.store_arguments tgt rs_tgt
                                              (typify_list vs_tgt (sig_args (Mach.fn_sig fd)))
                                              (* (Args.vs args_tgt) *)
                                              (Mach.fn_sig fd) m_tgt>>) /\
               (<<RSPC: rs_tgt PC = fptr_tgt>>) /\
               (<<RSRA: rs_tgt RA = Vnullptr>>) /\
               (<<PTRFREE: forall pr (PTR: ~ is_junk_value m0 (assign_junk_blocks m0 n) (rs_tgt pr)),
                   (<<INARG: exists mr,
                       (<<MR: to_mreg pr = Some mr>>) /\
                       (<<ARG: In (R mr) (regs_of_rpairs (loc_arguments (Mach.fn_sig fd)))>>)>>) \/
                   (<<INPC: pr = PC>>) \/
                   (<<INRSP: pr = RSP>>)>>)).
    { exploit StoreArgumentsProps.store_arguments_progress.
      - instantiate (2:=typify_list vs_tgt (sig_args (Mach.fn_sig fd))).
        eapply typify_has_type_list. erewrite <- lessdef_list_length; eauto.
      - exploit SkEnv.revive_incl_skenv; try eapply INCLTGT; eauto. i. des. inv WF.
        eapply WFPARAM in H0. eauto. ss. rewrite <- SIG. ss.
      - instantiate (1:= n). i. des.
        exists ((to_pregset (set_regset_undef rs0 (Mach.fn_sig fd)))
                  #PC <- fptr_tgt
                  #RA <- Vnullptr
                  #RSP <- (Vptr (Mem.nextblock tgt) Ptrofs.zero)).
        esplits; eauto.
        + split; ss. inv STR. econs; eauto. eapply extcall_arguments_same; eauto. i.
          { assert (NNIN: ~ Loc.notin (R r) (regs_of_rpairs (loc_arguments (Mach.fn_sig fd)))).
            { intros X. eapply Loc.notin_not_in; eauto. }
            unfold set_regset_undef, to_pregset, to_mregset, Pregmap.set, to_preg, preg_of, to_mreg in *.
            destruct r; eauto; des_ifs; try contradiction.
          }
        + i.
          assert (NNIN: forall mr, ~ Loc.notin (R mr) (regs_of_rpairs (loc_arguments (Mach.fn_sig fd))) -> In (R mr) (regs_of_rpairs (loc_arguments (Mach.fn_sig fd)))).
          { intros mr NIN. clear - NIN.
            eapply NNPP. intros X.
            eapply LocationsC.Loc_not_in_notin_R in X. des. contradiction. }
          clear - NNIN PTR. unfold set_regset_undef, to_pregset, to_mregset, Pregmap.set, to_preg, preg_of, to_mreg in *.
          destruct pr; des_ifs; ss; eauto. exfalso. apply PTR. ss.
    }
    des. eexists. econs; eauto; swap 1 2.
    + folder. inv FPTR; ss. eauto.
    + congruence.
    + rewrite RSRA. econs; ss.
    + rewrite RSRA. ss.
    + rewrite SIG. econs; eauto. rewrite <- LEN. symmetry. eapply lessdef_list_length. eauto.
    + erewrite <- transf_function_sig; eauto.
    + erewrite <- transf_function_sig; eauto. ii. hexploit PTRFREE0; et.
      ii. apply PTR. unfold is_junk_value in *. des_ifs.
      unfold Mem.valid_block. unfold Mem.valid_block in H0.
      rewrite assign_junk_blocks_nextblock in *.
      inv STORE. inv STORE0. inv H1. rewrite <- NB0. rewrite <- NB in *.
      erewrite Mem.nextblock_alloc; eauto.
      erewrite (Mem.nextblock_alloc src) in H0; eauto.
      inv MWF. rewrite <- mext_next. des; esplits; eauto; try xomega.
  - inv MATCH; ss. destruct st_src0, st_tgt0, sm0. ss. inv MATCHST; ss.

  - ss. inv CALLSRC. inv MATCH. inv INITDATA. inv MATCHST. ss. destruct st_tgt0. ss. clarify. des.
    inv FPTR; ss. destruct (rs0 PC) eqn:PCEQ; ss. des_ifs.

    exploit Asmgenproof0.extcall_arguments_match; eauto. intros TGRARGS. des.
    exploit Mem.free_parallel_extends; eauto. intros TGTFREE. des. esplits; ss.
    + econs; eauto.
      * r in TRANSF. r in TRANSF.
        exploit (SimSymbId.sim_skenv_revive TRANSF); eauto.
        { apply SIMSKENV. }
        intro GE. apply (fsim_external_funct_id GE); ss.
      * inv STACKS; ss.
        -- inv STACKWF; [|inv TL]. inv ATLR; auto; exfalso; auto.
        -- destruct ra; ss; try inv H0. inv ATLR. ss.
      * inv AG. rewrite agree_sp0. clarify.
    + instantiate (1:= SimMemExt.mk m1 m2'). econs; ss; eauto.
    + ss.

  - inv AFTERSRC. ss. des. clarify. destruct st_tgt0, st. inv MATCH. inv MATCHST.
    inv INITDATA. inv SIMRET; ss. destruct sm_ret. ss. clarify.
    exploit Mem_unfree_parallel_extends; try eapply UNFREE; eauto.
    intros TGTUNFREE. des. esplits; auto.
    + econs; ss; eauto.
      * exists skd. esplits; eauto. replace (r PC) with fptr; auto. inv FPTR; ss.
      * inv AG. rewrite agree_sp0. eauto.
    + instantiate (1:= SimMemExt.mk m1 m2'). inv INITRS. inv AG.
      econs; ss; eauto; econs; eauto.
      * econs; eauto.
      * unfold loc_external_result, regset_after_external, Mach.regset_after_external.
        apply agree_set_other; auto. apply agree_set_pair; auto.
        econstructor; ss; eauto. intros. rewrite to_preg_to_mreg.
        destruct (Conventions1.is_callee_save r0) eqn:T; eauto.

  - ss. inv FINALSRC. des. clarify. destruct st_tgt0, st. inv MATCH. inv MATCHST.
    inv INITDATA. destruct sm0. ss. clarify.
    inv STACKWF; [|inv TL]. inv STACKS; [|inv H7; ss]. inv INITRS.
    exploit Mem.free_parallel_extends; eauto. intros TGTFREE. des.
    esplits; auto.
    + econs; ss; eauto.
      * replace (r PC) with (init_rs0 RA).
        { clear - initial_parent_ra_junk. unfold external_state. des_ifs.
          exploit initial_parent_ra_junk; ss; eauto.
          unfold Genv.find_funct_ptr, Genv.find_def in *. des_ifs.
          eapply Genv.genv_defs_range in Heq1. ss.
        }
        inv ATPC; auto. exfalso. auto.
      * inv ATPC; auto. exfalso. auto.
      * unfold Genv.find_funct, Genv.find_funct_ptr. des_ifs.
        exfalso. exploit Genv.genv_defs_range; eauto. eapply initial_parent_ra_junk; ss.
      * inv AG. i.
        { eapply Val.lessdef_trans.
          - erewrite <- agree_mregs_eq0; auto. ii.
            eapply loc_args_callee_save_disjoint; eauto.
          - eauto.
        }
      * inv AG. rewrite agree_sp0. ss.
    + econs; simpl; ss.
      * ss. inv AG. auto.
      * instantiate (1:= SimMemExt.mk _ _). ss.
      * ss.
    + ss.

  - left; i. ss. esplits.
    + eapply MachC.modsem_receptive; et.

    + i. inv STEPSRC. inv MATCH. set (INITDATA0 := INITDATA). inv INITDATA0.
      inv INITRAPTR. inv INITRS0. clarify.
      exploit step_simulation; ss; try apply agree_sp_def0; eauto.
      { eapply make_match_genvs; eauto. apply SIMSKENV. }
      i. des; ss; esplits; auto; clarify.
      * left. instantiate (1 := mkstate st_tgt0.(init_rs) S2'). ss.
        destruct st_tgt0. eapply asm_plus_dplus; eauto.
      * instantiate (1 := SimMemExt.mk (MachC.get_mem (MachC.st st_src1)) (get_mem S2')).
        econs; ss; eauto.
        { instantiate (1:=init_rs st_tgt0 RSP).
          destruct st_src0, st_src1. clear - STEP STACKWF NOTDUMMY.
          inv STEP; ss; clarify.
          - econs. ss.
          - inv STACKWF; ss.
        }
        rewrite <- INITRS. rewrite <- INITFPTR. auto.
      * right. split; eauto. apply star_refl.
      * instantiate (1 := SimMemExt.mk (MachC.get_mem (MachC.st st_src1)) (get_mem st_tgt0.(st))).
        econs; ss; eauto.
        { instantiate (1:=init_rs st_tgt0 RSP).
          destruct st_src0, st_src1. clear - STEP STACKWF NOTDUMMY. inv STEP; ss; clarify.
          - econs. ss.
          - inv STACKWF; ss.
        }
        rewrite <- INITRS. rewrite <- INITFPTR. auto.

  Unshelve.
    all: ss.
Qed.

End PRESERVATION.

Section SIMMOD.

Variable prog: Mach.program.
Variable tprog: program.
Hypothesis TRANSL: match_prog prog tprog.
Definition mp: ModPair.t := mk_mp (MachC.module prog return_address_offset) (AsmC.module tprog).

Theorem sim_mod: ModPair.sim mp.
Proof.
  econs; ss.
  - r. eapply Sk.match_program_eq; eauto. ii. destruct f1; ss.
    + clarify. right. unfold bind in MATCH. des_ifs. esplits; eauto.
      unfold transf_function, transl_function, bind in *. des_ifs.
    + clarify. left. esplits; eauto.
  - ii. inv SIMSKENVLINK. eapply sim_modsem; eauto.
Qed.

End SIMMOD.


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.
Import compcert.lib.Maps.
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
  (PLAIN: plain_members m = true),
   Ctypes.field_type i m = Errors.OK t ->
          In (Member_plain i t) m.
Proof.
induction m as [|[|]]; intros.
inv H.
simpl in H.
if_tac in H. subst. inv H. left; auto.
right. apply IHm; auto.
inv PLAIN.
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; [ lia | ].
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);
   [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; [lia | ]. 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 lia.
* (* Tstruct *)
destruct (cenv_cs ! i) eqn:?H;
 [ | right; intro H0; inv H0; [inv H1 | congruence]].
destruct (plain_members (co_members c)) eqn:?PLAIN;
   [ | right; intro Hx; inv Hx; [ discriminate | 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, Full) => z0 | _ => 0 end).
pose (D := fun x: {it: member | In it (co_members c)} =>
                align_compatible_rec cenv_cs (type_member (proj1_sig x)) (z + FO (name_member (proj1_sig x)))).
assert (H1: forall x, {D x} + {~ D x}). {
 subst D. intros. destruct x as [[id t0|] ?].
2:{ exfalso. clear - i0 PLAIN.
   induction (co_members c) as [|[|]]; simpl in *; try discriminate; auto. destruct i0; auto. discriminate.
 }
 simpl.
 apply IHn.
 assert (H1:= rank_union_member cenv_cs _ a _ _ cenv_consistent H i0).
 simpl in H1. rewrite H in H1. lia.
}
destruct (Forall_dec D H1 (make_in_list (co_members c))) as [H2|H2]; clear H1; [left|right].
+
 eapply align_compatible_rec_Tstruct.
 eassumption. auto.
 assert (H1 := proj1 (Forall_forall _ _) H2); clear H2.
 intros.
 specialize (H1 (exist _ (Member_plain i0 t0) (field_type_in_members_strong _ _ _ PLAIN 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|] ?].
2:{ exfalso. clear - i0 PLAIN.
   induction (co_members c) as [|[|]]; simpl in *; try discriminate; auto. destruct i0; auto. discriminate.
 }
 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 PLAIN.
 induction (co_members c) as [|[|]]; [ | | discriminate]. inv i0. simpl.
 if_tac. subst.
 simpl in H1. destruct (id_in_list id0 (map name_member m)) eqn:?; try discriminate.
 destruct i0. inv H. auto.
 apply id_in_list_false in Heqb.
 exfalso. apply Heqb. apply (in_map name_member) in H. apply H.
 apply IHm. auto.
 destruct i0. inv H0. contradiction. auto.
 simpl in H1. destruct (id_in_list id0 (map name_member m)) eqn:?; try discriminate.
 auto.
 unfold FO; simpl.
 clear - i0 PLAIN.
 assert (in_members id (co_members c)). unfold in_members. apply (in_map name_member) in i0; auto.
 pose proof (plain_members_field_offset _ PLAIN _ _ H). rewrite H0. auto.
* (* Tunion *)
destruct (cenv_cs ! i) eqn:?H;
 [ | right; intro H0; inv H0; [inv H1 | congruence]].
destruct (plain_members (co_members c)) eqn:?PLAIN;
   [ | right; intro Hx; inv Hx; [ discriminate | congruence]].
simpl in Hrank. rewrite H in Hrank.
pose (D := fun x: {it: member | In it (co_members c)} =>
                align_compatible_rec cenv_cs (type_member (proj1_sig x)) z).
assert (H1: forall x, {D x} + {~ D x}). {
 subst D. intros. destruct x as [[id t0|] ?].
2:{ exfalso. clear - i0 PLAIN.
   induction (co_members c) as [|[|]]; simpl in *; try discriminate; auto. destruct i0; auto. discriminate.
 }
 simpl.
 apply IHn.
 assert (H1:= rank_union_member cenv_cs _ a _ _ cenv_consistent H i0).
 simpl in H1. rewrite H in H1. lia.
}
destruct (Forall_dec D H1 (make_in_list (co_members c))) as [H2|H2]; clear H1; [left|right].
+
 eapply align_compatible_rec_Tunion.
 eassumption. auto.
 assert (H1 := proj1 (Forall_forall _ _) H2); clear H2.
 intros.
 specialize (H1 (exist _ (Member_plain i0 t0) (field_type_in_members_strong _ _ _ PLAIN H0))).
 specialize (H1 (in_make_in_list _ _ _)).
 apply H1.
+
 contradict H2.
 apply Forall_forall.
 intros.
 subst D. simpl.
 destruct x as [[id t0|] ?].
2:{ exfalso. clear - i0 PLAIN.
   induction (co_members c) as [|[|]]; simpl in *; try discriminate; auto. destruct i0; auto. discriminate.
 }
 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 PLAIN.
 induction (co_members c) as [|[|]]; [ | | discriminate]. inv i0. simpl.
 if_tac. subst.
 simpl in H1. destruct (id_in_list id0 (map name_member m)) eqn:?; try discriminate.
 destruct i0. inv H. auto.
 apply id_in_list_false in Heqb.
 exfalso. apply Heqb. apply (in_map name_member) in H. apply H.
 apply IHm; auto.
 destruct i0. inv H0. contradiction. auto.
 simpl in H1. destruct (id_in_list id0 (map name_member 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)).
lia.
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.


Require Import Core.Core Core.Notations Core.Tactics Types
        Exec.Der_write_tags (* BCT.Exec *).
From ExtLib.Structures Require Import Monad MonadWriter.
From ExtLib.Data Require Import Monads.OptionMonad.

Require Export Types.
Require Export ExtLib.Structures.Monad.
From ExtLib.Data Require Export Monads.OptionMonad.

Open Scope monad.

(*Definition primitive_decoder td ls : option (list int * Z) :=
    match ls with
    | [] => None
    | _ => ber_check_tags td ls >>=
                        fun x => let c := tag_consumed x in
                              let l := tag_length x in
                              if (Zlength ls - c <? l)
                              then None
                              else let y := skipn (Z.to_nat c) ls in
                                    Some (y, c + 1)
    end.*)

(* writes tags, copies ls and outputs the number of encoded bytes *)
(* Definition primitive_encoder td ls : errW1 asn_enc_rval :=
  x <- der_write_tags td  ;;
  tell ls ;;
  ret (encode (Zlength ls + encoded x)). *)

Definition ZeroChar := Byte.repr 48.

Definition bool_of_byte (b : byte) :=
  if (b == default_byte)%byte then false else true.
Definition byte_of_bool (b : bool) := Byte.repr (if b then 255 else 0).
Definition int_of_bool (b : bool) := Int.repr (if b then 255 else 0).
Definition bool_of_int (i : int) :=
  if (i == 0)%int then false else true.

(* Find composite *)
Fixpoint find_cs (id : ident) cs : option composite_definition :=
  match cs with
  | Composite i s_u m a :: css => if (i =? id)%positive
                             then Some (Composite i s_u m a)
                             else find_cs id css
  | [] => None
  end.


From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.algebra Require Import excl agree csum.
From iris.heap_lang Require Import notation par proofmode.
From iris.proofmode Require Import proofmode.
From iris_examples.barrier Require Import proof specification.
From iris.prelude Require Import options.

Definition one_shotR (Σ : gFunctors) (F : oFunctor) :=
  csumR (exclR unitO) (agreeR $ laterO $ oFunctor_apply F (iPropO Σ)).
Definition Pending {Σ F} : one_shotR Σ F := Cinl (Excl ()).
Definition Shot {Σ} {F : oFunctor} (x : oFunctor_apply F (iPropO Σ)) : one_shotR Σ F :=
  Cinr $ to_agree $ Next $ x.

Class oneShotG (Σ : gFunctors) (F : oFunctor) :=
  one_shot_inG :> inG Σ (one_shotR Σ F).
Definition oneShotΣ (F : oFunctor) : gFunctors :=
  #[ GFunctor (csumRF (exclRF unitO) (agreeRF (▶ F))) ].
Global Instance subG_oneShotΣ {Σ F} : subG (oneShotΣ F) Σ → oneShotG Σ F.
Proof. solve_inG. Qed.

Definition client : val :=
  λ: "fM" "fW1" "fW2",
  let: "b" := newbarrier #() in
  ("fM" #() ;; signal "b") ||| ((wait "b" ;; "fW1" #()) ||| (wait "b" ;; "fW2" #())).

Section proof.
Local Set Default Proof Using "Type*".
Context `{!heapGS Σ, !barrierG Σ, !spawnG Σ, !oneShotG Σ F}.
Context (N : namespace).
Local Notation X := (oFunctor_apply F (iPropO Σ)).

Definition barrier_res γ (Φ : X → iProp Σ) : iProp Σ :=
  (∃ x, own γ (Shot x) ∗ Φ x)%I.

Lemma worker_spec e γ l (Φ Ψ : X → iProp Σ) :
  recv N l (barrier_res γ Φ) -∗ (∀ x, Φ x -∗ WP e {{ _, Ψ x }}) -∗
  WP wait #l ;; e {{ _, barrier_res γ Ψ }}.
Proof.
  iIntros "Hl He". wp_apply (wait_spec with "Hl"); simpl.
  iDestruct 1 as (x) "[#Hγ Hx]".
  wp_seq. iApply (wp_wand with "[Hx He]"); [by iApply "He"|].
  iIntros (v) "?"; iExists x; by iSplit.
Qed.

Context (P : iProp Σ) (Φ Φ1 Φ2 Ψ Ψ1 Ψ2 : X -n> iPropO Σ).
Context {Φ_split : ∀ x, Φ x -∗ (Φ1 x ∗ Φ2 x)}.
Context {Ψ_join  : ∀ x, Ψ1 x -∗ Ψ2 x -∗ Ψ x}.

Lemma P_res_split γ : barrier_res γ Φ -∗ barrier_res γ Φ1 ∗ barrier_res γ Φ2.
Proof.
  iDestruct 1 as (x) "[#Hγ Hx]".
  iDestruct (Φ_split with "Hx") as "[H1 H2]". by iSplitL "H1"; iExists x; iSplit.
Qed.

Lemma Q_res_join γ : barrier_res γ Ψ1 -∗ barrier_res γ Ψ2 -∗ ▷ barrier_res γ Ψ.
Proof.
  iDestruct 1 as (x) "[#Hγ Hx]"; iDestruct 1 as (x') "[#Hγ' Hx']".
  iAssert (▷ (x ≡ x'))%I as "Hxx".
  { iCombine "Hγ" "Hγ'" as "Hγ2". iClear "Hγ Hγ'".
    rewrite own_valid csum_validI /= agree_validI agree_equivI later_equivI /=.
    rewrite -{2}[x]oFunctor_map_id -{2}[x']oFunctor_map_id.
    assert (HF : oFunctor_map F (cid, cid) ≡ oFunctor_map F (iProp_fold (Σ:=Σ) ◎
        iProp_unfold, iProp_fold (Σ:=Σ) ◎ iProp_unfold)).
    { apply ne_proper; first by apply _.
      by split; intro; simpl; symmetry; apply iProp_fold_unfold. }
    rewrite (HF x). rewrite (HF x').
    rewrite !oFunctor_map_compose. iNext. by iRewrite "Hγ2". }
  iNext. iRewrite -"Hxx" in "Hx'".
  iExists x; iFrame "Hγ". iApply (Ψ_join with "Hx Hx'").
Qed.

Lemma client_spec_new (fM fW1 fW2 : val) :
  WP fM #() {{ _, ∃ x, Φ x }} -∗
  □ (∀ x, Φ1 x -∗ WP fW1 #() {{ _, Ψ1 x }}) -∗
  □ (∀ x, Φ2 x -∗ WP fW2 #() {{ _, Ψ2 x }}) -∗
  WP client fM fW1 fW2 {{ _, ∃ γ, barrier_res γ Ψ }}.
Proof using All.
  iIntros "/= Hf #Hf1 #Hf2"; rewrite /client.
  iMod (own_alloc (Pending : one_shotR Σ F)) as (γ) "Hγ"; first done.
  wp_lam. wp_pures. wp_apply (newbarrier_spec N (barrier_res γ Φ)); auto.
  iIntros (l) "[Hr Hs]".
  set (workers_post (v : val) := (barrier_res γ Ψ1 ∗ barrier_res γ Ψ2)%I).
  wp_smart_apply (par_spec  (λ _, True)%I workers_post with "[Hf Hs Hγ] [Hr]").
  - wp_lam. wp_bind (fM #()). iApply (wp_wand with "Hf").
    iIntros (v) "HP"; iDestruct "HP" as (x) "HP". wp_seq.
    iMod (own_update with "Hγ") as "Hx".
    { by apply (cmra_update_exclusive (Shot x)). }
    iApply (signal_spec with "[- $Hs]"); last auto.
    iExists x; auto.
  - iDestruct (recv_weaken with "[] Hr") as "Hr"; first by iApply P_res_split.
    iMod (recv_split with "Hr") as "[H1 H2]"; first done.
    wp_smart_apply (par_spec (λ _, barrier_res γ Ψ1)%I
                       (λ _, barrier_res γ Ψ2)%I with "[H1] [H2]").
    + wp_smart_apply (worker_spec with "H1"); auto.
    + wp_smart_apply (worker_spec with "H2"); auto.
    + auto.
  - iIntros (_ v) "[_ [H1 H2]]". iDestruct (Q_res_join with "H1 H2") as "?". auto.
Qed.
End proof.


From Undecidability.L Require Import Tactics.LTactics.
From Undecidability.L.Datatypes Require Import Lists LVector LSum LProd LFinType LNat.
From Complexity.Complexity Require Import NP Definitions Monotonic Subtypes.
From Undecidability.L.Functions Require Import EqBool.
From Undecidability.L.TM Require Import TapeFuns.
From Complexity.L.TM Require Import CompCode.

From Undecidability.TM Require Import TM_facts CodeTM.
From Undecidability.TM.Single Require Import EncodeTapes StepTM.

From Complexity.TM Require Import M2MBounds PrettyBounds.SizeBounds.
From Undecidability Require Import TM.Util.VectorPrelim.
From Complexity.Libs Require Import PSLCompat.

Unset Printing Coercions.

(*Import EncodeTapes DecodeTapes Single.StepTM ProgrammingTools Combinators Decode.*)

(*From Undecidability Require Import MultiUnivTimeSpaceSimulation. *)
From Complexity.NP Require Import TMGenNP_fixed_mTM M_multi2mono.

Set Default Proof Using "Type".
Section LMGenNP_to_TMGenNP_mTM.

  Context (sig:finType) (n:nat) `{R__sig : encodable sig}  (M : TM sig (S n)).
  Let M__mono := M__mono M.

  Local Arguments Canonical_Rel : simpl never.
  Local Arguments loopM : clear implicits.
  Local Arguments loopM {_ _ } _ _ _.
  Import L_facts.
  Import EqBool.

  (* From L/TM/Encoding.v *)
  Lemma sizeOfTape_by_size (t:(tape sig)) :
    sizeOfTape t <= size (enc t).
  Proof.
    unfold enc;cbn.
    destruct t;cbn [tapeToList sizeOfTape length size].
    all:rewrite ?app_length,?rev_length. all:cbn [length].
    all:ring_simplify. all:try rewrite !size_list_enc_r. all:try nia.
  Qed.
  Lemma sizeOfmTapes_by_size (t:tapes sig n) :
    sizeOfmTapes t <= size (enc t).
  Proof.
    setoid_rewrite enc_vector_eq. rewrite Lists.size_list.
    erewrite <- sumn_map_le_pointwise with (f1:=fun _ => _). 2:{ intros. setoid_rewrite <- sizeOfTape_by_size. reflexivity. }
    rewrite sizeOfmTapes_max_list_map. unfold MaxList.max_list_map. rewrite max_list_sumn.
    etransitivity. 2:now apply Nat.le_add_r. apply sumn_map_le_pointwise. intros. apply Nat.le_add_r.
  Qed.

  Lemma TMGenNP_mTM_to_TMGenNP_singleTM :
    mTMGenNP_fixed M ⪯p TMGenNP_fixed (projT1 M__mono).
  Proof.
    subst M__mono.
    evar (f__steps : nat*nat*nat -> nat). evar (f__nice : nat*nat*nat -> nat).
    enough (Hf__nice : f__steps <=c f__nice).
    unfold mTMGenNP_fixed,mTMGenNP_fixed',TMGenNP_fixed. cbn.
    set (t__start:=fun (ts : tapes sig n) => inl START::concat (map (fun t => inr (sigList_cons)::map (fun s => inr (sigList_X s)) (encode_tape t)) (Vector.to_list ts))++[inr (sigList_cons)]).
    set (t__size := fun maxSize => 3 + if eqb 0 maxSize then 0 else 1 + maxSize).
    eapply reducesPolyMO_intro_restrictBy_in with
        (f:=fun '(ts,maxSize,steps) => (t__start ts
                                     ,t__size maxSize
                                     ,  c__leUpToC (H:=Hf__nice) * f__nice (steps,sizeOfmTapes ts,maxSize)+ 3)).
    2:{ unfold execTM.
        intros [[v maxSize] steps]. unfold HaltsOrDiverges_mTM_fixed. intros H_HaltOrDiv.
        split.
        -intros (t1&Ht1&s__end&Hs__end).
         eexists (map (fun c => inr (sigList_X c)) (encode_tape t1) ++ [inr sigList_nil;inl STOP]).
         split. 1:{ cbn - [plus]. autorewrite with list. rewrite sizeOfTape_encodeTape. cbn - [Nat.eqb].
                    destruct (Nat.eqb_spec 0 (sizeOfTape t1));
                      destruct (eqb_spec 0 (maxSize)). all:try nia.
         }
         edestruct Terminates__mono as (?&?).
         2:{ eexists. cbn. unfold execTM. rewrite H. easy. }
         cbn. set (tin:=midtape _ _ _).
         eexists (select (putFirstAtEnd n) (t1:::v)), _.
         assert (Ht1v:contains_tapes tin (select (putFirstAtEnd n) (t1 ::: v))).
         { hnf. subst tin. f_equal. unfold encode_tapes.
           rewrite encode_list_concat.
           autorewrite with list. cbn. rewrite !concat_map,!map_map.
           rewrite putFirstAtEnd_to_list.
           autorewrite with list. cbn. repeat setoid_rewrite map_map.
           rewrite concat_app;cbn. autorewrite with list. easy.
         } split. easy.
         split. 2:easy. hnf.
         (do 2 eexists). split.
         +intros ? ?. cbn in H. replace v0 with ((select (putFirstAtEnd n) (t1 ::: v))) in * by now eapply contains_tapes_inj. clear v0 H.
          split. 1: {hnf. rewrite putEnd_invL. eauto. }
          assert (H':=proj2_sig M2MBounds.Loop_steps_nice). hnf in H'.
          unfold PrettyBounds.dominatedWith in H'.
          rewrite H'. rewrite putFirstAtEnd_to_list.
          rewrite BaseCode.encodeList_size_app,size_list, Vector.length_to_list.
          unfold Code.size. cbn - [mult plus].
          autorewrite with list. cbn [length]. rewrite sizeOfTape_encodeTape_le.
          erewrite sumn_map_le_pointwise with (f2:=fun x => _).
          2:{ intros. rewrite sizeOfTape_encodeTape_le. rewrite sizeOfmTapes_upperBound. 2:now eapply Vector.to_list_In. reflexivity. }
          rewrite !sumn_map_c, Vector.length_to_list.
          unshelve erewrite ( _ : (n * (2 + sizeOfmTapes v) + n + 1 + S (2 + sizeOfTape t1 + 1) + S n * steps)
                                  <= ((steps + sizeOfmTapes v + 5)* S n + sizeOfTape t1)). nia.
          reflexivity.
         +cbn - [mult plus]. autorewrite with list; cbn - [plus mult].
          rewrite length_concat,map_map;cbn - [plus mult];setoid_rewrite map_length.
          rewrite sizeOfTape_encodeTape_le,Ht1.
          rewrite sumn_le_bound.
          2:{ intros ? (?&<-&?)%in_map_iff.
              rewrite sizeOfTape_encodeTape_le, sizeOfmTapes_upperBound. 2:now apply Vector.to_list_In. reflexivity. }
          rewrite map_length. rewrite Vector.length_to_list.
          replace (1 + (2 + maxSize + 2)) with (maxSize + 5) by lia.
          setoid_rewrite <- correct__leUpToC.
          [f__steps]:refine (fun '(steps, sizeOfmTapes, maxSize) =>  _).
          set (sizeOfmTapes _). unfold f__steps. reflexivity.
        -intros (cert&Hsize&f'&Hf'). destruct @loopM as [f| ] eqn:Hf. all:cbn -[plus mult t__start] in *. 2:now inv Hf'. clear Hf' f'.
         apply Realises__mono in Hf as (v0&v1&Hv0&Hv1&H__mono). cbn in Hv0.
         hnf in H__mono;cbn in H__mono. unfold LiftTapes in H__mono;cbn in H__mono.
         destruct H__mono as (outc&k&Hout&<-&_).
         hnf in Hv0. revert Hv0. intros [= Htl].
         unfold encode_tapes in Htl;rewrite encode_list_concat in Htl.
         rewrite map_app,concat_map,map_map in Htl. cbn in Htl.
         setoid_rewrite map_map in Htl. rewrite <- !app_assoc in Htl. cbn in Htl.
         assert (H':=Htl). eapply concat_eq_inv_borderL with (isBorder := fun c => c = inr sigList_cons) in H'. rewrite map_length, Vector.length_to_list in H'.
         5:easy. 4:now cbn;intuition subst.
         2,3:intros _ (x&<-&Hinx)%in_map_iff. 2,3:eexists _,_;split;[reflexivity | ].
         2,3:now split;[easy | intros ? (y&<-&Hiny)%in_map_iff;easy].
         destruct H' as [Hinit Hlast]. rewrite skipn_map in Hlast.
         destruct (split_vector v0 n) as (v'&vlst) eqn:Hsplit.
         unshelve eassert (H':=split_vector_correct _ _). 6:rewrite Hsplit in H'. clear. abstract nia.
         cbn [fst snd] in H'. apply (f_equal (@vector_to_list _ _ )) in H'. rewrite vector_to_list_cast in H'. clear Hsplit.
         rewrite Vector.to_list_append in H'.
         revert v' vlst H'. replace (Init.Nat.min n (S n)) with n by nia. replace (S n - n) with 1 by nia.
         intros v' vlst eq. destruct_vector (* vlst as h *). cbn in eq.
         rewrite <- eq in Hlast,Hinit.
         replace v' with v in *.
         2:{ eapply VectorSpec.eq_nth_iff. intros i ? <-.
             unshelve eassert (Htmp:=Hinit (proj1_sig (Fin.to_nat i)) _). { now destruct Fin.to_nat. }
             destruct (Fin.to_nat i) eqn:Hi.
             rewrite map_app,<-!Vector.to_list_map in Htmp.
             rewrite nth_error_app1 in Htmp. 2:now rewrite Vector.length_to_list.
             cbn in Htmp. rewrite !vector_nth_error_nat in Htmp.
             destruct lt_dec. 2:easy.
             rewrite !nth_map' in Htmp. revert Htmp. intros [= Htmp].
             apply map_injective in Htmp. 2:congruence. apply DecodeTape.tape_encode_injective in Htmp.
             rewrite <- (Fin.of_nat_to_nat_inv i).  rewrite Hi;cbn.
             erewrite Fin.of_nat_ext. apply Htmp.
         }
         clear Hinit v'.
         rewrite skipn_app in Hlast. 2:now rewrite Vector.length_to_list. cbn in Hlast.
         autorewrite with list in Hlast. cbn in Hlast. revert Hlast. intros [= ->].
         edestruct H_HaltOrDiv as (?&?&?&?).
         2:now eauto.
         assert (Hts__size : sizeOfTape h <= maxSize).
         1:{ autorewrite with list in Hsize.  rewrite sizeOfTape_encodeTape in Hsize. unfold t__size in *.
             destruct (eqb_spec 0 maxSize);destruct sizeOfTape. all:cbn in Hsize;try nia. }
         clear Hsize. unfold initc in *. cbn in Hout.
         unshelve eassert (Htmp := LiftTapes_lift _ _). 11:{ now rewrite Hout. } now apply putEndAtFirst_dupfree.
         cbn in Htmp. unfold selectConf in Htmp. cbn in Htmp.

         erewrite putEndAtFirst_to_list in Htmp. 2:exact eq. eassumption.
    }
    2:{

      unfold f__steps.
      enough ((fun _ => 1) <=c f__nice).
      smpl upToC.
      1,2:smpl_upToC.
      3:{ [f__nice]: exact (fun '(x,y,z) => (fun s => s*s*S x) (S x + y + z)).
          subst f__nice.
          set (c:= 5*(S n) + 1).
          exists (c * c).
          intros [[x y] z].
          set (s:=S x+y+z).
          unshelve erewrite (_ : (x + y + 5) * S n + z <= c*s). 1:{ unfold s,c. nia. }
          nia.
      }
      all:unfold f__nice. all:smpl_upToC_solve.
    }

    assert (polyTimeComputable f__nice).
    {
      evar (time : nat -> nat). [time]:intros n0.
      eexists (fun x => time x).
      { unfold f__nice. extract. solverec.
        set (n0:=(L_facts.size (enc (a0, b0, b)))).
        assert (a0+b0+b+1 <= n0). 1:{ unfold n0. rewrite !size_prod. cbn [fst snd]. rewrite !size_nat_enc.
          unfold c__natsizeS, c__natsizeO; nia. }
        unfold add_time, mult_time.
        unshelve erewrite (_ : a0 <= n0). nia. unshelve erewrite (_ : b0 <= n0). nia. unshelve erewrite (_ : b <= n0). nia.
        unfold time. reflexivity. }
      1,2:unfold time;smpl_inO.
      { evar (f__size : nat -> nat). [f__size]:intros n0. exists f__size.
        { intros [[a0 b0] b]. unfold f__nice.
          set (n0:=(L_facts.size (enc (a0, b0, b)))).
          assert (a0+b0+b+1 <= n0). 1:{ unfold n0. rewrite !size_prod. cbn [fst snd]. rewrite !size_nat_enc.
            unfold c__natsizeS, c__natsizeO; nia. }
          rewrite size_nat_enc.
          unshelve erewrite (_ : a0 <= n0). nia. unshelve erewrite (_ : b0 <= n0). nia. unshelve erewrite (_ : b <= n0). nia.
          change S with (plus 1).
          unfold f__size;reflexivity.
        }
        all:unfold f__size;smpl_inO.
      }
    }
    clearbody f__nice.

    assert (polyTimeComputable t__size).
    {
      evar (c0 : nat).
      eexists (fun _ => c0).
      { unfold t__size. extract. solverec. all:rewrite eqbTime_le_l.
        all:set (c:=L_facts.size (enc 0)). all:cbv in c;subst c. all:subst c0. 2:easy. nia. }
      1,2:smpl_inO.
      { evar (f__size : nat -> nat). [f__size]:intros n0. exists f__size.
        { intros x. unfold t__size.
          set (n0:=(L_facts.size (enc x))).
          assert (Hx:x<=n0) by apply size_nat_enc_r.
          rewrite size_nat_enc. destruct _. 2:rewrite Hx;unfold f__size;reflexivity. unfold f__size. nia.
        }

        all:unfold f__size;smpl_inO.
      }
    }clearbody t__size.

    assert (polyTimeComputable t__start).
    {
      set (f:=fun s : sigTape sig => inr (sigList_X s)) in t__start.
      assert ( {f__c:UpToC (fun _ => 1) & computableTime' f (fun _ _ => (f__c tt,tt))}) as [t__f comp__f].
      {  evar (c:nat). exists_UpToC (fun _ => c). unfold f. clear_all. extract. solverec. [c]:exact 3. now unfold c. subst c. smpl_upToC_solve. }

      set (g:= (fun t : tape sig => inr sigList_cons :: map f (encode_tape t))) in t__start.
      assert ( {t__g:UpToC (fun t=> sizeOfTape t + 1) & computableTime' g (fun t _ => (t__g t,tt))}) as [t__g comp__g].
      {  evar (t__c: tape sig -> nat). [t__c]:intro. exists_UpToC t__c. unfold g.
         extract. solverec.
         rewrite map_time_const,sizeOfTape_encodeTape_le. all:unfold t__c. reflexivity. smpl_upToC_solve.
      }

      evar (time : nat -> nat). [time]:intros n0.
      eexists (fun x => time x).
      { unfold t__start. extract. solverec. rewrite (UpToC_le _).
        rewrite (correct__leUpToC (mapTime_upTo _)).
        rewrite length_concat,map_map. subst g. cbn -[plus mult]. setoid_rewrite map_length. rewrite Vector.length_to_list.
        erewrite sumn_map_le_pointwise  with (f2:=fun _ => _).
        2:{ intros;rewrite (UpToC_le t__g),sizeOfmTapes_upperBound;try reflexivity;now apply Vector.to_list_In. }
        erewrite sumn_map_le_pointwise with (f1:=fun x1 : tape sig => S (| encode_tape x1 |)) (f2:=fun _ => _).
        2:{ intros. setoid_rewrite sizeOfTape_encodeTape_le at 1. rewrite sizeOfmTapes_upperBound at 1. 2:now apply Vector.to_list_In.
            reflexivity. }
        rewrite sumn_map_c, Vector.length_to_list.
        rewrite sumn_map_c, Vector.length_to_list.
        rewrite sizeOfmTapes_by_size. set (L_facts.size _).
        unfold time. reflexivity.
      }
      1,2:now unfold time;change S with (plus 1);smpl_inO.
      { evar (f__size : nat -> nat). [f__size]:intros n0. exists f__size.
        { intros x. unfold t__start.
          rewrite size_list_cons. subst g f.
          rewrite Lists.size_list. rewrite map_app,concat_map,map_map. cbn. setoid_rewrite map_map. rewrite sumn_app.
          assert (H' : forall l, sumn (concat l) = sumn (map sumn l)). 1:{induction l;cbn;now autorewrite with list. }
          rewrite H',map_map. cbn. set (tmp:=size (enc (inr sigList_cons)));cbv in tmp;subst tmp.
          setoid_rewrite size_sum. rewrite size_boundary. setoid_rewrite size_sigList.
          repeat setoid_rewrite <- Nat.add_assoc.  ring_simplify. ring_simplify (7 + (4 + 5)).
          repeat setoid_rewrite sumn_map_add. repeat setoid_rewrite sumn_map_c. setoid_rewrite sumn_map_mult_c_r.
          setoid_rewrite sumn_map_le_pointwise with (f2:=fun x => _) at  3 4 5.
          2,3,4: (setoid_rewrite sizeOfTape_encodeTape_le;intros;rewrite sizeOfmTapes_upperBound at 1; [ | now apply Vector.to_list_In]; reflexivity).
          rewrite sumn_map_c.
          setoid_rewrite sumn_map_le_pointwise with (f2:=fun x => _).
          2:{ intros. setoid_rewrite sumn_map_le_pointwise with (f2:=fun x => _).
              2:{ intros. apply (correct__leUpToC (size_finType_any_le_c (X:=finType_CS (sigTape sig)))). }
              rewrite sumn_map_c. rewrite sizeOfTape_encodeTape_le,  sizeOfmTapes_upperBound. 2:now apply Vector.to_list_In. reflexivity. }
          rewrite sumn_map_c. rewrite Vector.length_to_list. setoid_rewrite sizeOfmTapes_by_size.
          set (n0:= L_facts.size _). ring_simplify. unfold f__size. reflexivity.
        }
        all:unfold f__size;smpl_inO.
      }
    }
    clearbody f__steps t__start.
(*    assert (polyTimeComputable (@sizeOfmTapes sig n)) by apply ptc_sizeOfmtapes. *)

    evar (time : nat -> nat). [time]:intros n0.
      eexists (fun x => time x).
      {
        extract. solverec.
        remember (L_facts.size (enc (a0, b0, b))) as n0 eqn:Hn0.
        rewrite !size_prod in Hn0. cbn [fst snd] in Hn0.
        erewrite (mono__polyTC X0 (x':=n0)). 2:{ subst n0. repeat set (L_facts.size _). nia. }
        rewrite (mono__polyTC X1 (x':=n0)). 2:{ subst n0. repeat set (L_facts.size _). nia. }
        set (c0 := 5+c__natsizeO +c__natsizeS).
        assert (H'' : L_facts.size (enc (b, sizeOfmTapes a0, b0)) <= n0*c0).
        {  rewrite !size_prod. cbn [fst snd]. setoid_rewrite size_nat_enc at 2.
            rewrite sizeOfmTapes_by_size. subst n0. repeat set (L_facts.size _). nia. }
        setoid_rewrite (mono__polyTC X (x':=n0*c0)). 2:exact H''.
        specialize (bounds__rSP (f:=f__nice)) as H'. setoid_rewrite <- size_nat_enc_r in H'.
        unfold mult_time, add_time.
        unshelve rewrite H'. now apply resSize__polyTC.
        setoid_rewrite mono__rSP. 2,3:exact H''.
        rewrite sizeOfmTapes_by_size at 1. unshelve erewrite (_ : L_facts.size (enc a0) <= n0). now (subst n0;clear;repeat set (L_facts.size _);nia).
        unfold time. reflexivity.
      }
      1,2:now unfold time;smpl_inO;apply inOPoly_comp;smpl_inO.
      { evar (f__size : nat -> nat). [f__size]:intros n0. exists f__size.
        { intros [[a0 b0] b]. remember (L_facts.size (enc (a0, b0, b))) as n0 eqn:Hn0.
          rewrite !size_prod in Hn0|-*. cbn [fst snd] in Hn0|-*. rewrite !size_nat_enc.
          assert (H'' : L_facts.size (enc (b, sizeOfmTapes a0, b0)) <= n0*(5 + c__natsizeS + c__natsizeO)).
        {  rewrite !size_prod. cbn [fst snd]. setoid_rewrite size_nat_enc at 2.
           rewrite sizeOfmTapes_by_size. subst n0. repeat set (L_facts.size _). nia. }
        specialize (bounds__rSP (f:=f__nice)) as H'. setoid_rewrite <- size_nat_enc_r in H'.
        unshelve rewrite H'. now apply resSize__polyTC.
        setoid_rewrite mono__rSP. 2:exact H''.

        specialize (bounds__rSP (f:=t__size)) as Hsize. setoid_rewrite <- size_nat_enc_r in Hsize at 1.
        unshelve rewrite Hsize. now apply resSize__polyTC.
        setoid_rewrite (mono__rSP _ (x':=n0)) at 1 . 2:nia.

        specialize (bounds__rSP (f:=t__start)) as Hstart.
        unshelve rewrite Hstart. now apply resSize__polyTC.
        setoid_rewrite (mono__rSP _ (x':=n0)) at 1 . 2:subst;clear;repeat (set (L_facts.size _));nia.
        unfold f__size. reflexivity.
        }
        1,2:unfold f__size;smpl_inO; apply inOPoly_comp;smpl_inO.

      }

  Qed.

  (* Print Assumptions LMGenNP_to_TMGenNP_mTM. *)

End LMGenNP_to_TMGenNP_mTM.