Require Import List.
Import ListNotations.

Require oeuf.SourceValues.
Require oeuf.HighestValues.
Require oeuf.HigherValue.
Require oeuf.HighValues.

Require oeuf.MatchValues.

Require Import StructTact.StructTactics.
Require Import oeuf.StuartTact.

Inductive value_level : Set :=
| VlSource
        (G : list (SourceValues.type * list SourceValues.type * SourceValues.type))
        (ty : SourceValues.type)
| VlHighest
| VlHigher
| VlHighFname (* HighValues, using sequential indexes for function names *)
| VlHigh
.

Definition value_type vl : Type :=
    match vl with
    | VlSource G ty => SourceValues.value G ty
    | VlHighest => HighestValues.value
    | VlHigher => HigherValue.value
    | VlHighFname => HighValues.value
    | VlHigh => HighValues.value
    end.

Definition value_match_indexed M vl1 vl2 : value_type vl1 -> value_type vl2 -> Prop :=
    match vl1, vl2 with

    (* zero steps *)
    | VlSource G1 ty1, VlSource G2 ty2 =>
            fun v1 v2 => existT _ G1 (existT _ ty1 v1) = existT _ G2 (existT _ ty2 v2)
                    :> { G : _ & { ty : _ & SourceValues.value G ty } }
    | VlHighest, VlHighest => eq
    | VlHigher, VlHigher => eq
    | VlHighFname, VlHighFname => eq
    | VlHigh, VlHigh => eq

    (* one step *)
    | VlSource G ty, VlHighest => fun v1 v2 => MatchValues.compile_highest v1 = v2
    | VlHighest, VlHigher => MatchValues.mv_higher
    | VlHigher, VlHighFname => MatchValues.mv_high
    | VlHighFname, VlHigh => MatchValues.mv_fmajor M

    (* two steps *)
    | VlSource G ty, VlHigher => fun v1 v3 => exists v2,
            MatchValues.compile_highest v1 = v2 /\
            MatchValues.mv_higher v2 v3
    | VlHighest, VlHighFname => fun v1 v3 => exists v2,
            MatchValues.mv_higher v1 v2 /\
            MatchValues.mv_high v2 v3
    | VlHigher, VlHigh => fun v1 v3 => exists v2,
            MatchValues.mv_high v1 v2 /\
            MatchValues.mv_fmajor M v2 v3

    (* three steps *)
    | VlSource G ty, VlHighFname => fun v1 v4 => exists v2 v3,
            MatchValues.compile_highest v1 = v2 /\
            MatchValues.mv_higher v2 v3 /\
            MatchValues.mv_high v3 v4
    | VlHighest, VlHigh => fun v1 v4 => exists v2 v3,
            MatchValues.mv_higher v1 v2 /\
            MatchValues.mv_high v2 v3 /\
            MatchValues.mv_fmajor M v3 v4

    (* four steps *)
    | VlSource G ty, VlHigh => fun v1 v5 => exists v2 v3 v4,
            MatchValues.compile_highest v1 = v2 /\
            MatchValues.mv_higher v2 v3 /\
            MatchValues.mv_high v3 v4 /\
            MatchValues.mv_fmajor M v4 v5

    (* anything else *)
    | _, _ => fun _ _ => False
    end.

(* Like value_match_indexed, but all cases usind indices are deleted. *)
Definition value_match vl1 vl2 : value_type vl1 -> value_type vl2 -> Prop :=
    match vl1, vl2 with

    (* zero steps *)
    | VlSource G1 ty1, VlSource G2 ty2 =>
            fun v1 v2 => existT _ G1 (existT _ ty1 v1) = existT _ G2 (existT _ ty2 v2)
                    :> { G : _ & { ty : _ & SourceValues.value G ty } }
    | VlHighest, VlHighest => eq
    | VlHigher, VlHigher => eq
    | VlHighFname, VlHighFname => eq
    | VlHigh, VlHigh => eq

    (* one step *)
    | VlSource G ty, VlHighest => fun v1 v2 => MatchValues.compile_highest v1 = v2
    | VlHighest, VlHigher => MatchValues.mv_higher
    | VlHigher, VlHighFname => MatchValues.mv_high

    (* two steps *)
    | VlSource G ty, VlHigher => fun v1 v3 => exists v2,
            MatchValues.compile_highest v1 = v2 /\
            MatchValues.mv_higher v2 v3
    | VlHighest, VlHighFname => fun v1 v3 => exists v2,
            MatchValues.mv_higher v1 v2 /\
            MatchValues.mv_high v2 v3

    (* three steps *)
    | VlSource G ty, VlHighFname => fun v1 v4 => exists v2 v3,
            MatchValues.compile_highest v1 = v2 /\
            MatchValues.mv_higher v2 v3 /\
            MatchValues.mv_high v3 v4

    (* four steps *)

    (* anything else *)
    | _, _ => fun _ _ => False
    end.

Definition value_level_le_indexed vl1 vl2 : Prop :=
    match vl1, vl2 with

    (* zero steps *)
    | VlSource G1 ty1, VlSource G2 ty2 => G1 = G2 /\ ty1 = ty2
    | VlHighest, VlHighest => True
    | VlHigher, VlHigher => True
    | VlHighFname, VlHighFname => True
    | VlHigh, VlHigh => True

    (* one step *)
    | VlSource _ _, VlHighest => True
    | VlHighest, VlHigher => True
    | VlHigher, VlHighFname => True
    | VlHighFname, VlHigh => True

    (* two steps *)
    | VlSource _ _, VlHigher => True
    | VlHighest, VlHighFname => True
    | VlHigher, VlHigh => True

    (* three steps *)
    | VlSource _ _, VlHighFname => True
    | VlHighest, VlHigh => True

    (* four steps *)
    | VlSource _ _, VlHigh => True

    (* anything else *)
    | _, _ => False
    end.

Definition value_level_le vl1 vl2 : Prop :=
    match vl1, vl2 with

    (* zero steps *)
    | VlSource G1 ty1, VlSource G2 ty2 => G1 = G2 /\ ty1 = ty2
    | VlHighest, VlHighest => True
    | VlHigher, VlHigher => True
    | VlHighFname, VlHighFname => True
    | VlHigh, VlHigh => True

    (* one step *)
    | VlSource _ _, VlHighest => True
    | VlHighest, VlHigher => True
    | VlHigher, VlHighFname => True

    (* two steps *)
    | VlSource _ _, VlHigher => True
    | VlHighest, VlHighFname => True

    (* three steps *)
    | VlSource _ _, VlHighFname => True

    (* four steps *)

    (* anything else *)
    | _, _ => False
    end.

Lemma value_match_indexed_compose : forall M vl1 vl2 vl3 v1 v2 v3,
    value_match_indexed M vl1 vl2 v1 v2 ->
    value_match_indexed M vl2 vl3 v2 v3 ->
    value_match_indexed M vl1 vl3 v1 v3.
destruct vl1, vl2, vl3; intros ? ? ? Hm1 Hm2; simpl in *; subst;
try fix_existT; repeat (break_exists || break_and);
try solve [eauto | exfalso; eauto | firstorder congruence].
Qed.

Lemma value_match_indexed_decompose : forall M vl1 vl2 vl3 v1 v3,
    value_match_indexed M vl1 vl3 v1 v3 ->
    value_level_le_indexed vl1 vl2 ->
    value_level_le_indexed vl2 vl3 ->
    exists v2, value_match_indexed M vl1 vl2 v1 v2 /\ value_match_indexed M vl2 vl3 v2 v3.
destruct vl1, vl2, vl3; intros ? ? ? Hle1 Hle2;
try solve [inversion Hle1 | inversion Hle2];
simpl in *; repeat (break_exists || break_and); subst; eauto 9.
Qed.

Lemma value_match_compose : forall vl1 vl2 vl3 v1 v2 v3,
    value_match vl1 vl2 v1 v2 ->
    value_match vl2 vl3 v2 v3 ->
    value_match vl1 vl3 v1 v3.
destruct vl1, vl2, vl3; intros ? ? ? Hm1 Hm2; simpl in *; subst;
try fix_existT; repeat (break_exists || break_and);
try solve [eauto | exfalso; eauto | firstorder congruence].
Qed.

Lemma value_match_decompose : forall vl1 vl2 vl3 v1 v3,
    value_match vl1 vl3 v1 v3 ->
    value_level_le_indexed vl1 vl2 ->
    value_level_le_indexed vl2 vl3 ->
    exists v2, value_match vl1 vl2 v1 v2 /\ value_match vl2 vl3 v2 v3.
destruct vl1, vl2, vl3; intros ? ? Hm Hle1 Hle2;
try solve [inversion Hle1 | inversion Hle2 | inversion Hm];
simpl in *; repeat (break_exists || break_and); subst; eauto 9.
Qed.

Lemma value_level_le_indexed_refl : forall vl,
    value_level_le_indexed vl vl.
destruct vl; simpl; eauto.
Qed.

Lemma value_level_le_indexed_trans : forall vl1 vl2 vl3,
    value_level_le_indexed vl1 vl2 ->
    value_level_le_indexed vl2 vl3 ->
    value_level_le_indexed vl1 vl3.
destruct vl1, vl2; simpl; try solve [intros ? ?; exfalso; eassumption].
all: destruct vl3; simpl; try solve [intros ? ?; exfalso; eassumption].
all: intros; eauto.

firstorder congruence.
Qed.

Lemma value_level_le_refl : forall vl,
    value_level_le vl vl.
destruct vl; simpl; eauto.
Qed.

Lemma value_level_le_trans : forall vl1 vl2 vl3,
    value_level_le vl1 vl2 ->
    value_level_le vl2 vl3 ->
    value_level_le vl1 vl3.
destruct vl1, vl2; simpl; try solve [intros ? ?; exfalso; eassumption].
all: destruct vl3; simpl; try solve [intros ? ?; exfalso; eassumption].
all: intros; eauto.

firstorder congruence.
Qed.

Lemma value_level_le_add_index : forall vl1 vl2,
    value_level_le vl1 vl2 ->
    value_level_le_indexed vl1 vl2.
destruct vl1, vl2; simpl; intro; eauto.
Qed.

Lemma value_match_remove_index : forall M vl1 vl2 v1 v2,
    value_level_le vl1 vl2 ->
    value_match_indexed M vl1 vl2 v1 v2 ->
    value_match vl1 vl2 v1 v2.
intros0 Hvm.
destruct vl1, vl2; simpl in *; eauto.
Qed.

Lemma value_match_add_index : forall M vl1 vl2 v1 v2,
    value_match vl1 vl2 v1 v2 ->
    value_match_indexed M vl1 vl2 v1 v2.
intros0 Hvm. intros.
destruct vl1, vl2; simpl in *; eauto; try solve [exfalso; eauto].
Qed.

Lemma value_match_add_index_iff : forall M vl1 vl2 v1 v2,
    value_level_le vl1 vl2 ->
    value_match vl1 vl2 v1 v2 <->
    value_match_indexed M vl1 vl2 v1 v2.
intros; split; eauto using value_match_add_index, value_match_remove_index.
Qed.


Require Import Coqlib.
Require Import Asm.
Require Import PeekTactics.
Require Import PeepsLib.
Require Import Integers.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.

Module Imp.

(* dummy addrmode *)
Definition da : addrmode := Addrmode None None (inl Int.zero).

Definition peep_vec_mull_example :=
            Pmovsd_fm XMM0 da ::
            Pmovsd_fm XMM0 da ::
            Pmuld_ff XMM0 XMM0 ::
            Pmovsd_fm XMM0 da ::
            Pmovsd_fm XMM0 da ::
            Pmuld_ff XMM0 XMM0 ::
            Pmovsd_fm XMM0 da ::
            Pmovsd_fm XMM0 da ::
            Pmuld_ff XMM0 XMM0 ::
            Pmovsd_fm XMM0 da ::
            Pmovsd_fm XMM0 da ::
            Pmuld_ff XMM0 XMM0 ::
            Pmovsd_mf da XMM0 ::
            Pmovsd_mf da XMM0 ::
            Pmovsd_mf da XMM0 ::
            Pmovsd_mf da XMM0 ::
            nil.

Section VEC_MULL.

  Variable concrete : code.
  Variable r1 r2 r3 r4 r5 r6 r7 r8 : freg.
  Variable a b c : addrmode.

  Definition a8 := addr_add a 8.
  Definition a16 := addr_add a 16.
  Definition a24 := addr_add a 24.

  Definition b8 := addr_add b 8.
  Definition b16 := addr_add b 16.
  Definition b24 := addr_add b 24.

  Definition c8 := addr_add c 8.
  Definition c16 := addr_add c 16.
  Definition c24 := addr_add c 24.

  Definition make_bfreg (f : freg) : bfreg :=
    match f with
      | XMM0 => xmm0
      | XMM1 => xmm1
      | XMM2 => xmm2
      | XMM3 => xmm3
      | XMM4 => xmm4
      | XMM5 => xmm5
      | XMM6 => xmm6
      | XMM7 => xmm7
    end.

  Definition get_high_reg (b : bfreg) : hfreg :=
    let (_,h) := split_big_freg b in h.

  Definition br1 := make_bfreg r1.
  Definition br2 := make_bfreg r2.
  Definition br3 := make_bfreg r3.
  Definition br4 := make_bfreg r4.
  Definition br5 := make_bfreg r5.
  Definition br6 := make_bfreg r6.
  Definition br7 := make_bfreg r7.
  Definition br8 := make_bfreg r8.
  Definition hr1 := get_high_reg br1.
  Definition hr2 := get_high_reg br2.
  Definition hr3 := get_high_reg br3.
  Definition hr4 := get_high_reg br4.
  Definition hr5 := get_high_reg br5.
  Definition hr6 := get_high_reg br6.
  Definition hr7 := get_high_reg br7.
  Definition hr8 := get_high_reg br8.

  Definition peep_vec_mull_defs : rewrite_defs :=
    {|
      fnd :=
            Pmovsd_fm r1 a ::
            Pmovsd_fm r2 b ::
            Pmuld_ff r1 r2 ::
            Pmovsd_fm r3 a8 ::
            Pmovsd_fm r4 b8 ::
            Pmuld_ff r3 r4 ::
            Pmovsd_fm r5 a16 ::
            Pmovsd_fm r6 b16 ::
            Pmuld_ff r5 r6 ::
            Pmovsd_fm r7 a24 ::
            Pmovsd_fm r8 b24 ::
            Pmuld_ff r7 r8 ::
            Pmovsd_mf c r1 ::
            Pmovsd_mf c8 r3 ::
            Pmovsd_mf c16 r5 ::
            Pmovsd_mf c24 r7 ::
            nil
      ; rpl :=
          Pmovups_rm br1 a ::
          Pmovups_rm br2 b ::
          Pmulpd_ff br1 br2 ::
          Pmovups_rm br3 a16 ::
          Pmovups_rm br4 b16 ::
          Pmulpd_ff br3 br4 ::
          Pmovups_mr c br1 ::
          Pmovups_mr c16 br3 ::
          Pnop :: Pnop :: Pnop :: Pnop ::
          Pnop :: Pnop :: Pnop :: Pnop :: nil
      ; lv_in :=
          PC :: nil
      ; lv_out :=
          PC :: nil
      ; clobbered :=
          nil
    |}.

  Lemma peep_vec_mull_selr :
    StepEquiv.step_through_equiv_live (fnd peep_vec_mull_defs) (rpl peep_vec_mull_defs) (lv_in peep_vec_mull_defs) (lv_out peep_vec_mull_defs).
  Proof.
    prep_l.
    step_l.
    step_l.
    step_l.
    step_l.
    step_l.
    step_l.
    step_l.
    step_l.
    step_l.
    step_l.
    step_l.
    step_l.
    step_l.
    step_l.
    step_l.
    step_l.
    prep_r.
    (* step_r. *)
    prep_exec_instr.
    {
      clear -H.
      assert False by admit.
      exfalso.
      assumption.
    }
    repeat break_exists.
    specialize (H4 x3).

    step_r.

    prep_exec_instr.
    {
      clear -H.
      assert False by admit.
      exfalso.
      assumption.
    }
    repeat break_exists.
    specialize (H20 x3).
    step_r.

    prep_exec_instr.
    {
      clear -H.
      assert False by admit.
      exfalso.
      assumption.
    }
    repeat break_exists.
    specialize (H35 x3).
    step_r.

    prep_exec_instr.
    {
      clear -H.
      assert False by admit.
      exfalso.
      assumption.
    }
    repeat break_exists.
    specialize (H50 x3).
    step_r.

    prep_exec_instr.
    {
      clear -H.
      assert False by admit.
      exfalso.
      assumption.
    }
    repeat break_exists.
    specialize (H64 x3).
    step_r.

    prep_exec_instr.
    {
      clear -H.
      assert False by admit.
      exfalso.
      assumption.
    }
    repeat break_exists.
    specialize (H77 x3).
    step_r.

    prep_exec_instr.
    {
      clear -H.
      assert False by admit.
      exfalso.
      assumption.
    }
    repeat break_exists.
    specialize (H92 x3).
    step_r.

    prep_exec_instr.
    {
      clear -H.
      assert False by admit.
      exfalso.
      assumption.
    }
    repeat break_exists.
    specialize (H106 x3).
    step_r.

    prep_exec_instr.
    {
      clear -H.
      assert False by admit.
      exfalso.
      assumption.
    }
    repeat break_exists.
    specialize (H134 x3).
    step_r.

    step_r.
    step_r.
    step_r.
    step_r.
    step_r.
    step_r.
    step_r.

    assert (x43 = md').
    exploit step_through_md; eauto.
    unfold peep_code.
    simpl.
    intros.
    repeat break_or; simpl; tauto.
    subst x43.

    finish_r.
    admit.
  Qed.

  Definition peep_vec_mull_proofs : rewrite_proofs :=
    {|
      defs := peep_vec_mull_defs
      ; selr := peep_vec_mull_selr
    |}.

  Definition peep_vec_mull :
    concrete = fnd peep_vec_mull_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite' peep_vec_mull_defs peep_vec_mull_proofs; admit.
  Qed.

End VEC_MULL.

Definition peep_vec_mull_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_vec_mull p.
  unfold peep_vec_mull_defs in p.
  simpl in p.
  specialize (p c).
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_nil c.
  set_instr_eq i 0%nat peep_vec_mull_example.
  set_instr_eq i0 1%nat peep_vec_mull_example.
  set_instr_eq i1 2%nat peep_vec_mull_example.
  set_instr_eq i2 3%nat peep_vec_mull_example.
  set_instr_eq i3 4%nat peep_vec_mull_example.
  set_instr_eq i4 5%nat peep_vec_mull_example.
  set_instr_eq i5 6%nat peep_vec_mull_example.
  set_instr_eq i6 7%nat peep_vec_mull_example.
  set_instr_eq i7 8%nat peep_vec_mull_example.
  set_instr_eq i8 9%nat peep_vec_mull_example.
  set_instr_eq i9 10%nat peep_vec_mull_example.
  set_instr_eq i10 11%nat peep_vec_mull_example.
  set_instr_eq i11 12%nat peep_vec_mull_example.
  set_instr_eq i12 13%nat peep_vec_mull_example.
  set_instr_eq i13 14%nat peep_vec_mull_example.
  set_instr_eq i14 15%nat peep_vec_mull_example.

  Require Import AddrmodeEq.
  destruct (addrmode_eq a1 (addr_add a 8)); [|exact None].
  destruct (addrmode_eq a3 (addr_add a 16)); [|exact None].
  destruct (addrmode_eq a5 (addr_add a 24)); [|exact None].
  destruct (addrmode_eq a2 (addr_add a0 8)); [|exact None].
  destruct (addrmode_eq a4 (addr_add a0 16)); [|exact None].
  destruct (addrmode_eq a6 (addr_add a0 24)); [|exact None].
  destruct (addrmode_eq a9 (addr_add a7 8)); [|exact None].
  destruct (addrmode_eq a10 (addr_add a7 16)); [|exact None].
  destruct (addrmode_eq a11 (addr_add a7 24)); [|exact None].

  subst.
  unfold a8 in *.
  unfold b8 in *.
  unfold c8 in *.
  unfold a16 in *.
  unfold b16 in *.
  unfold c16 in *.
  unfold a24 in *.
  unfold b24 in *.
  unfold c24 in *.
  destruct (preg_eq rd rd1); [|exact None].
  destruct (preg_eq rd0 r1); [|exact None].
  destruct (preg_eq rd2 rd4); [|exact None].
  destruct (preg_eq rd3 r0); [|exact None].
  destruct (preg_eq rd5 rd7); [|exact None].
  destruct (preg_eq rd6 r2); [|exact None].
  destruct (preg_eq rd8 rd10); [|exact None].
  destruct (preg_eq rd9 r3); [|exact None].
  destruct (preg_eq r4 rd1); [|exact None].
  destruct (preg_eq r5 rd4); [|exact None].
  destruct (preg_eq r6 rd7); [|exact None].
  destruct (preg_eq r7 rd10); [|exact None].
  inv e. inv e0.
  inv e1. inv e2.
  inv e3. inv e4.
  inv e5. inv e6.
  inv e7. inv e8.
  inv e9. inv e10.
  specialize (p rd1 r1).
  specialize (p rd4 r0).
  specialize (p rd7 r2).
  specialize (p rd10 r3).
  specialize (p a a0 a7).
  specialize (p eq_refl).
  exact (Some p).
Qed.

End Imp.


Require Import Process Refinement ModelCheck.

Module Done.
  Definition chs : channels := fun _ => nat.

  Definition pr : process chs := Done.

  Theorem pr_pr : refines pr pr.
  Proof.
    mc.
  Qed.
End Done.

Module DoneSend.
  Definition chs : channels := fun _ => nat.

  Definition pr1 : process chs := Done.

  Definition pr2 : process chs := #!chs["X", 0], Done.

  Theorem pr1_pr2 : refines pr1 pr2.
  Proof.
    mc.
  Qed.
End DoneSend.

Module Send.
  Definition chs : channels := fun _ => nat.

  Definition pr : process chs := #!chs["X", 0], Done.

  Theorem pr_pr : refines pr pr.
  Proof.
    mc.
  Qed.
End Send.

Module Recv.
  Definition chs : channels := fun _ => nat.

  Definition pr : process chs := #?chs["X", x], Done.

  Theorem pr_pr : refines pr pr.
  Proof.
    mc.
  Qed.
End Recv.

Module RecvSend.
  Definition chs : channels := fun _ => nat.

  Definition pr : process chs := #?chs["X", x], #!chs["Y", x], Done.

  Theorem pr_pr : refines pr pr.
  Proof.
    mc.
  Qed.
End RecvSend.

Module ComputeRhs.
  Definition chs : channels := fun _ => nat.

  Definition pr1 : process chs := #!chs["X", 0], Done.

  Definition pr2 : process chs := (#?chs["Y", v], #!chs["X", v], Done) || (#!chs["Y", 0], Done).

  Theorem pr1_pr2 : refines pr1 pr2.
  Proof.
    mc.
  Qed.
End ComputeRhs.

Module SwapSend.
  Definition chs : channels := fun _ => nat.

  Definition pr1 : process chs := (#!chs["X", 0], Done) || (#!chs["Y", 1], Done).

  Definition pr2 : process chs := (#!chs["Y", 1], Done) || (#!chs["X", 0], Done).

  Theorem pr1_pr2 : refines pr1 pr2.
  Proof.
    mc.
  Qed.
End SwapSend.

Module SwapSendRecv.
  Definition chs : channels := fun _ => nat.

  Definition pr1 : process chs := (#!chs["X", 0], Done) || (#?chs["Y", x], #!chs["Z", x], Done).

  Definition pr2 : process chs := (#?chs["Y", x], #!chs["Z", x], Done) || (#!chs["X", 0], Done).

  Theorem pr1_pr2 : refines pr1 pr2.
  Proof.
    mc.
  Qed.
End SwapSendRecv.

Module WithSelf.
  Definition chs : channels := fun _ => nat.

  Definition pr1 : process chs := ##[(Send, "X")],
    (#?chs["Y", x], #!chs["X", S x], Done)
    || (#!chs["Y", 0], Done).

  Definition pr2 : process chs := #!chs["X", 1], Done.

  Theorem pr1_pr2 : refines pr1 pr2.
  Proof.
    mc.
  Qed.
End WithSelf.

Module WithMoreSelf.
  Definition chs : channels := fun _ => nat.

  Definition pr1 : process chs := ##[(Send, "X")],
    (#?chs["Y", x], #!chs["X", S x], Done)
    || (#!chs["Y", 0], Done)
    || (#!chs["Y", 1], Done).

  Definition pr2 : process chs :=
    (#!chs["X", 2], Done)
    || (#!chs["X", 1], Done).

  Theorem pr1_pr2 : refines pr1 pr2.
  Proof.
    mc.
  Qed.
End WithMoreSelf.

Module DependentTypingAhoy.
  Definition chs : channels := fun s => if string_dec s "B" then bool else nat.

  Definition pr1 : process chs := ##[(Recv, "B"), (Send, "X")],
    (#?chs["B", b], #?chs["N", n], if b then #!chs["X", 42], Done else #!chs["X", n], Done)
    || (#!chs["N", 13], Done).

  Definition pr2 : process chs :=
    #?chs["B", b], if b then #!chs["X", 42], Done else #!chs["X", 13], Done.

  Theorem pr1_pr2 : refines pr1 pr2.
  Proof.
    mc.
  Qed.
End DependentTypingAhoy.

Module RecvSendRestr.
  Definition chs : channels := fun _ => nat.

  Definition pr : process chs := ##[(Recv, "X"), (Send, "Y")], #?chs["X", x], #!chs["Y", x], Done.

  Theorem pr_pr : refines pr pr.
  Proof.
    mc.
  Qed.
End RecvSendRestr.


(* THIS FILE CONTAINS
   Lemmas that DO NOT depend on CompCert or Verifiable C,
   and that are used in the proof of the C program but are not
   used in the proof of functional_prog.v.
*)

Require Recdef.
Require Import Integers.
Require Coq.Strings.String.
Require Coq.Strings.Ascii.
(* Add LoadPath "~/Desktop/Code/research/vst/compcert/lib". *)
Require Import Coqlib.
(* Add LoadPath "~/Desktop/Code/research/compcert-2.4/lib". *)
(* Require Import compcert.lib.Coqlib. *)
Require Import List.
(* Pwd. *)
(* Add LoadPath "~/Desktop/Code/research/vst/sha". *)
(* Require Import sha.SHA256. *)
Require Import SHA256.
(* Add LoadPath "~/Desktop/Code/research/vst/msl". *)
Require Import Coqlib2.         (* formerly msl.Coqlib2 *)
Require Export common_lemmas.
(* TODO fix *)
Require Psatz.

Global Opaque CBLOCKz LBLOCKz.

Lemma int_min_signed_eq: Int.min_signed = -2147483648.
Proof. reflexivity. Qed.

Lemma int_max_signed_eq: Int.max_signed = 2147483647.
Proof. reflexivity. Qed.

Lemma int_max_unsigned_eq: Int.max_unsigned = 4294967295.
Proof. reflexivity. Qed.

Ltac repable_signed :=
   pose proof int_min_signed_eq;
   pose proof int_max_signed_eq;
   pose proof int_max_unsigned_eq;
(*   unfold repable_signed in *; *)
   omega.

Hint Rewrite Int.bits_or using omega : testbit.
Hint Rewrite Int.bits_shl using omega : testbit.
Hint Rewrite Int.bits_and using omega : testbit.
Hint Rewrite Int.bits_shru using omega : testbit.
Hint Rewrite Int.unsigned_repr using omega : testbit.
Hint Rewrite Int.testbit_repr using omega : testbit.
Hint Rewrite if_false using omega : testbit.
Hint Rewrite if_true using omega : testbit.
Hint Rewrite Z.ones_spec_low using omega : testbit.
Hint Rewrite Z.ones_spec_high using omega : testbit.
Hint Rewrite orb_false_r orb_true_r andb_false_r andb_true_r : testbit.
Hint Rewrite orb_false_l orb_true_l andb_false_l andb_true_l : testbit.
Hint Rewrite Z.add_simpl_r : testbit.
Hint Rewrite Int.unsigned_repr using repable_signed : testbit.

Lemma Ztest_Inttest:
 forall a, Z.testbit (Int.unsigned a) = Int.testbit a.
Proof. reflexivity. Qed.
Hint Rewrite Ztest_Inttest : testbit.

Definition swap (i: int) : int :=
 Int.or (Int.shl (Int.and i (Int.repr 255)) (Int.repr 24))
   (Int.or (Int.shl (Int.and (Shr 8 i) (Int.repr 255)) (Int.repr 16))
      (Int.or (Int.shl (Int.and (Shr 16 i) (Int.repr 255)) (Int.repr 8))
         (Shr 24 i))).

Lemma swap_swap: forall w, swap (swap w) = w.
Proof.
unfold swap, Shr; intros.
apply Int.same_bits_eq; intros.
assert (Int.zwordsize=32) by reflexivity.
change 255 with (Z.ones 8).
assert (32 < Int.max_unsigned) by (compute; auto).
autorewrite with testbit.
if_tac; [if_tac; [if_tac | ] | ]; autorewrite with testbit; f_equal; omega.
Qed.

Lemma map_swap_involutive:
 forall l, map swap (map swap l)  = l.
Proof. intros.
 rewrite map_map.
 replace (fun x => swap (swap x)) with (@Datatypes.id int).
 apply map_id. extensionality x. symmetry; apply swap_swap.
Qed.

Lemma isbyteZ_testbit:
  forall i j, 0 <= i < 256 -> j >= 8 -> Z.testbit i j = false.
Proof.
intros; erewrite Byte.Ztestbit_above with (n:=8%nat); auto.
Qed.

Lemma length_intlist_to_Zlist:
  forall l, length (intlist_to_Zlist l) = (4 * length l)%nat.
Proof.
induction l.
simpl. reflexivity. simpl. omega.
Qed.

Lemma Zlength_intlist_to_Zlist: forall l,
  Zlength (intlist_to_Zlist l) = WORD*Zlength l.
Proof.
intros. repeat rewrite Zlength_correct. rewrite length_intlist_to_Zlist.
rewrite Nat2Z.inj_mul. reflexivity.
Qed.

Lemma intlist_to_Zlist_Z_to_int_cons:
  forall a b c d l,
      isbyteZ a -> isbyteZ b -> isbyteZ c -> isbyteZ d ->
     intlist_to_Zlist (Z_to_Int a b c d :: l) =
     a::b::c::d:: intlist_to_Zlist l.
Proof.
intros. simpl.
unfold isbyteZ in *.
assert (Int.zwordsize=32)%Z by reflexivity.
unfold Z_to_Int, Shr; simpl.
change 255%Z with (Z.ones 8).
repeat f_equal; auto;
match goal with |- _ = ?A => transitivity (Int.unsigned (Int.repr A));
   [f_equal | apply Int.unsigned_repr; repable_signed]
end;
apply Int.same_bits_eq; intros;
autorewrite with testbit.
*
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
rewrite (isbyteZ_testbit b) by omega.
rewrite (isbyteZ_testbit c) by omega.
rewrite (isbyteZ_testbit d) by omega.
autorewrite with testbit; auto.
*
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
rewrite (isbyteZ_testbit c) by omega.
rewrite (isbyteZ_testbit d) by omega.
autorewrite with testbit; auto.
*
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
rewrite (isbyteZ_testbit d) by omega.
autorewrite with testbit; auto.
*
destruct (zlt i 8); autorewrite with testbit;  [ | symmetry; apply isbyteZ_testbit; omega].
auto.
Qed.

Lemma Zlist_to_intlist_to_Zlist:
  forall nl: list Z,
  NPeano.divide (Z.to_nat WORD) (length nl) ->
  Forall isbyteZ nl ->
  intlist_to_Zlist (Zlist_to_intlist nl) = nl.
Proof.
intros nl [k H].
revert nl H; induction k; intros.
destruct nl; inv H; reflexivity.
simpl in H.
destruct nl as [ | a [ | b [ | c [ | d ?]]]]; inv H.
inv H0. inv H4. inv H5. inv H6.
unfold Zlist_to_intlist; fold Zlist_to_intlist.
rewrite intlist_to_Zlist_Z_to_int_cons by auto.
repeat f_equal; auto.
Qed.

Lemma intlist_to_Zlist_to_intlist:
  forall il: list int,
   Zlist_to_intlist (intlist_to_Zlist il) = il.
Proof.
induction il.
reflexivity.
simpl.
f_equal; auto. clear.
assert (Int.zwordsize=32)%Z by reflexivity.
unfold Z_to_Int, Shr; simpl.
change 255%Z with (Z.ones 8).
apply Int.same_bits_eq; intros.
rewrite Int.repr_unsigned.
autorewrite with testbit.
if_tac; autorewrite with testbit; [ | f_equal; omega].
if_tac; autorewrite with testbit; [ | f_equal; omega].
if_tac; autorewrite with testbit; [ | f_equal; omega].
auto.
Qed.

Lemma length_Zlist_to_intlist: forall n l,
       length l = (Z.to_nat WORD * n)%nat ->
       length (Zlist_to_intlist l) = n.
Proof.
induction n; intros.
destruct l; inv H; reflexivity.
replace (S n) with (1 + n)%nat in H by omega.
rewrite mult_plus_distr_l in H.
destruct l as [|i0 l]; [ inv H |].
destruct l as [|i1 l]; [ inv H |].
destruct l as [|i2 l]; [ inv H |].
destruct l as [|i3 l]; [ inv H |].
simpl. f_equal. apply IHn. forget (Z.to_nat WORD * n)%nat as A. inv H; auto.
Qed.

Lemma big_endian_integer_ext:
 forall f f', (forall z, (0 <= z < WORD)%Z -> f z = f' z) ->
    big_endian_integer f = big_endian_integer f'.
Proof.
unfold big_endian_integer;
intros.
repeat f_equal; intros; apply H; repeat split; compute; auto; congruence.
Qed.

Local Open Scope nat.

Definition LBLOCK : nat := Z.to_nat LBLOCKz.
Definition CBLOCK : nat := Z.to_nat CBLOCKz.
Opaque LBLOCK CBLOCK.

Lemma LBLOCK_zeq: Z.of_nat LBLOCK = 16%Z.
Proof. reflexivity. Qed.

Lemma CBLOCK_zeq: (Z.of_nat CBLOCK = 64%Z).
Proof. reflexivity. Qed.

Lemma LBLOCKz_nonneg: (0 <= LBLOCKz)%Z.
Proof. change LBLOCKz with 16%Z; omega. Qed.
Hint Resolve LBLOCKz_nonneg.

Lemma LBLOCKz_pos: (0 < LBLOCKz)%Z.
Proof. change LBLOCKz with 16%Z; omega. Qed.
Hint Resolve LBLOCKz_pos.

Lemma CBLOCKz_nonneg: (0 <= CBLOCKz)%Z.
Proof. change CBLOCKz with 64%Z; omega. Qed.
Hint Resolve CBLOCKz_nonneg.

Lemma CBLOCKz_pos: (0 < CBLOCKz)%Z.
Proof. change CBLOCKz with 64%Z; omega. Qed.
Hint Resolve CBLOCKz_pos.

Lemma intlist_to_Zlist_app:
 forall al bl, intlist_to_Zlist (al++bl) = intlist_to_Zlist al ++ intlist_to_Zlist bl.
Proof. intros; induction al; simpl; auto. repeat f_equal; auto. Qed.

Lemma firstn_app:
 forall {A} n m (al: list A), firstn n al ++ firstn m (skipn n al) =
  firstn (n+m) al.
Proof. induction n; destruct al; intros; simpl; auto.
destruct m; reflexivity.
f_equal; auto.
Qed.

Lemma nth_skipn:
  forall A i n data (d:A),
       nth i (skipn n data) d = nth (i+n) data d.
Proof.
intros.
revert i data; induction n; simpl; intros.
f_equal; omega.
destruct data; auto.
destruct i; simpl; auto.
rewrite IHn.
replace (i + S n) with (S (i + n)) by omega; auto.
Qed.

Lemma Forall_app :
forall {A} P (l1 l2 :list A),
Forall P (l1 ++ l2) <->
Forall P l1 /\ Forall P l2.
intros.
split; induction l1; intros.
inv H. destruct l2; inv H0. auto.
split. auto. simpl in H2. inv H2.
constructor; auto.
split. inv H. constructor; auto. apply IHl1 in H3.
intuition.
inv H. apply IHl1 in H3. intuition.
simpl. intuition.
simpl. constructor.
destruct H. inv H. auto.
apply IHl1. intuition.
inv H0; auto.
Qed.

Lemma firstn_firstn: forall {A} lo n (data: list A), firstn lo (firstn (lo + n) data) = firstn lo data.
Proof.
  intros.
  revert data; induction lo; intros.
  + reflexivity.
  + destruct data; simpl; [reflexivity |].
    rewrite IHlo.
    reflexivity.
Qed.

Lemma skipn_firstn: forall {A} lo n (data: list A), skipn lo (firstn (lo + n) data) = firstn n (skipn lo data).
Proof.
  intros.
  revert data; induction lo; intros.
  + reflexivity.
  + destruct data; simpl.
    - destruct n; reflexivity.
    - apply IHlo.
Qed.

Lemma Zlength_app: forall T (al bl: list T),
    Zlength (al++bl) = (Zlength al + Zlength bl)%Z.
Proof. induction al; intros. simpl app; rewrite Zlength_nil; omega.
 simpl app; repeat rewrite Zlength_cons; rewrite IHal; omega.
Qed.
Lemma Zlength_rev: forall T (vl: list T), Zlength (rev vl) = Zlength vl.
Proof. induction vl; simpl; auto. rewrite Zlength_cons. rewrite <- IHvl.
rewrite Zlength_app. rewrite Zlength_cons. rewrite Zlength_nil; omega.
Qed.

Lemma Zlength_map: forall A B (f: A -> B) l, Zlength (map f l) = Zlength l.
Proof. induction l; simpl; auto. repeat rewrite Zlength_cons. f_equal; auto.
Qed.

Local Open Scope Z.

Lemma divide_length_app:
 forall {A} n (al bl: list A),
      (n | Zlength al) ->
      (n | Zlength bl) ->
      (n | Zlength (al++bl)).
Proof.
 intros. destruct H,H0. exists (x+x0)%Z.
 rewrite Zlength_app,H,H0;
 rewrite Z.mul_add_distr_r; omega.
Qed.

Lemma isbyte_intlist_to_Zlist : forall l, Forall isbyteZ (intlist_to_Zlist l).
Proof.
induction l; simpl; intros.
constructor.
assert (forall i, Int.unsigned (Int.and i (Int.repr 255)) < 256).
clear; intro.
eapply Z.lt_le_trans.
apply (Int.and_interval i (Int.repr (Z.ones 8))).
change (Int.size  (Int.repr (Z.ones 8))) with 8.
rewrite Zmin_spec.
if_tac.
eapply Z.le_trans with (two_p 8).
apply two_p_monotone.
split; [ | omega].
apply Int.size_range.
compute; congruence.
compute; congruence.
unfold Shr, isbyteZ; repeat constructor; try apply Int.unsigned_range; auto; clear IHl.
rewrite <- (Int.divu_pow2 a (Int.repr (2 ^ 24)) (Int.repr 24) (eq_refl _)).
unfold Int.divu.
rewrite Int.unsigned_repr.
rewrite Int.unsigned_repr by (compute; split; congruence).
apply Z.div_lt_upper_bound.
compute; congruence.
change (2 ^ 24 * 256)%Z with (Int.modulus).
apply Int.unsigned_range.
assert (0 < 2 ^ 24)
 by (apply Z.pow_pos_nonneg; clear; omega).
rewrite Int.unsigned_repr by (compute; split; congruence).
split.
apply Z.div_pos; auto.
apply Int.unsigned_range.
apply Z.div_le_upper_bound; auto.
apply Z.le_trans with (Int.modulus+1).
destruct (Int.unsigned_range a).
omega.
compute; congruence.
Qed.

Lemma isbyte_intlist_to_Zlist' : forall l,
   Forall isbyteZ (map Int.unsigned (map Int.repr (intlist_to_Zlist l))).
Proof.
intro.
replace (map Int.unsigned (map Int.repr (intlist_to_Zlist l))) with (intlist_to_Zlist l).
apply isbyte_intlist_to_Zlist.
induction l; simpl; auto.
repeat f_equal; auto; symmetry; apply Int.repr_unsigned.
Qed.

Lemma Forall_isbyte_repr_unsigned:
 forall l: list int, map Int.repr (map Int.unsigned l) = l.
Proof.
induction l; intros.
reflexivity.
simpl.
f_equal; auto.
apply Int.repr_unsigned.
Qed.

Lemma map_unsigned_repr_isbyte:
  forall l : list Z , Forall isbyteZ l -> map Int.unsigned (map Int.repr l) = l.
Proof. induction l; simpl; intros; auto.
  inv H. f_equal; auto. unfold isbyteZ in H2; apply Int.unsigned_repr.
 assert (Int.max_unsigned > 256)%Z by (compute; congruence).
 omega.
Qed.

Lemma int_unsigned_inj: forall a b, Int.unsigned a = Int.unsigned b -> a=b.
Proof.
intros.
rewrite <- (Int.repr_unsigned a); rewrite <- (Int.repr_unsigned b).
congruence.
Qed.

Lemma intlist_to_Zlist_inj: forall al bl, intlist_to_Zlist al = intlist_to_Zlist bl -> al=bl.
Proof.
induction al; destruct bl; intros; auto.
inv H.
inv H.
simpl in H.
injection H; intros.
f_equal; auto.
clear - H1 H2 H3 H4.
rename i into b.
apply int_unsigned_inj in H1.
apply int_unsigned_inj in H2.
apply int_unsigned_inj in H3.
apply int_unsigned_inj in H4.
unfold Shr in *.
apply Int.same_bits_eq; intros.
assert (Int.zwordsize=32)%Z by reflexivity.
change 255%Z with (Z.ones 8) in *.
destruct (zlt i 8).
transitivity (Int.testbit (Int.and a (Int.repr (Z.ones 8))) i).
autorewrite with testbit; auto.
rewrite H1. autorewrite with testbit; auto.
destruct (zlt i 16).
transitivity (Int.testbit (Int.and (Int.shru a (Int.repr 8)) (Int.repr (Z.ones 8))) (i-8)).
autorewrite with testbit.
change (Int.unsigned (Int.repr 8)) with 8%Z.
rewrite Z.sub_add; auto.
rewrite H2.
autorewrite with testbit.
rewrite Z.sub_add. auto.
destruct (zlt i 24).
transitivity (Int.testbit (Int.and (Int.shru a (Int.repr 16)) (Int.repr (Z.ones 8))) (i-16)).
autorewrite with testbit.
change (Int.unsigned (Int.repr 16)) with 16%Z.
rewrite Z.sub_add. auto.
rewrite H3.
autorewrite with testbit.
change (Int.unsigned (Int.repr 16)) with 16%Z.
rewrite Z.sub_add. auto.
transitivity (Int.testbit (Int.shru a (Int.repr 24)) (i-24)).
autorewrite with testbit.
change (Int.unsigned (Int.repr 24)) with 24%Z.
rewrite Z.sub_add. auto.
rewrite H4.
autorewrite with testbit.
change (Int.unsigned (Int.repr 24)) with 24%Z.
rewrite Z.sub_add. auto.
Qed.

Lemma Zlength_intlist_to_Zlist_app:
 forall al bl,  Zlength (intlist_to_Zlist (al++bl)) =
    (Zlength (intlist_to_Zlist al) + Zlength (intlist_to_Zlist bl))%Z.
Proof.
induction al; simpl; intros; auto.
repeat rewrite Zlength_cons.
rewrite IHal.
omega.
Qed.

Lemma Forall_firstn:
  forall A (f: A -> Prop) n l, Forall f l -> Forall f (firstn n l).
Proof.
induction n; destruct l; intros.
constructor. constructor. constructor.
inv H. simpl. constructor; auto.
Qed.

Lemma Forall_skipn:
  forall A (f: A -> Prop) n l, Forall f l -> Forall f (skipn n l).
Proof.
induction n; destruct l; intros.
constructor. inv H; constructor; auto. constructor.
inv H. simpl.  auto.
Qed.

Local Open Scope Z.

Lemma add_repr: forall i j, Int.add (Int.repr i) (Int.repr j) = Int.repr (i+j).
Proof. intros.
  rewrite Int.add_unsigned.
 apply Int.eqm_samerepr.
 unfold Int.eqm.
 apply Int.eqm_add; apply Int.eqm_sym; apply Int.eqm_unsigned_repr.
Qed.

Lemma mul_repr:
 forall x y, Int.mul (Int.repr x) (Int.repr y) = Int.repr (x * y).
Proof.
intros. unfold Int.mul.
apply Int.eqm_samerepr.
repeat rewrite Int.unsigned_repr_eq.
apply Int.eqm_mult; unfold Int.eqm; apply Int.eqmod_sym;
apply Int.eqmod_mod; compute; congruence.
Qed.

Lemma hilo_lemma:
  forall hi lo, [Int.repr (hilo hi lo / Int.modulus), Int.repr (hilo hi lo)] = [hi, lo].
Proof.
unfold hilo; intros.
rewrite Z.div_add_l by (compute; congruence).
rewrite Zdiv_small by apply Int.unsigned_range.
rewrite Z.add_0_r.
rewrite Int.repr_unsigned.
f_equal.
f_equal.
rewrite <- add_repr.
rewrite <- mul_repr.
replace (Int.repr Int.modulus) with (Int.repr 0).
rewrite Int.mul_zero. rewrite Int.add_zero_l. apply Int.repr_unsigned.
apply Int.eqm_samerepr.
unfold Int.eqm.
change 0 with (Int.modulus mod Int.modulus).
apply Int.eqmod_sym.
apply Int.eqmod_mod.
compute; congruence.
Qed.

Lemma Forall_isbyteZ_unsigned_repr:
 forall l, Forall isbyteZ l -> Forall isbyteZ (map Int.unsigned (map Int.repr l)).
Proof. induction 1. constructor.
constructor. rewrite Int.unsigned_repr; auto.
unfold isbyteZ in H; repable_signed.
apply IHForall.
Qed.

Lemma divide_hashed:
 forall (bb: list int),
    NPeano.divide LBLOCK (length bb) <->
    (LBLOCKz | Zlength bb).
Proof.
intros; split; intros [n ?].
exists (Z.of_nat n). rewrite Zlength_correct, H.
rewrite Nat2Z.inj_mul; auto.
exists (Z.to_nat n).
rewrite Zlength_correct in H.
assert (0 <= n).
assert (0 <= n * LBLOCKz) by omega.
apply Z.mul_nonneg_cancel_r in H0; auto.
rewrite <- (Z2Nat.id (n*LBLOCKz)%Z) in H by omega.
apply Nat2Z.inj in H. rewrite H.
change LBLOCK with (Z.to_nat LBLOCKz).
rewrite Z2Nat.inj_mul; auto.
Qed.

Lemma hash_blocks_equation' : forall (r : registers) (msg : list int),
       hash_blocks r msg =
       match msg with
       | [] => r
       | _ :: _ => hash_blocks (hash_block r (firstn LBLOCK msg)) (skipn LBLOCK msg)
       end.
Proof. exact hash_blocks_equation. Qed.

Lemma CBLOCK_eq: CBLOCK=64%nat.
Proof. reflexivity. Qed.
Lemma LBLOCK_eq: LBLOCK=16%nat.
Proof. reflexivity. Qed.

Lemma hash_blocks_last:
 forall a bl c,
              Zlength a = 8 ->
              (LBLOCKz | Zlength bl) ->
              Zlength c = LBLOCKz ->
   hash_block (hash_blocks a bl) c = hash_blocks a (bl++ c).
Proof.
intros.
assert (POS: (0 < LBLOCK)%nat) by (rewrite LBLOCK_eq; omega).
apply divide_hashed in H0.
destruct H0 as [n ?].
rewrite Zlength_correct in H,H1.
change 8 with (Z.of_nat 8) in H.
(*change LBLOCK with 16%nat in H0.*)
change LBLOCKz with (Z.of_nat LBLOCK) in H1.
apply Nat2Z.inj in H.
apply Nat2Z.inj in H1.
revert a bl H H0; induction n; intros.
destruct bl; inv H0.
rewrite hash_blocks_equation'.
simpl. rewrite hash_blocks_equation'.
destruct c eqn:?. inv H1.
rewrite <- Heql in *; clear i l Heql.
rewrite firstn_same by omega.
replace (skipn LBLOCK c) with (@nil int).
rewrite hash_blocks_equation'; reflexivity.
pose proof (skipn_length LBLOCK c).
spec H0; [omega |]. rewrite H1 in H0.
destruct (skipn LBLOCK c); try reflexivity; inv H0.
replace (S n * LBLOCK)%nat with (n * LBLOCK + LBLOCK)%nat  in H0 by
  (simpl; omega).
rewrite hash_blocks_equation'.
destruct bl.
simpl in H0.
Psatz.lia.
forget (i::bl) as bl'; clear i bl. rename bl' into bl.
rewrite IHn.
symmetry.
rewrite hash_blocks_equation.
destruct bl.
simpl in H0; Psatz.lia.
unfold app at 1; fold app.
forget (i::bl) as bl'; clear i bl. rename bl' into bl.
f_equal.
f_equal.
apply firstn_app1.
Psatz.nia.
apply skipn_app1.
Psatz.nia.
apply length_hash_block; auto. (* fixme *) change 16%nat with LBLOCK.
rewrite firstn_length. apply min_l.
Psatz.nia.
rewrite skipn_length.
apply plus_reg_l with LBLOCK.
rewrite plus_comm.
rewrite NPeano.Nat.sub_add by Psatz.lia.
omega.
(*Psatz.lia.*)
rewrite H0. assert (Hn: (n*LBLOCK >= 0)%nat).
  remember ((n * LBLOCK)%nat). clear. omega.
  omega.
Qed.

Lemma length_hash_blocks: forall regs blocks,
  length regs = 8%nat ->
  (LBLOCKz | Zlength blocks) ->
  length (hash_blocks regs blocks) = 8%nat.
Proof.
intros.
destruct H0 as [n ?].
rewrite Zlength_correct in H0.
assert (POS := LBLOCKz_pos).
change LBLOCKz with (Z.of_nat LBLOCK) in *.
rewrite <- (Z2Nat.id n) in H0
 by (apply -> Z.mul_nonneg_cancel_r ; [ | apply POS]; omega).
rewrite <- Nat2Z.inj_mul in H0.
apply Nat2Z.inj in H0.
revert regs blocks H H0; induction (Z.to_nat n); intros.
  destruct blocks; inv H0.
rewrite hash_blocks_equation'; auto.
destruct blocks.
destruct LBLOCK; inv POS; inv H0.
rewrite hash_blocks_equation'; auto.
forget (i::blocks) as bb.
apply IHn0; auto.
apply length_hash_block; auto. (* fixme *) change 16%nat with LBLOCK.
rewrite firstn_length. apply min_l. simpl in H0. Psatz.nia.
rewrite skipn_length. rewrite H0; clear - POS.  simpl.
rewrite plus_comm. rewrite NPeano.Nat.add_sub. auto.
simpl in H0. rewrite H0; clear - POS. Psatz.lia.
Qed.

Lemma nth_list_repeat: forall A i n (x :A),
    nth i (list_repeat n x) x = x.
Proof.
 induction i; destruct n; simpl; auto.
Qed.

Lemma map_list_repeat:
  forall A B (f: A -> B) n x,
     map f (list_repeat n x) = list_repeat n (f x).
Proof. induction n; simpl; intros; f_equal; auto.
Qed.

Lemma Forall_list_repeat:
  forall A (f: A -> Prop) n (x: A),
     f x -> Forall f (list_repeat n x).
Proof.
 intros; induction n; simpl; auto.
Qed.

Lemma ZtoNat_Zlength:
 forall {A} (l: list A), Z.to_nat (Zlength l) = length l.
Proof.
intros. rewrite Zlength_correct. apply Nat2Z.id.
Qed.
Hint Rewrite @ZtoNat_Zlength : norm.

Lemma Zlength_nonneg:
 forall {A} (l: list A), 0 <= Zlength l.
Proof.
intros. rewrite Zlength_correct. omega.
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

(* Import SolidityNotations. *)
Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.
(*Set Typeclasses Strict Resolution. *)
(* Set Typeclasses Debug.  *)
(* Set Typeclasses Unique Instances.
Unset Typeclasses Unique Solutions. *)

(* Existing Instance monadStateT.
Existing Instance monadStateStateT. *)
(* Module MultiSigWalletSpecSig := MultiSigWalletSpecSig XTypesSig StateMonadSig. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.
Require Import depoolContract.Lib.CommonStateProofs.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope solidity_scope.

(* Require Import MultiSigWallet.Specifications._validatelimit_inlineSpec.
Module _validatelimit_inlineSpec := _validatelimit_inlineSpec MultiSigWalletSpecSig.
Import _validatelimit_inlineSpec. *)

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

(* Check hmapIsMember. *)

(* Lemma foo: forall (l: Ledger) addr, isSome
(eval_state
 (callEmbeddedStateAdj (H0 :=  FullState_T1xT2xT3xT4xT5xT6xT7xT8xT9xT10xT11xT12xT13xT14xT15xT16_T17)
 (DePoolFuncs.ParticipantBase_Ф_fetchParticipant
 addr)
 DePoolFuncs.DePoolSpec.LedgerClass.local0)
 l) =
isSome
(eval_state
 (callEmbeddedStateAdj (H0 :=  FullState_T1xT2xT3xT4xT5xT6xT7xT8xT9xT10xT11xT12xT13xT14xT15xT16_T17)
 (DePoolFuncs.ParticipantBase_Ф_fetchParticipant
 addr)
 DePoolFuncs.DePoolSpec.LedgerClass.local0)
 l).
 Proof.
    intros.
    reflexivity.
 Qed.    *)

(* Existing Instance embeddedLocalState.

Existing Instance monadStateT.
Existing Instance monadStateStateT. *)

(* Existing Instance embeddedLocalState.
Existing Instance embeddedMultisig. *)

 (* function ConfigParamsBase.getCurValidatorData (  )  virtual internal returns  ( uint256 hash ,  uint32 utime_since ,  uint32 utime_until )   {
         ( TvmCell cell ,  bool ok )  = tvm_rawConfigParam ( 34 )  ;
        require ( ok ,  InternalErrors . ERROR508 )  ;
        hash = tvm_hash ( cell )  ;
        TvmSlice s = cell . toSlice (  )  ;
         (  ,  utime_since ,  utime_until )  = s . decode ( uint8 ,  uint32 ,  uint32 )  ;
     }

Definition ConfigParamsBase_Ф_getCurValidatorData :  LedgerT ( XErrorValue ( XInteger256 # XInteger32 # XInteger32 ) XInteger ) :=
	U0! {( Л_cell , Л_ok )} := tvm_rawConfigParam (! $ xInt34 !) ;
 	Require {{ $ Л_ok , ↑ε8 InternalErrors_ι_ERROR508 }} ;
 	U0! Л_hash := tvm_hash (! $ Л_cell !) ;
 	U0! Л_s := ($ Л_cell) ->toSlice() ;
	U0! {( _ , Л_utime_since , Л_utime_until )} := ($ Л_s) ->decode(uint8,uint32,uint32) ;  (* (uint8 , uint32 , uint32) *)
	return# ( $Л_hash, $Л_utime_since , $Л_utime_until ).
*)

 Lemma ConfigParamsBase_Ф_getCurValidatorData_exec : forall (l: Ledger),
    exec_state (  ConfigParamsBase_Ф_getCurValidatorData ) l =  l.
 Proof.
   intros. destruct l. compute. auto.
 Qed.

 Lemma ConfigParamsBase_Ф_getCurValidatorData_eval : forall (l: Ledger) ,
 eval_state ( ConfigParamsBase_Ф_getCurValidatorData ) l =

 let (Л_cell, Л_ok) := eval_state (tvm_rawConfigParam 34) l in
 let hash := tvm_hash Л_cell in
 let sliceRaw := toSlice Л_cell in
 let res := decode_uint8_uint32_uint32 sliceRaw in
  if Л_ok then Value (hash , snd (fst (fst res)) , snd (fst res))
          else Error (eval_state ( ↑8 ε InternalErrors_ι_ERROR508) l).
 Proof.
   intros. destruct l. compute.  auto.
 Qed.

 (* function ConfigParamsBase.getPrevValidatorHash (  )  virtual internal returns  ( uint )   {
         ( TvmCell cell ,  bool ok )  = tvm_rawConfigParam ( 32 )  ;
        require ( ok ,  InternalErrors . ERROR507 )  ;
        return tvm_hash ( cell )  ;
     }

Definition ConfigParamsBase_Ф_getPrevValidatorHash : LedgerT ( XErrorValue XInteger XInteger ) :=
	U0! {( Л_cell , Л_ok )} := tvm_rawConfigParam (! $ xInt32 !) ;
 	Require {{ $ Л_ok , ↑ε8 InternalErrors_ι_ERROR507 }} ;
 	 tvm_hash (! $ Л_cell !).*)

 Lemma ConfigParamsBase_Ф_getPrevValidatorHash_exec : forall (l: Ledger) ,
 	 exec_state (  ConfigParamsBase_Ф_getPrevValidatorHash ) l = l .
 Proof.
   intros. destruct l. auto.
 Qed.

 Lemma ConfigParamsBase_Ф_getPrevValidatorHash_eval : forall (l: Ledger)  ,
 eval_state (  ConfigParamsBase_Ф_getPrevValidatorHash ) l =

 let (Л_cell, Л_ok) := eval_state (tvm_rawConfigParam 32) l in
 let hash := tvm_hash Л_cell in

 if Л_ok then Value hash
 else Error (eval_state ( ↑8 ε InternalErrors_ι_ERROR507) l).
 Proof.
   intros. compute. auto.
 Qed.

 (* function ConfigParamsBase.roundTimeParams (  )  virtual internal returns  (
        uint32 validatorsElectedFor ,
        uint32 electionsStartBefore ,
        uint32 electionsEndBefore ,
        uint32 stakeHeldFor
     )   {
        bool ok ;
         ( validatorsElectedFor ,  electionsStartBefore ,  electionsEndBefore ,  stakeHeldFor ,  ok )  = tvm_configParam ( 15 )  ;
        require ( ok ,  InternalErrors . ERROR509 )  ;
     }

Definition ConfigParamsBase_Ф_roundTimeParams  : LedgerT ( XErrorValue ( XInteger32 # XInteger32 # XInteger32 # XInteger32 ) XInteger )  :=
 U0! {( Л_validatorsElectedFor , Л_electionsStartBefore , Л_electionsEndBefore , Л_stakeHeldFor , Л_ok )} := tvm_configParam (! $ xInt15 !) ;
 Require {{ $ Л_ok , ↑ε8 InternalErrors_ι_ERROR509 }} ;
 return# ($Л_validatorsElectedFor, $Л_electionsStartBefore, $Л_electionsEndBefore, $Л_stakeHeldFor ).
*)
 Lemma ConfigParamsBase_Ф_roundTimeParams_exec : forall (l: Ledger) ,
 	 exec_state (  ConfigParamsBase_Ф_roundTimeParams ) l = l .
 Proof.
   intros. destruct l. auto.
 Qed.

 Lemma ConfigParamsBase_Ф_roundTimeParams_eval : forall (l: Ledger) ,
  eval_state ConfigParamsBase_Ф_roundTimeParams l =
  let (Л_params, Л_ок) := eval_state (tvm_configParam 15) l in
  let stakeHeldFor := snd Л_params in
  let electionsEndBefore := snd (fst Л_params) in
  let electionsStartBefore := snd (fst (fst Л_params)) in
  let validatorsElectedFor := fst (fst (fst Л_params)) in
   if Л_ок
    then
      Value (validatorsElectedFor,
            electionsStartBefore,
            electionsEndBefore,
            stakeHeldFor)
    else Error (eval_state ( ↑8 ε InternalErrors_ι_ERROR509) l).
 Proof.
   intros. destruct l.  compute. auto.
 Qed.

 (* function ConfigParamsBase.getMaxStakeFactor (  )  virtual pure internal returns  ( uint32 )   {
         ( TvmCell cell ,  bool ok )  = tvm_rawConfigParam ( 17 )  ;
        require ( ok ,  InternalErrors . ERROR516 )  ;
        TvmSlice s = cell . toSlice (  )  ;
        s . loadTons (  )  ;
        s . loadTons (  )  ;
        s . loadTons (  )  ;
        return s . decode ( uint32 )  ;
     }

Definition ConfigParamsBase_Ф_getMaxStakeFactor : LedgerT ( XErrorValue XInteger32 XInteger ) :=
	U0! {( Л_cell , Л_ok )} := tvm_rawConfigParam (! $ xInt17 !) ;
 	Require {{ $ Л_ok , ↑ε8 InternalErrors_ι_ERROR516 }} ;
 	U0! Л_s := ($ Л_cell) ->toSlice() ;
 	Л_s ->loadTons() ;
 	Л_s ->loadTons() ;
 	Л_s ->loadTons() ;
	($ Л_s) ->decode(uint32) . (*uint32*)
*)

 Lemma ConfigParamsBase_Ф_getMaxStakeFactor_exec : forall (l: Ledger) ,
 	 exec_state ConfigParamsBase_Ф_getMaxStakeFactor l = l .
 Proof.
   intros. destruct l. auto.
 Qed.

 Lemma ConfigParamsBase_Ф_getMaxStakeFactor_eval : forall (l: Ledger)  ,
 eval_state (  ConfigParamsBase_Ф_getMaxStakeFactor ) l =

 let (Л_cell, Л_ok) := eval_state (tvm_rawConfigParam 17) l in
 let sliceRaw := toSlice Л_cell in
 let t1 := tvm_loadTons (tvm_loadTons (tvm_loadTons sliceRaw)) in
 let res := fst (decode_uint32 t1) in
 if Л_ok
 then Value res
 else  Error (eval_state ( ↑8 ε InternalErrors_ι_ERROR516) l).
 Proof.
   intros. destruct l.
   compute. auto.
 Qed.

 (* function ConfigParamsBase.getElector (  )  virtual pure internal returns  ( address )   {
         ( TvmCell cell ,  bool ok )  = tvm_rawConfigParam ( 1 )  ;
        require ( ok ,  InternalErrors . ERROR517 )  ;
        TvmSlice s = cell . toSlice (  )  ;
        uint256 value = s . decode ( uint256 )  ;
        return address . makeAddrStd (  - 1 ,  value )  ;
     }

Definition ConfigParamsBase_Ф_getElector : LedgerT ( XErrorValue XAddress XInteger ) :=
 U0! {( Л_cell , Л_ok )} := tvm_rawConfigParam (! $ xInt1 !) ;
 Require {{ $ Л_ok , ↑ε8 InternalErrors_ι_ERROR517 }} ;
 U0! Л_s := ($ Л_cell) ->toSlice() ;
 U0! Л_value := ($ Л_s) ->decode(uint256) ;
  address->makeAddrStd (! $xInt0 !- $ xInt1 , $ Л_value !) .
*)

 Lemma ConfigParamsBase_Ф_getElector_exec : forall (l: Ledger) ,
 	 exec_state ConfigParamsBase_Ф_getElector l = l .
 Proof.
   intros. destruct l. auto.
 Qed.

 Lemma ConfigParamsBase_Ф_getElector_eval : forall (l: Ledger) ,
 eval_state  ConfigParamsBase_Ф_getElector l =

 let (Л_cell, Л_ok) := eval_state (tvm_rawConfigParam 1) l in

 let sliceRaw := toSlice Л_cell in
 let v := fst (decode_uint256 sliceRaw) in
 let res := address_makeAddrStd (-1)%Z v in

  if Л_ok then Value res
    else Error (eval_state ( ↑8 ε InternalErrors_ι_ERROR517) l).
 Proof.
  intros. destruct l.
  compute. auto.
 Qed.


(*
 * Module: Instructions
 *
 * Description:
 *  This module defines the various instructions that exist within the language.
 *)

Require Import TLB.
Require Import Arith.

(*
 * Inductive Type: tm
 *
 * Description:
 *   This data type represents all of the instructions that can occur in
 *   the language.  It also contains a "val" instruction which encapsulates
 *   data that can be stored in the store.
 *
 *   It's called "tm" because tm is short for "term" which is what the basic
 *   element of most small-step semantics are called.
 *
 *   This machine has a single register and has memory addressing modes.
 *
 *   val : Represents a value in memory
 *   sec : Represents a secret value in memory
 *   ldi : Load immediate value into register
 *   lda : Load value from specified address into register
 *   sta : Store value in register into specified address
 *   add : Add a constant value to the value in the register.  The result stays
 *         within the register.
 *   map : Add a TLB entry to the MMU.
 *   invalidate : Reset a TLB entry back to a default value.
 *   jmp : Jump to the address located in the register.
 *   jeq : Jump to the specified address if the register is zero.
 *   jne : Jump to the specified address if the register is negative.
 *   trap: Generate a machine trap (syscall, exception, or interrupt).
 *   iret: Return from a trap.
 *   svaDeclareStack : Declare a range of memory to be a stack.
 *   svaLoadPGTable : Load the ASID value
 *   svaInitStack   : Create and initialize a new thread
 *   svaSwap        : Switch to a new thread identified in the register
 *   svaRegisterTrap: Register a trap handler
 *   svaSaveIcontext: Save a copy of the interrupt context
 *   svaLoadIcontext: Save a copy of the interrupt context
 *   svaPushFunction: Push a function frame on to the interrupted stack
 *   jsr : Jump to the subroutine located in the register.
 *   ret : Return to the previously executed jsr instruction.
 *)
Inductive tm : Type :=
  | val  : nat -> tm
  | sec  : tm
  | ldi  : nat -> tm
  | lda  : nat -> tm
  | sta  : nat -> tm
  | add  : nat -> tm
  | sub  : nat -> tm
  | map  : nat -> TLBTy -> tm
  | jmp  : tm
  | jeq  : nat -> tm
  | jne  : nat -> tm
  | trap : tm
  | iret : tm
  | svaDeclareStack : nat -> nat -> tm
  | svaLoadPGTable : tm
  | svaInitStack : nat -> tm
  | svaSwap : tm
  | svaRegisterTrap : tm
  | svaSaveIcontext : tm
  | svaLoadIcontext : tm
  | svaPushFunction : nat -> tm
  | jsr : tm
  | ret : tm.


Require Import SetoidList ZArith Lia.
Require Import Flocq.Core.Zaux.
From compcert Require Import common.Errors backend.Cminor lib.Integers.
From sparkfrontend Require Import LibTac LibHypsNaming compcert_utils more_stdlib.
Import compcert.common.Memory.
Require compcert.cfrontend.Ctypes.

(*Require Import sparkfrontend.LibTac sparkfrontend.LibHypsNaming  compcert.common.Errors
        compcert.common.Cminor compcert.lib.Integers sparkfrontend.compcert_utils sparkfrontend.more_stdlib.*)

Open Scope nat_scope.
(** The Chaining structure of the stacks.

In this section we describe the way the first element of each local
stack points to another local stack up to a given depth. This give a
stack of stacks that is isomrphic to Spark's stack of stacks. *)

(* We need this structural invariant at least to prove that execution
   never modifies the chaining pointers. *)
Inductive chained_stack_structure m : nat -> Values.val -> Prop :=
| chained_0: forall b, chained_stack_structure m 0 (Values.Vptr b Ptrofs.zero) (* Should b null? *)
| chained_S: forall n b' b,
    chained_stack_structure m n (Values.Vptr b' Ptrofs.zero) ->
    Mem.loadv AST.Mint32 m (Values.Vptr b Ptrofs.zero) = Some (Values.Vptr b' Ptrofs.zero) ->
    chained_stack_structure m (S n) (Values.Vptr b Ptrofs.zero).

Inductive repeat_Mem_loadv (chk:AST.memory_chunk) (m : mem): forall (lvl:nat) (sp sp' : Values.val), Prop :=
| Repeat_loadv1: forall sp, repeat_Mem_loadv chk m O sp sp
| Repeat_loadv2: forall lvl sp sp' sp'',
    repeat_Mem_loadv chk m lvl sp' sp'' ->
    Mem.loadv AST.Mint32 m sp = Some sp' ->
    repeat_Mem_loadv chk m (S lvl) sp sp''.

(* CE gives the maximum number of loads. *)
Definition stack_localstack_aligned lvl locenv g m sp :=
  forall δ_lvl,
    (δ_lvl <= lvl)%nat ->
    exists b_δ,
      Cminor.eval_expr g sp locenv m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) δ_lvl) (Values.Vptr b_δ Ptrofs.zero).

Ltac rename_chained t th :=
  match th with
| chained_stack_structure ?m ?lvl ?sp => fresh "chain_" m "_" lvl "_" sp
| chained_stack_structure ?m ?lvl _ => fresh "chain_" m "_" lvl
| chained_stack_structure ?m _ _ => fresh "chain_" m
| chained_stack_structure _ ?lvl _ => fresh "chain_" lvl
| chained_stack_structure _ _ _ => fresh "chain"
| repeat_Mem_loadv _ ?m ?lvl ?v ?sp => fresh "repeat_loadv_" lvl "_" v
| repeat_Mem_loadv _ ?m ?lvl ?v ?sp => fresh "repeat_loadv_" lvl
| repeat_Mem_loadv _ ?m ?lvl ?v ?sp => fresh "repeat_loadv"
| stack_localstack_aligned _ _ ?g ?m ?sp => fresh "aligned_" g "_" m
| stack_localstack_aligned _ _ _ ?m ?sp => fresh "aligned_" m
| stack_localstack_aligned _ _ ?g _ ?sp => fresh "aligned_" g
end.

Ltac prefixable h th ::=
  match th with
  | _ => prefixable_compcert h th
  | _ => prefixable_eq_neq h th
  end.

Ltac rename_hyp h th ::=
  match th with
  | _ => (compcert_utils.rename_hyp1 h th)
  | _ => (LibHypsNaming.rename_hyp_neg h th)
  | _ => (rename_chained h th)
  end.

Lemma chained_stack_structure_le m sp : forall n,
    chained_stack_structure m n sp ->
    forall n', (n' <= n)%nat ->
               chained_stack_structure m n' sp.
Proof.
  !!intros ? ?.
  !induction h_chain_m_n_sp;!intros.
  - assert (n'=0)%nat by lia;subst.
    constructor.
  - destruct n'.
    * constructor.
    * econstructor;eauto.
      apply h_forall_n';eauto;lia.
Qed.

Lemma chained_stack_struct_inv_sp_zero: forall m n sp,
    chained_stack_structure m n sp -> exists b',  sp = (Values.Vptr b' Ptrofs.zero).
Proof.
  !intros.
  inversion h_chain_m_n_sp;subst;eauto.
Qed.

Lemma chained_stack_struct_sp_add: forall m n sp,
    chained_stack_structure m n sp -> (Values.Val.add sp (Values.Vint Int.zero)) = sp.
Proof.
  !intros.
  destruct (chained_stack_struct_inv_sp_zero m n sp);subst;auto.
Qed.

Lemma cm_eval_addrstack_zero:
  forall b ofs m g e,
      Cminor.eval_expr g (Values.Vptr b ofs) e m (Econst (Oaddrstack Ptrofs.zero)) (Values.Vptr b ofs).
Proof.
  !intros.
  constructor;cbn.
  rewrite Ptrofs.add_zero.
  reflexivity.
Qed.

Lemma cm_eval_addrstack_zero_chain:
  forall n sp m,
    chained_stack_structure m n sp ->
    forall g e,
      Cminor.eval_expr g sp e m (Econst (Oaddrstack Ptrofs.zero)) sp.
Proof.
  !intros.
  destruct (chained_stack_struct_inv_sp_zero _ _ _ h_chain_m_n_sp).
  subst.
  apply cm_eval_addrstack_zero.
Qed.

(* a useful formulation of the two previous lemmas. *)
Lemma det_cm_eval_addrstack_zero_chain : forall m lvl sp e g vaddr,
    chained_stack_structure m lvl sp ->
    Cminor.eval_expr g sp e m (Econst (Oaddrstack Ptrofs.zero)) vaddr ->
    vaddr = sp.
Proof.
  !intros.
  pose proof cm_eval_addrstack_zero_chain lvl sp m h_chain_m_lvl_sp g e.
  eapply det_eval_expr;eauto.
Qed.

Lemma det_cm_eval_addrstack_zero : forall b i m e g vaddr,
    Cminor.eval_expr g (Values.Vptr b i) e m (Econst (Oaddrstack Ptrofs.zero)) vaddr ->
    vaddr = (Values.Vptr b i).
Proof.
  !intros.
  pose proof cm_eval_addrstack_zero b i m g e.
  eapply det_eval_expr;eauto.
Qed.

Ltac subst_det_addrstack_zero :=

  match goal with
  | H:Cminor.eval_expr ?g ?sp ?e ?m ?exp ?vaddr,
      H':Cminor.eval_expr ?g ?sp ?e ?m ?exp ?vaddr' |- _ =>
    assert (vaddr=vaddr') by (eapply det_eval_expr;eauto);
    try (subst vaddr + subst vaddr');
    clear H
    (* to avoid useless applications *)
  | H:Cminor.eval_expr ?g ?sp ?e ?m ?exp ?sp |- _ =>
    fail 1
  | H:Cminor.eval_expr ?g (Values.Vptr ?b ?i) ?e ?m (Econst (Oaddrstack Ptrofs.zero)) ?vaddr |- _ =>
    assert (vaddr=(Values.Vptr b i)) by (eapply det_cm_eval_addrstack_zero;eauto);
    try subst vaddr
  | H:Cminor.eval_expr ?g ?sp ?e ?m (Econst (Oaddrstack Ptrofs.zero)) ?vaddr,
      H':chained_stack_structure ?m ?n ?sp |- _ =>
    assert (vaddr=sp) by (eapply det_cm_eval_addrstack_zero_chain;eauto);
    try subst vaddr

  end.

Lemma chained_stack_structure_aux m sp : forall n,
    chained_stack_structure m (S n) sp ->
    forall g e, exists b',
      chained_stack_structure m n (Values.Vptr b' Ptrofs.zero)
      /\ Mem.loadv AST.Mint32 m sp = Some (Values.Vptr b' Ptrofs.zero)
      /\ Cminor.eval_expr g sp e m (Eload AST.Mint32 (Econst (Oaddrstack Ptrofs.zero))) (Values.Vptr b' Ptrofs.zero).
Proof.
  !!intros until 1.
  inversion h_chain_m;subst;!intros.
  exists b';split;[|split];eauto.
  econstructor;eauto.
  constructor.
  cbn.
  reflexivity.
Qed.

Lemma build_loads__decomp_S: forall m b0 g e b,
    Cminor.eval_expr g (Values.Vptr b0 Ptrofs.zero) e m
                     (Eload AST.Mint32 (Econst (Oaddrstack Ptrofs.zero)))
                     (Values.Vptr b Ptrofs.zero) ->
    forall n v,
      Cminor.eval_expr g (Values.Vptr b0 Ptrofs.zero) e m
                       (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) (S n)) v ->
      exists sp',
        Cminor.eval_expr g (Values.Vptr b0 Ptrofs.zero) e m
                         (Eload AST.Mint32 (Econst (Oaddrstack Ptrofs.zero))) sp'
        /\ Cminor.eval_expr g sp' e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) v.
Proof.
  !intros.
  revert v b h_CM_eval_expr h_CM_eval_expr_v.
  !induction n.
  - !intros.
    cbn in *.
    exists v;split;auto.
    constructor;cbn.
    subst_det_addrstack_zero.
    cbn.
    rewrite Ptrofs.add_zero.
    reflexivity.
  - !intros.
    cbn in h_CM_eval_expr_v.
    !invclear h_CM_eval_expr_v;subst.
    change (Eload AST.Mint32 (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) with (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) (S n)) in h_CM_eval_expr_vaddr.
    specialize (h_forall_v _ _ h_CM_eval_expr h_CM_eval_expr_vaddr).
    decomp h_forall_v.
    exists sp';split;auto.
    cbn.
    econstructor;eauto.
Qed.

Lemma chained_stack_structure_decomp_S: forall m max sp g e,
    forall n v, chained_stack_structure m max sp ->
      n < max ->
      Cminor.eval_expr g sp e m
                       (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) (S n))
                       v ->
         exists sp',
           Cminor.eval_expr g sp e m (Eload AST.Mint32 (Econst (Oaddrstack Ptrofs.zero))) sp' /\
           Cminor.eval_expr g sp' e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) v.
Proof.
  !!intros until n.
  !induction n.
  - !intros.
    cbn in *.
    exists v;split;auto.
    eapply cm_eval_addrstack_zero_chain with (n:=Nat.pred max);eauto.
    rewrite <- (PeanoNat.Nat.succ_pred_pos _ h_lt_O_max) in h_chain_m_max_sp.
    !inversion h_chain_m_max_sp.
    !inversion h_CM_eval_expr_v.
    subst_det_addrstack_zero.
    rewrite h_loadv in h_loadv_vaddr_v.
    inversion h_loadv_vaddr_v.
    assumption.
  - !intros.
    cbn in h_CM_eval_expr_v.
    !invclear h_CM_eval_expr_v;subst.
    change (Eload AST.Mint32 (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) with (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) (S n)) in h_CM_eval_expr_vaddr.
    !!assert (n<max) by lia.
    specialize h_forall_v with (1:=h_chain_m_max_sp)(2:=h_lt_n_max)(3:=h_CM_eval_expr_vaddr).
    decomp h_forall_v.
    exists sp';split;auto.
    cbn.
    econstructor;eauto.
Qed.

Lemma chained_stack_structure_spec :
  forall  g e m n b,
    (forall lvl,
        (lvl <= n)%nat
        -> exists b',
          Cminor.eval_expr g (Values.Vptr b Ptrofs.zero) e m
                           (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) lvl)
                           (Values.Vptr b' Ptrofs.zero))
    -> chained_stack_structure m n (Values.Vptr b Ptrofs.zero).
Proof.
  !!induction n;!intros.
  - constructor.
  - !!assert (1 <= S n) by lia.
    !!pose proof  (h_forall_lvl 1%nat h_le).
    decomp h_ex.
    !!assert (S n <= S n) by lia.
    !!pose proof  (h_forall_lvl _ h_le0).
    decomp h_ex.
    cbn in *.
    !!specialize build_loads__decomp_S with (1:=h_CM_eval_expr)(2:=h_CM_eval_expr0) as ?.
    decomp h_ex.
    subst_det_addrstack_zero.
    eapply chained_S with (b':=b');eauto.
    + eapply h_forall_b.
      !intros.
      !!assert (S lvl <= S n) by lia.
      !!pose proof  (h_forall_lvl _ h_le1).
      decomp h_ex.
      cbn in *.
      !!specialize build_loads__decomp_S with (1:=h_CM_eval_expr_sp') (2:=h_CM_eval_expr) as ?.
      decomp h_ex.
      subst_det_addrstack_zero.
      eauto.
    + !inversion h_CM_eval_expr_sp'.
      subst_det_addrstack_zero.
      assumption.
Qed.

Lemma assignment_preserve_chained_stack_structure_aux:
  forall stkptr m chk e_t_v addr_blck addr_ofs m' n,
    chained_stack_structure m n stkptr ->
    (4 <= (Ptrofs.unsigned addr_ofs))%Z ->
    Mem.storev chk m (Values.Vptr addr_blck addr_ofs) e_t_v = Some m' ->
    chained_stack_structure m' n stkptr.
Proof.
  !intros.
  induction h_chain_m_n_stkptr.
  - constructor.
  - econstructor.
    all:swap 1 2.
    + unfold Mem.loadv.
      unfold Mem.storev in heq_storev_e_t_v_m'.
      erewrite Mem.load_store_other with (m1:=m);eauto.
    + assumption.
Qed.

(*
Lemma add_Vint_zero: forall m vaddr x,
    Mem.loadv AST.Mint32 m vaddr = Some x ->
    Values.Val.add x (Values.Vint Int.zero) = x.
Proof.
  !intros.
  destruct vaddr;cbn in *; try discriminate.
  cbn.
Qed.
 *)

Lemma chained_stack_structure_decomp_S_2': forall n m sp,
    chained_stack_structure m (S n) sp ->
    forall g e v sp',
      Cminor.eval_expr g sp e m (Eload AST.Mint32 (Econst (Oaddrstack Ptrofs.zero))) sp' ->
      Cminor.eval_expr g sp' e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) v ->
      Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) (S n)) v.
Proof.
  intro n.
  !induction n.
  - !intros.
    cbn in *.
    !inversion h_CM_eval_expr_sp'.
    !inversion h_CM_eval_expr_vaddr.
    !inversion h_CM_eval_expr_v.
    cbn in *.
    !invclear h_eval_constant.
    !invclear h_eval_constant0;subst.
    assert (exists b, sp' = Values.Vptr b Ptrofs.zero).
    { !inversion h_chain_m.
      cbn in *.
      rewrite Ptrofs.add_zero in h_loadv_vaddr_sp'.
      rewrite h_loadv_vaddr_sp' in h_loadv.
      inversion h_loadv.
      eauto. }
    decomp H;subst.
    econstructor;cbn;eauto.
  - !intros.
    cbn in h_CM_eval_expr_v.
    cbn.
    inversion h_CM_eval_expr_v;subst.
    econstructor;eauto.
    eapply h_forall_m;eauto.
    eapply chained_stack_structure_le;eauto.
Qed.

Lemma chain_structure_spec:
  forall n m sp ,
    chained_stack_structure m n sp ->
    forall g e,
      exists b, Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) (Values.Vptr b Ptrofs.zero).
Proof.
  !!intros until 1.
  !induction h_chain_m_n_sp;!intros.
  - exists b.
    eapply cm_eval_addrstack_zero;eauto.
  - specialize (h_forall_g g e).
    decomp h_forall_g.
    exists b0.
    eapply chained_stack_structure_decomp_S_2';eauto.
    + econstructor;eauto.
    + econstructor;eauto.
      constructor.
      reflexivity.
Qed.

Lemma chain_repeat_loadv_1 : forall m n sp,
    chained_stack_structure m n sp ->
    forall v g e, repeat_Mem_loadv AST.Mint32 m n sp v ->
                  Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) v.
Proof.
  !!intros until 1.
  !induction h_chain_m_n_sp;cbn;!intros.
  - !inversion h_repeat_loadv_O.
    apply cm_eval_addrstack_zero.
  - eapply chained_stack_structure_decomp_S_2'.
    + econstructor;eauto.
    + econstructor;eauto.
      econstructor;eauto.
    + eapply h_forall_v;eauto.
      !inversion h_repeat_loadv.
      rewrite h_loadv in h_loadv_sp'.
      !invclear h_loadv_sp'.
      assumption.
Qed.

Lemma chained_stack_structure_decomp_S_2: forall n m sp,
    chained_stack_structure m (S n) sp ->
    forall g e v,
      Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) (S n)) v ->
      exists sp',
        Cminor.eval_expr g sp e m (Eload AST.Mint32 (Econst (Oaddrstack Ptrofs.zero))) sp' /\
        Cminor.eval_expr g sp' e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) v.
Proof.
  intro n.
  !induction n.
  - !intros.
    cbn in *.
    exists v;split;auto.
    constructor;cbn.
    !!pose proof chained_stack_structure_aux _ _ _ h_chain_m g e.
    decomp h_ex.
    subst_det_addrstack_zero.
    cbn.
    rewrite Ptrofs.add_zero.
    reflexivity.
  - !intros.
    cbn in h_CM_eval_expr_v.
    !inversion h_CM_eval_expr_v;subst.
    change (Eload AST.Mint32 (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) with (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) (S n)) in h_CM_eval_expr_vaddr.
    !assert (chained_stack_structure m (S n) sp).
    { eapply chained_stack_structure_le;eauto. }
    specialize h_forall_m with (1:=h_chain_m0) (2:=h_CM_eval_expr_vaddr).
    decomp h_forall_m.
    exists sp';split;auto.
    cbn.
    econstructor;eauto.
Qed.

(* We can cut a chain into a smaller chain. *)
Lemma chain_structure_cut:
  forall n'' n' m sp ,
    chained_stack_structure m (n'+n'') sp ->
    forall g e,
      exists v sp' : Values.val,
        Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) (n'+n'')%nat) v
        /\ Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n'') sp'
        /\ Cminor.eval_expr g sp' e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n') v
        /\ chained_stack_structure m n' sp'.
Proof.
  !!intros * ? *.
  !!pose proof chain_structure_spec _ _ _ h_chain_m g e.
  decomp h_ex.
  exists (Values.Vptr b Ptrofs.zero).
  revert dependent h_CM_eval_expr.
  revert dependent h_chain_m.
  revert n' m sp g e b.
  !induction n'';!intros;up_type.
  - replace (n'+0)%nat with n' in * by lia.
    exists sp;split;[eauto| split;eauto].
    cbn.
    eapply cm_eval_addrstack_zero_chain;eauto.
  - specialize (h_forall_n' (S n') m sp g e b).
    !assert (chained_stack_structure m (S n' + n'') sp).
    { replace (n' + S n'')%nat with (S n' + n'')%nat in h_chain_m; try lia.
      assumption. }
    specialize (h_forall_n' h_chain_m0).
    replace (n' + S n'')%nat with (S n' + n'')%nat in h_CM_eval_expr; try lia.
    specialize (h_forall_n' h_CM_eval_expr).
    decomp h_forall_n'.
    !specialize chained_stack_structure_decomp_S_2 with (1:=h_chain_m1)(2:=h_CM_eval_expr1) as ?.
    decomp h_ex.
    exists sp'0;split;[|split;[|split]];eauto.
    + replace (n' + S n'')%nat with (S n' + n'')%nat; try lia.
      assumption.
    + cbn.
      econstructor.
      * eassumption.
      * !inversion h_CM_eval_expr_sp'0.
        repeat subst_det_addrstack_zero.
        assumption.
    + !inversion h_CM_eval_expr_sp'0;subst.
      repeat subst_det_addrstack_zero.
      clear h_chain_m h_chain_m0.
      !inversion h_chain_m1;subst;up_type.
      cbn in *.
      rewrite h_loadv in h_loadv_vaddr_sp'0.
      inversion h_loadv_vaddr_sp'0.
      subst.
      assumption.
Qed.

Lemma chained_stack_structure_decomp_S_3: forall n m sp n_base,
    chained_stack_structure m (S n + n_base) sp ->
    let base := (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n_base) in
    forall g e v,
      Cminor.eval_expr g sp e m (build_loads_ base (S n)) v ->
      exists sp',
        Cminor.eval_expr g sp e m (Eload AST.Mint32 (Econst (Oaddrstack Ptrofs.zero))) sp' /\
        Cminor.eval_expr g sp' e m (build_loads_ base n) v.
Proof.
  !intros.
  unfold base in h_CM_eval_expr_v.
  rewrite <- build_loads_compos in h_CM_eval_expr_v.
  cbn [plus] in h_CM_eval_expr_v.
  !!pose proof chained_stack_structure_decomp_S_2 _ _ _ h_chain_m g e v h_CM_eval_expr_v.
  decomp h_ex.
  exists sp';split;eauto.
  unfold base.
  rewrite <- build_loads_compos_comm.
  rewrite Nat.add_comm.
  assumption.
Qed.

Lemma chained_stack_structure_decomp_add: forall n1 n2 m sp,
    chained_stack_structure m (n1 + n2) sp ->
    forall g e v,
      Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) (n1 + n2)) v ->
      exists sp',
        Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n2) sp' /\
        Cminor.eval_expr g sp' e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n1) v.
Proof.
  !!intros until e.
  specialize chain_structure_cut with (1:=h_chain_m)(g:=g)(e:=e) as h.
  decomp h.
  !intros.
  subst_det_addrstack_zero.
  exists sp'.
  split;auto.
Qed.

Lemma chained_stack_structure_decomp_add': forall n1 n2 m sp sp' g e v,
    chained_stack_structure m (n1 + n2) sp ->
    Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n2) sp' ->
    Cminor.eval_expr g sp' e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n1) v ->
    Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) (n1 + n2)) v.
Proof.
  !!intros until 1.
  specialize chain_structure_cut with (1:=h_chain_m)(g:=g)(e:=e) as h.
  decomp h.
  !intros.
  repeat subst_det_addrstack_zero.
  assumption.
Qed.

Lemma chain_repeat_loadv_2: forall (m : mem) (n : nat) (sp : Values.val),
    chained_stack_structure m n sp
    -> forall (v : Values.val) (g : genv) (e : env),
      eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) v
      -> repeat_Mem_loadv AST.Mint32 m n sp v.
Proof.
  !!intros until 1.
  !induction h_chain_m_n_sp;!intros.
  - !inversion h_CM_eval_expr_v.
    inversion h_eval_constant.
    rewrite Ptrofs.add_zero_l.
    constructor.
  - assert (chained_stack_structure m (S n) (Values.Vptr b Ptrofs.zero)) by (econstructor;eauto).
    econstructor 2.
    all:swap 1 2.
    + eassumption.
    + eapply h_forall_v with (g:=g)(e:=e).
      cbn in h_CM_eval_expr_v.
      specialize chained_stack_structure_decomp_S_2 with (1:=H)(2:=h_CM_eval_expr_v) as h.
      decomp h.
      !assert ((Values.Vptr b' Ptrofs.zero) = sp').
      { clear h_CM_eval_expr_v0.
        !inversion h_CM_eval_expr_sp';subst.
        !inversion h_CM_eval_expr_vaddr.
        cbn in h_eval_constant.
        rewrite Ptrofs.add_zero_l in h_eval_constant.
        inversion h_eval_constant.
        subst.
        rewrite h_loadv in h_loadv_vaddr_sp'.
        inversion h_loadv_vaddr_sp'.
        auto. }
      rewrite heq_vptr_b'_zero.
      assumption.
Qed.

Lemma chain_repeat_loadv: forall (m : mem) (n : nat) (sp : Values.val),
    chained_stack_structure m n sp
    -> forall (v : Values.val) (g : genv) (e : env),
      repeat_Mem_loadv AST.Mint32 m n sp v
      <-> eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) v.
Proof.
  split.
  - apply chain_repeat_loadv_1;auto.
  - apply chain_repeat_loadv_2;auto.
Qed.

Lemma chain_struct_build_loads_ofs : forall  m n sp_init,
    chained_stack_structure m n sp_init ->
    forall δ_var g e b ofs,
      (δ_var mod Ptrofs.modulus)%Z = δ_var ->
      Cminor.eval_expr g sp_init e m (build_loads n δ_var) (Values.Vptr b ofs) ->
      ofs = Ptrofs.repr δ_var.
Proof.
  !intros.
  !!pose proof chained_stack_struct_inv_sp_zero _ _ _ h_chain_m_n_sp_init.
  decomp h_ex;subst.
  unfold build_loads in h_CM_eval_expr;cbn.
  !invclear h_CM_eval_expr.
  !inversion h_CM_eval_expr_v2;subst;cbn in *.
  !invclear h_eval_binop_Oadd_v1_v2.
  !invclear h_eval_constant.
  replace n with (0+n)%nat in h_CM_eval_expr_v1,h_chain_m_n_sp_init by auto with arith.
  !!pose proof chain_structure_cut _ _ _ _ h_chain_m_n_sp_init g e.
  decomp h_ex.
  replace (0+n)%nat with n in h_CM_eval_expr_v1,h_chain_m_n_sp_init by auto with arith.
  subst_det_addrstack_zero.
  !!pose proof chained_stack_struct_inv_sp_zero _ _ _ h_chain_m_O_sp'.
  decomp h_ex.
  subst.
  cbn in h_val_add_v1_v2.
  rewrite Ptrofs.add_zero_l in h_val_add_v1_v2.
  destruct Archi.ptr64.
  - inversion h_val_add_v1_v2.
  - !inversion h_val_add_v1_v2.
    unfold Ptrofs.of_int.
    rewrite Int.unsigned_repr_eq.
    apply f_equal;auto.
Qed.

Lemma malloc_preserves_chained_structure :
  forall lvl m sp b ofs  m' new_sp,
    Mem.alloc m b ofs = (m', new_sp) ->
    chained_stack_structure m lvl sp ->
    chained_stack_structure m' lvl sp.
Proof.
  intro lvl.
  !induction lvl;!intros.
  - !inversion h_chain_m_O_sp.
    constructor.
  - !inversion h_chain_m.
    cbn in *.
    econstructor.
    + eapply h_forall_m;eauto.
    + cbn.
      eapply Mem.load_alloc_other;eauto.
Qed.

Lemma malloc_preserves_chaining_loads :
  forall m lvl sp sz m' new_sp,
    Mem.alloc m 0 sz = (m', new_sp) ->
    forall n, (n <= lvl)%nat ->
         chained_stack_structure m lvl sp ->
         forall e g sp',
           Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) sp'
           -> Cminor.eval_expr g sp e m' (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) sp'.
Proof.
  !!intros until n.
  induction n;!intros.
  - cbn in *.
    !!pose proof chained_stack_struct_inv_sp_zero _ _ _ h_chain_m_lvl_sp.
    decomp h_ex.
    subst.
    subst_det_addrstack_zero.
    apply cm_eval_addrstack_zero.
  - !!assert (n <= lvl)%nat by lia.
    specialize (IHn h_le_n_lvl h_chain_m_lvl_sp).
    cbn -[Mem.storev] in *.
    !inversion h_CM_eval_expr_sp'.
    specialize (IHn _ _ _ h_CM_eval_expr_vaddr).
    econstructor.
    + eassumption.
    + cbn in *.
      rewrite <- h_loadv_vaddr_sp'.
      destruct vaddr; try discriminate.
      cbn in *.
      eapply Mem.load_alloc_unchanged;eauto.
      eapply Mem.valid_access_valid_block.
      apply Mem.load_valid_access in h_loadv_vaddr_sp'.
      eapply Mem.valid_access_implies with (1:=h_loadv_vaddr_sp').
      constructor.
Qed.

Lemma malloc_preserves_chaining_loads_2 :
  forall m lvl sp sz m' new_sp,
    Mem.alloc m 0 sz = (m', new_sp) ->
    forall n, (n <= lvl)%nat ->
         chained_stack_structure m lvl sp ->
         forall e g sp',
           Cminor.eval_expr g sp e m' (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) sp'
           -> Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) sp'.
Proof.
  !!intros until n.
  induction n;!intros.
  - cbn in *.
    !!pose proof chained_stack_struct_inv_sp_zero _ _ _ h_chain_m_lvl_sp.
    decomp h_ex.
    subst.
    subst_det_addrstack_zero.
    apply cm_eval_addrstack_zero.
  - !!assert (n <= lvl)%nat by lia.
    specialize (IHn h_le_n_lvl h_chain_m_lvl_sp).
    cbn -[Mem.storev] in *.
    !inversion h_CM_eval_expr_sp'.
    specialize (IHn _ _ _ h_CM_eval_expr_vaddr).
    econstructor.
    + eassumption.
    + cbn in *.
      rewrite <- h_loadv_vaddr_sp'.
      destruct vaddr; try discriminate.
      cbn in *.
      symmetry.
      eapply Mem.load_alloc_unchanged;eauto.
      destruct (Mem.valid_block_alloc_inv _ _ _ _ _ h_malloc_m_m' b).
      * eapply Mem.valid_access_valid_block.
        apply Mem.load_valid_access in h_loadv_vaddr_sp'.
        eapply Mem.valid_access_implies with (1:=h_loadv_vaddr_sp').
        constructor.
      * exfalso.
        subst.
        !!assert ((lvl-n) + n = lvl)%nat by lia.
        rewrite <- heq_add in h_chain_m_lvl_sp.
        !!pose proof (chain_structure_cut _ _ _ _ h_chain_m_lvl_sp) g e.
        decomp h_ex.
        rewrite heq_add in h_CM_eval_expr_v.
        subst_det_addrstack_zero.
        destruct (lvl - n)%nat eqn:heq'.
        -- exfalso; lia.
        -- cbn in h_CM_eval_expr_v0.
           eapply chained_stack_structure_decomp_S_2 in h_CM_eval_expr_v0.
           ++ decomp h_CM_eval_expr_v0.
              !inversion h_CM_eval_expr_sp'0.
              subst_det_addrstack_zero.
              absurd (Mem.valid_block m new_sp).
              ** eapply Mem.fresh_block_alloc;eauto.
              ** unfold Mem.loadv in h_loadv_vaddr_sp'0.
                 eapply  Mem.load_valid_access in h_loadv_vaddr_sp'0.
                 eapply Mem.valid_access_valid_block.
                 eapply Mem.valid_access_implies;eauto.
                 constructor.
           ++ assumption.
      * assumption.
Qed.

Lemma malloc_distinct_from_chaining_loads :
  forall lvl m sp,
    chained_stack_structure m lvl sp ->
    forall n sz m' new_sp,
      Mem.alloc m 0 sz = (m', new_sp) ->
      forall e g, (n < lvl)%nat -> forall b' ,
          Cminor.eval_expr g sp e m
                           ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) (Values.Vptr b' Ptrofs.zero)
          -> b' <> new_sp.
Proof.
  !!intros * ?.
  !induction h_chain_m_lvl_sp;cbn;!intros.
  - exfalso;lia.
  - destruct n0.
    + cbn in *.
      !!subst_det_addrstack_zero.
      !invclear H.
      intro abs;subst b.
      !!pose proof Mem.load_valid_access _ _ _ _ _ h_loadv.
      !!pose proof Mem.fresh_block_alloc _ _ _ _ _ h_malloc_m_m'.
      apply h_neg_valid_blck_m_new_sp.
      eapply Mem.valid_access_valid_block.
      eapply Mem.valid_access_implies with (1:=h_valid_access_new_sp).
      constructor.
    + eapply h_forall_n with (n0:=n0);eauto.
      * lia.
      * !assert(chained_stack_structure m (S n) (Values.Vptr b Ptrofs.zero)).
        { econstructor;eauto. }
        !assert(chained_stack_structure m (S n0) (Values.Vptr b Ptrofs.zero)).
        { eapply chained_stack_structure_le with (n:=S n).
          - assumption.
          - lia. }
        !!pose proof chained_stack_structure_decomp_S_2 _ _ _ h_chain_m0 g e _ h_CM_eval_expr.
        decomp h_ex.
        !inversion h_CM_eval_expr_sp'.
        subst_det_addrstack_zero.
        subst.
        rewrite h_loadv in h_loadv_vaddr_sp'.
        inversion h_loadv_vaddr_sp'.
        subst.
        eassumption.
Qed.

(* if we store in a block [sp0] not invovlved in the chaining from [sp], then
   all chainging addresses reachable from sp from sp'' are unchanged. *)
Lemma chain_aligned: forall m n stkptr,
  chained_stack_structure m n stkptr ->
  forall lgth_CE,
    (lgth_CE <= n)%nat ->
    forall locenv g,
      stack_localstack_aligned lgth_CE locenv g m stkptr.
Proof.
  !!intros until 1.
  unfold stack_localstack_aligned.
  !induction h_chain_m_n_stkptr;!intros.
  - exists b.
    assert (δ_lvl = 0%nat) by lia;subst.
    cbn.
    apply cm_eval_addrstack_zero.
  - destruct δ_lvl.
    + cbn.
      exists b.
      apply cm_eval_addrstack_zero.
    + cbn.
      !!destruct lgth_CE;[cbn in h_le_δ_lvl_lgth_CE;exfalso;lia|].
      subst;up_type.
      specialize (h_forall_lgth_CE lgth_CE).
      !!assert (lgth_CE <= n) by lia.
      !!assert (δ_lvl <= lgth_CE)%nat by lia.
      specialize (fun locenv g => h_forall_lgth_CE h_le_lgth_CE_n locenv g δ_lvl h_le_δ_lvl_lgth_CE0).
      specialize (h_forall_lgth_CE locenv g).
      decomp h_forall_lgth_CE.
      exists b_δ.
      assert (chained_stack_structure m (S δ_lvl) (Values.Vptr b Ptrofs.zero)).
      { econstructor; eauto.
        eapply chained_stack_structure_le;eauto.
        lia. }
      eapply chained_stack_structure_decomp_S_2';eauto.
      econstructor;eauto.
      eapply cm_eval_addrstack_zero_chain;eauto.
Qed.

Lemma storev_outside_struct_chain_preserves_chaining:
  forall sp0 e sp g m lvl,
      (* chainging addresses are unchanged. *)
      (forall n, (n < lvl)%nat -> forall b' ,
            Cminor.eval_expr g sp e m
                             ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) (Values.Vptr b' Ptrofs.zero)
            -> b' <> sp0) ->
      forall n, chained_stack_structure m lvl sp ->
           forall x _v _chk m', Mem.storev _chk m (Values.Vptr sp0 _v) x = Some m' ->
                   (n <= lvl)%nat -> forall v,
                       Cminor.eval_expr g sp e m ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) v
                       -> Cminor.eval_expr g sp e m' ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) v.
Proof.
  !!intros until lvl.
  intros h_eval_sp_lds n.
  !induction n;!intros.
  - cbn in *.
    !!pose proof chained_stack_struct_inv_sp_zero _ _ _ h_chain_m_lvl_sp.
    decomp h_ex.
    subst.
    subst_det_addrstack_zero.
    apply cm_eval_addrstack_zero.
  - !!assert (n <= lvl)%nat by lia.
    specialize (h_impl_forall_x h_chain_m_lvl_sp _ _ _ _ heq_storev_x_m' h_le_n_lvl).
    cbn -[Mem.storev] in *.
    !inversion h_CM_eval_expr_v.
    specialize (h_impl_forall_x _ h_CM_eval_expr_vaddr).
    econstructor.
    + eassumption.
    + cbn in *.
      destruct vaddr; try discriminate.
      cbn in *.
      pose proof Mem.load_store_other _ _ _ _ _ _ heq_storev_x_m' AST.Mint32 b (Ptrofs.unsigned i) as h.
      rewrite h.
      * assumption.
      * left.
        eapply h_eval_sp_lds with (n:=n).
        -- lia.
        -- assert (i = Ptrofs.zero).
           { !!pose proof chain_aligned _ _ _ h_chain_m_lvl_sp lvl (le_n _) e g.
             red in h_aligned_g_m.
             !!assert (n <= lvl) by lia.
             specialize (h_aligned_g_m _ h_le_n_lvl0).
             decomp h_aligned_g_m.
             !! (subst_det_addrstack_zero;idtac).
             inversion heq_vptr_b_i.
             reflexivity. }
           subst.
           eassumption.
Qed.

(* more general result: we can change something in the chained
structure but not the structure itself (chainging pointers. *)
Lemma gen_storev_outside_struct_chain_preserves_chaining:
  forall sp0 e sp g m lvl ofs0,
    (* chainging addresses are unchanged. *)
    ((4 <= (Ptrofs.unsigned ofs0))%Z \/
    (forall n, (n < lvl)%nat -> forall b' ,
          Cminor.eval_expr
            g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)
            (Values.Vptr b' Ptrofs.zero)
          -> b' <> sp0)) ->
    forall n, chained_stack_structure m lvl sp ->
              forall x _chk m', Mem.storev _chk m (Values.Vptr sp0 ofs0) x = Some m' ->
                                (n <= lvl)%nat -> forall v,
                                    Cminor.eval_expr g sp e m ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) v
                                    -> Cminor.eval_expr g sp e m' ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) v.
Proof.
  !!intros until ofs0.
  intros h_eval_sp_lds n.
  !induction n;!intros.
  - cbn in *.
    !!pose proof chained_stack_struct_inv_sp_zero _ _ _ h_chain_m_lvl_sp.
    decomp h_ex.
    subst.
    subst_det_addrstack_zero.
    apply cm_eval_addrstack_zero.
  - !!assert (n <= lvl)%nat by lia.
    specialize h_impl_forall_x with (1:=h_chain_m_lvl_sp)(2:=heq_storev_x_m') (3:=h_le_n_lvl).
    cbn -[Mem.storev] in *.
    !inversion h_CM_eval_expr_v.
    specialize (h_impl_forall_x _ h_CM_eval_expr_vaddr).
    econstructor.
    + eassumption.
    + cbn in *.
      destruct vaddr; try discriminate.
      cbn in *.
      pose proof Mem.load_store_other _ _ _ _ _ _ heq_storev_x_m' AST.Mint32 b (Ptrofs.unsigned i) as h.
      rewrite h.
      * assumption.
      * !destruct h_eval_sp_lds.
        -- right.
           assert (i = Ptrofs.zero).
           { !!specialize chained_stack_structure_le with (1:=h_chain_m_lvl_sp) (2:=h_le_n_lvl) as ?.
             !!specialize chain_structure_spec with (1:=h_chain_m_n_sp) (g:=g)(e:=e) as ?.
             decomp h_ex.
             !!specialize det_eval_expr with (1:=h_CM_eval_expr) (2:=h_CM_eval_expr_vaddr) as ?.
             !inversion heq_vptr_b0_zero.
             reflexivity. }
           subst.
           left.
           cbn.
           rewrite Ptrofs.unsigned_zero.
           lia.
        -- left.
           eapply h_forall_n with (n:=n).
           ++ lia.
           ++ assert (i = Ptrofs.zero).
              { !!pose proof chain_aligned _ _ _ h_chain_m_lvl_sp lvl (le_n _) e g.
                red in h_aligned_g_m.
                !!assert (n <= lvl) by lia.
                specialize (h_aligned_g_m _ h_le_n_lvl0).
                decomp h_aligned_g_m.
                !! (subst_det_addrstack_zero;idtac).
                inversion heq_vptr_b_i.
                reflexivity. }
              subst.
              eassumption.
Qed.

Lemma storev_outside_struct_chain_preserves_chaining2:
  forall sp0 e sp g m lvl,
      (* chainging addresses are unchanged. *)
      (forall n, (n < lvl)%nat -> forall b' ,
            Cminor.eval_expr g sp e m
                             ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) (Values.Vptr b' Ptrofs.zero)
            -> b' <> sp0) ->
      forall n, chained_stack_structure m lvl sp ->
           forall x _v _chk m', Mem.storev _chk m (Values.Vptr sp0 _v) x = Some m' ->
                   (n <= lvl)%nat -> forall v,
                       Cminor.eval_expr g sp e m' ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) v
                       -> Cminor.eval_expr g sp e m ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) v.
Proof.
  !!intros until lvl.
  intros h_eval_sp_lds n.
  !induction n;!intros.
  - cbn in *.
    !!pose proof chained_stack_struct_inv_sp_zero _ _ _ h_chain_m_lvl_sp.
    decomp h_ex.
    subst.
    subst_det_addrstack_zero.
    apply cm_eval_addrstack_zero.
  - !!assert (n <= lvl)%nat by lia.
    specialize (h_impl_forall_x h_chain_m_lvl_sp _ _ _ _ heq_storev_x_m' h_le_n_lvl).
    cbn -[Mem.storev] in *.
    !inversion h_CM_eval_expr_v.
    specialize (h_impl_forall_x _ h_CM_eval_expr_vaddr).
    econstructor.
    + eassumption.
    + cbn in *.
      destruct vaddr; try discriminate.
      cbn in *.
      pose proof Mem.load_store_other _ _ _ _ _ _ heq_storev_x_m' AST.Mint32 b (Ptrofs.unsigned i) as h.
      rewrite <- h.
      * assumption.
      * left.
        eapply h_eval_sp_lds with (n:=n).
        -- lia.
        -- assert (i = Ptrofs.zero).
           { !!pose proof chain_aligned _ _ _ h_chain_m_lvl_sp lvl (le_n _) e g.
             red in h_aligned_g_m.
             !!assert (n <= lvl) by lia.
             specialize (h_aligned_g_m _ h_le_n_lvl0).
             decomp h_aligned_g_m.
             !! (subst_det_addrstack_zero;idtac).
             inversion heq_vptr_b_δ_zero.
             reflexivity. }
           subst.
           eassumption.
Qed.

(* More general result *)
Lemma gen_storev_outside_struct_chain_preserves_chaining2:
  forall sp0 e sp g m lvl ofs0,
    (* chainging addresses are unchanged. *)
    ((4 <= (Ptrofs.unsigned ofs0))%Z \/
     forall n, (n < lvl)%nat -> forall b' ,
         Cminor.eval_expr g sp e m
                          ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) (Values.Vptr b' Ptrofs.zero)
         -> b' <> sp0) ->
    forall n, chained_stack_structure m lvl sp ->
              forall x _chk m', Mem.storev _chk m (Values.Vptr sp0 ofs0) x = Some m' ->
                                   (n <= lvl)%nat -> forall v,
                                       Cminor.eval_expr g sp e m' ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) v
                                       -> Cminor.eval_expr g sp e m ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) v.
Proof.
  !!intros until ofs0.
  intros h_eval_sp_lds n.
  !induction n;!intros.
  - cbn in *.
    !!specialize chained_stack_struct_inv_sp_zero with (1:=h_chain_m_lvl_sp) as ?.
    decomp h_ex.
    subst.
    subst_det_addrstack_zero.
    apply cm_eval_addrstack_zero.
  - !!assert (n <= lvl)%nat by lia.
    specialize h_impl_forall_x with (1:=h_chain_m_lvl_sp) (2:=heq_storev_x_m') (3:=h_le_n_lvl).
    cbn -[Mem.storev] in *.
    !inversion h_CM_eval_expr_v.
    specialize (h_impl_forall_x _ h_CM_eval_expr_vaddr).
    econstructor.
    + eassumption.
    + cbn in *.
      destruct vaddr; try discriminate.
      cbn in *.
      pose proof Mem.load_store_other _ _ _ _ _ _ heq_storev_x_m' AST.Mint32 b (Ptrofs.unsigned i) as h.
      rewrite <- h.
      * assumption.
      * !destruct h_eval_sp_lds.
        -- right.
           assert (i = Ptrofs.zero).
           { !!specialize chained_stack_structure_le with (1:=h_chain_m_lvl_sp) (2:=h_le_n_lvl) as ?.
             !!specialize chain_structure_spec with (1:=h_chain_m_n_sp) (g:=g)(e:=e) as ?.
             decomp h_ex.
             !!specialize det_eval_expr with (1:=h_CM_eval_expr) (2:=h_impl_forall_x) as ?.
             !inversion heq_vptr_b0_zero.
             reflexivity. }
           subst.
           left.
           cbn.
           rewrite Ptrofs.unsigned_zero.
           lia.
        -- left.
           eapply h_forall_n with (n:=n).
           ++ lia.
           ++ assert (i = Ptrofs.zero).
              { !!pose proof chain_aligned _ _ _ h_chain_m_lvl_sp lvl (le_n _) e g.
                red in h_aligned_g_m.
                !!assert (n <= lvl) by lia.
                specialize (h_aligned_g_m _ h_le_n_lvl0).
                decomp h_aligned_g_m.
                !! (subst_det_addrstack_zero;idtac).
                inversion heq_vptr_b_δ_zero.
                reflexivity. }
              subst.
              eassumption.
Qed.

Lemma storev_outside_struct_chain_preserves_var_addresses:
  forall sp0 e sp g m lvl,
      (* chainging addresses are unchanged. *)
      (forall n, (n < lvl)%nat -> forall b' ,
            Cminor.eval_expr g sp e m
                             ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) (Values.Vptr b' Ptrofs.zero)
            -> b' <> sp0) ->
      forall n, chained_stack_structure m lvl sp ->
           forall x _v _chk m' δ, Mem.storev _chk m (Values.Vptr sp0 _v) x = Some m' ->
                   (n <= lvl)%nat -> forall v,
                       Cminor.eval_expr g sp e m ((build_loads n δ)) v
                       -> Cminor.eval_expr g sp e m' ((build_loads n δ)) v.
Proof.
  !!intros until lvl.
  intros h_eval_sp_lds n.
  !intros.
  unfold build_loads in *.
  !invclear h_CM_eval_expr_v.
  econstructor;[ | |eassumption].
  - eapply storev_outside_struct_chain_preserves_chaining;eauto.
  - !inversion h_CM_eval_expr_v2.
    constructor.
    assumption.
Qed.

Lemma storev_outside_struct_chain_preserves_var_addresses2:
  forall sp0 e sp g m lvl,
      (* chainging addresses are unchanged. *)
      (forall n, (n < lvl)%nat -> forall b' ,
            Cminor.eval_expr g sp e m
                             ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) (Values.Vptr b' Ptrofs.zero)
            -> b' <> sp0) ->
      forall n, chained_stack_structure m lvl sp ->
           forall x _v _chk m' δ, Mem.storev _chk m (Values.Vptr sp0 _v) x = Some m' ->
                   (n <= lvl)%nat -> forall v,
                       Cminor.eval_expr g sp e m' ((build_loads n δ)) v
                       -> Cminor.eval_expr g sp e m ((build_loads n δ)) v.
Proof.
  !!intros until lvl.
  intros h_eval_sp_lds n.
  !intros.
  unfold build_loads in *.
  !invclear h_CM_eval_expr_v.
  econstructor;[ | |eassumption].
  - eapply storev_outside_struct_chain_preserves_chaining2;eauto.
  - !inversion h_CM_eval_expr_v2.
    constructor.
    assumption.
Qed.

(* The content of variable do not change either (we go one lvl less deep, since we add one ELoad.  *)
Lemma storev_outside_struct_chain_preserves_var_value:
  forall sp0 e sp g m lvl,
      (* chainging addresses are unchanged. *)
      (forall n, (n <= lvl)%nat -> forall b' ,
            Cminor.eval_expr g sp e m
                             ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) (Values.Vptr b' Ptrofs.zero)
            -> b' <> sp0) ->
      forall n, chained_stack_structure m lvl sp ->
           forall x _v _chk _chk' m' δ, Mem.storev _chk m (Values.Vptr sp0 _v) x = Some m' ->
                   (n <= lvl)%nat -> forall v,
                       Cminor.eval_expr g sp e m (Eload _chk' (build_loads n δ)) v
                       -> Cminor.eval_expr g sp e m' (Eload _chk' (build_loads n δ)) v.
Proof.
  !!intros.
  rename h_forall_n into h_unch.
  !inversion h_CM_eval_expr_v.
  assert (h_unch':forall n : nat,
             (n < lvl)%nat
             -> forall b' : Values.block,
               Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) (Values.Vptr b' Ptrofs.zero) -> b' <> sp0).
  { intros.
    eapply h_unch with (n:=n0).
    - lia.
    - assumption. }
  !!pose proof storev_outside_struct_chain_preserves_var_addresses _ _ _ _ _ _ h_unch' _ h_chain_m_lvl_sp _ _ _ _ _ heq_storev_x_m' h_le_n_lvl _ h_CM_eval_expr_vaddr.
  econstructor;eauto.
  unfold build_loads in h_CM_eval_expr_vaddr, h_CM_eval_expr_vaddr0.
  !invclear h_CM_eval_expr_vaddr.
  !invclear h_CM_eval_expr_vaddr0.
  destruct vaddr;try discriminate.
  pose proof Mem.load_store_other _ _ _ _ _ _ heq_storev_x_m' _chk' b (Ptrofs.unsigned i) as h.
  unfold Mem.loadv in *.
  rewrite h.
  - assumption.
  - left.
    !assert (v1=(Values.Vptr b Ptrofs.zero)).
    { clear h.
      !!pose proof chain_aligned _ _ _ h_chain_m_lvl_sp lvl (le_n _) e g.
      red in h_aligned_g_m.
      !!assert (n <= lvl) by lia.
      specialize (h_aligned_g_m _ h_le_n_lvl0).
      decomp h_aligned_g_m.
      subst_det_addrstack_zero.
      f_equal.
      cbn in *.
      destruct v2;try discriminate.
      inversion h_eval_binop_Oadd_v1_v2.
      destruct Archi.ptr64;auto. }
    subst.
    eapply h_unch;eauto.
Qed.

Proposition storev_outside_struct_chain_preserves_chained_structure:
  forall (sp0 : Values.block) (e : env) (sp : Values.val) (g : genv) (m : mem) (lvl : nat),
    (forall n : nat,
        (n < lvl)%nat
        -> forall b' : Values.block,
          Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) (Values.Vptr b' Ptrofs.zero) -> b' <> sp0)
    -> chained_stack_structure m lvl sp
    -> forall (x : Values.val) (_v : ptrofs) (_chk : AST.memory_chunk) (m' : mem),
        Mem.storev _chk m (Values.Vptr sp0 _v) x = Some m' ->
        chained_stack_structure m' lvl sp.
Proof.
  !intros.
  assert
    ( forall n, (n <= lvl)%nat -> forall v : Values.val,
          Cminor.eval_expr g sp e m (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) v
          -> Cminor.eval_expr g sp e m' (build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n) v).
  { !intro.
    eapply storev_outside_struct_chain_preserves_chaining;eauto. }
  destruct (chained_stack_struct_inv_sp_zero _ _ _ h_chain_m_lvl_sp).
  subst.
  eapply chained_stack_structure_spec.
  !intros.
  !!pose proof chain_structure_spec lvl0 m (Values.Vptr x0 Ptrofs.zero).
  !!edestruct h_impl_forall_g with (g:=g) (e:=e).
  eapply chained_stack_structure_le;eauto;try lia.
  eauto.
Qed.

Lemma malloc_distinct_from_chaining_loads_2 :
  forall lvl m sp,
    chained_stack_structure m lvl sp ->
    forall n sz m' new_sp,
      Mem.alloc m 0 sz = (m', new_sp) ->
      forall e g, (n < lvl)%nat -> forall b' ,
          Cminor.eval_expr g sp e m'
                           ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) (Values.Vptr b' Ptrofs.zero)
          -> b' <> new_sp.
Proof.
  !intros.
  assert (Cminor.eval_expr g sp e m
                           ((build_loads_ (Econst (Oaddrstack Ptrofs.zero)) n)) (Values.Vptr b' Ptrofs.zero)).
  { eapply malloc_preserves_chaining_loads_2;eauto.
    eapply chained_stack_structure_le;eauto;try lia. }
  eapply malloc_distinct_from_chaining_loads; eauto.
Qed.


From Perennial.goose_lang Require Import notation typing.
From Perennial.goose_lang Require Import proofmode lifting lib.into_val.
From Perennial.goose_lang.lib Require Export proph.impl.

Set Default Proof Using "Type".

Section goose_lang.
Context `{ffi_sem: ffi_semantics} `{!ffi_interp ffi} `{!heapGS Σ}.
Context {ext_ty: ext_types ext}.

(** list-based prophecy variables (the most general underlying primitive) *)

Theorem wp_NewProph_list :
  {{{ True }}}
    NewProph #()
  {{{ (p : proph_id) pvs, RET #p; proph p pvs }}}.
Proof.
  iIntros (Φ) "_ HΦ". wp_lam.
  wp_apply wp_new_proph. iIntros (pvs v). by iApply "HΦ".
Qed.

Theorem wp_ResolveProph_list E (p : proph_id) pvs v :
  {{{ proph p pvs }}}
    ResolveProph (#p) (Val v) @ E
  {{{ pvs', RET (LitV LitUnit); ⌜pvs = v::pvs'⌝ ∗ proph p pvs' }}}.
Proof.
  iIntros (Φ) "Hp HΦ". wp_lam.
  wp_apply (wp_resolve_proph with "Hp"). auto.
Qed.

(** typed assign-once prophecy variables *)
Section once.
  Context `{!IntoVal T}.

  Definition proph_once (p : proph_id) (x : T) : iProp Σ :=
    ∃ pvs : list val, proph p pvs ∗
               ⌜match v ← head pvs; from_val v with
                | Some x' => x=x'
                | None => True
                end⌝.

  Theorem wp_NewProph_once :
    {{{ True }}}
      NewProph #()
    {{{ (p : proph_id) (x : T), RET #p; proph_once p x }}}.
  Proof.
    iIntros (Φ) "_ HΦ". iApply wp_NewProph_list; first done.
    iIntros "!> %p %pvs Hp".
    iApply ("HΦ" $! p (default (IntoVal_def T) (v ← head pvs; from_val v))).
    iExists pvs. iFrame. iPureIntro.
    destruct (head pvs); simpl; last done.
    destruct (from_val v); done.
  Qed.

  Theorem wp_ResolveProph_once (p : proph_id) (x y : T) v :
    from_val v = Some y →
    {{{ proph_once p x }}}
      ResolveProph (#p) (Val v)
    {{{ RET (LitV LitUnit); ⌜x = y⌝ }}}.
  Proof.
    iIntros (Hv Φ) "(%pvs & Hp & %Hpvs) HΦ".
    iApply (wp_ResolveProph_list with "Hp").
    iIntros "!> %pvs' [%Hpvs' _]". iApply "HΦ". iPureIntro.
    subst pvs. simpl in Hpvs.
    rewrite Hv in Hpvs. done.
  Qed.

End once.

End goose_lang.