Require Import List.
Import ListNotations.
Require Import Psatz.

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

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

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

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

Require Import oeuf.HighValues.
Require Import oeuf.OpaqueTypes.
Require Import oeuf.Monads.
Require Import oeuf.FullSemantics.

Lemma pos_lt_neq :
  forall p q,
    (p < q)%positive ->
    p <> q.
Proof.
  intros.
  unfold Pos.lt in H.
  intro. rewrite <- Pos.compare_eq_iff in H0.
  congruence.
Qed.

Lemma load_lt_nextblock :
  forall c m b ofs v,
    Mem.load c m b ofs = Some v ->
    (b < Mem.nextblock m)%positive.
Proof.
  intros.
  remember (Mem.nextblock_noaccess m) as H2.
  clear HeqH2.
  destruct (plt b (Mem.nextblock m)). assumption.
  app Mem.load_valid_access Mem.load.
  unfold Mem.valid_access in *.
  break_and. unfold Mem.range_perm in *.
  specialize (H ofs).
  assert (ofs <= ofs < ofs + size_chunk c).
  destruct c; simpl; omega.
  specialize (H H3).
  unfold Mem.perm in *.
  unfold Mem.perm_order' in H.
  rewrite H2 in H; eauto. inversion H.
Qed.

Definition mem_locked' (m m' : mem) (b : block) : Prop :=
  forall b',
    (b' < b)%positive ->
    forall ofs c v,
      Mem.load c m b' ofs = Some v ->
      Mem.load c m' b' ofs = Some v.

Definition mem_locked (m m' : mem) : Prop :=
  mem_locked' m m' (Mem.nextblock m).

Lemma alloc_mem_locked :
  forall m lo hi m' b,
    Mem.alloc m lo hi = (m',b) ->
    mem_locked m m'.
Proof.
  unfold mem_locked.
  unfold mem_locked'.
  intros.
  app Mem.alloc_result Mem.alloc. subst b.
  app load_lt_nextblock Mem.load.
  erewrite Mem.load_alloc_unchanged; eauto.
Qed.

Lemma load_all_mem_locked :
  forall m m',
    mem_locked m m' ->
    forall b,
      (b < Mem.nextblock m)%positive ->
      forall l ofs l',
        load_all (arg_addrs b ofs l) m = Some l' ->
        load_all (arg_addrs b ofs l) m' = Some l'.
Proof.
  induction l; intros.
  simpl in H1. inv H1. simpl. reflexivity.
  simpl in H1. repeat break_match_hyp; try congruence.
  invc H1.
  eapply IHl in Heqo0.
  simpl. rewrite Heqo0.
  unfold mem_locked in H.
  unfold mem_locked' in H.
  apply H in Heqo; auto. find_rewrite. reflexivity.
Qed.

Lemma load_all_mem_inj_id :
  forall m m',
    Mem.mem_inj inject_id m m' ->
    forall b l ofs l',
      load_all (arg_addrs b ofs l) m = Some l' ->
      exists l'',
        load_all (arg_addrs b ofs l) m' = Some l'' /\
        Forall2 (fun a b => Val.lessdef (snd a) (snd b)) l' l''.
Proof.
  induction l; intros0 Hload.
    { simpl in *. inject_some. eexists. split; eauto. }

  simpl in Hload.
  do 2 (break_match; try discriminate). inject_some.

  fwd eapply Mem.load_inj as HH; eauto.
    { reflexivity. }
    destruct HH as (v' & ? & ?).
    rewrite Z.add_0_r in *.
  fwd eapply IHl as HH; eauto.  destruct HH as (? & ? & ?).

  simpl.
  on _, fun H => rewrite H.
  on _, fun H => rewrite H.
  eexists. split; eauto.
  econstructor; eauto.
  rewrite <- val_inject_id. eauto.
Qed.

Lemma lessdef_def_eq : forall v v',
    Val.lessdef v v' ->
    v <> Vundef ->
    v' = v.
destruct v; intros0 Hld Hundef; try congruence.
all: invc Hld; reflexivity.
Qed.

Lemma value_inject_lessdef : forall A B (ge : Genv.t A B) m hv cv cv',
    value_inject ge m hv cv ->
    Val.lessdef cv cv' ->
    value_inject ge m hv cv'.
induction hv; intros0 Hvi Hld.

- on >@value_inject, invc. on >Val.lessdef, invc.
  econstructor; eauto.

- on >@value_inject, invc. on >Val.lessdef, invc.
  econstructor; eauto.

- on >@value_inject, invc. econstructor.
  fwd eapply lessdef_def_eq; eauto.
    { eapply opaque_type_inject_defined; eauto. }
  fix_existT. subst. auto.
Qed.

Lemma value_inject_defined : forall A B (ge : Genv.t A B) m hv cv,
    value_inject ge m hv cv ->
    cv <> Vundef.
intros0 Hvi. invc Hvi; try discriminate.
- eapply opaque_type_inject_defined; eauto.
Qed.

Lemma load_all_arg_addrs_zip : forall b ofs args m l,
    load_all (arg_addrs b ofs args) m = Some l ->
    exists cvs,
        l = zip args cvs /\
        length cvs = length args.
first_induction args; intros0 Hload; simpl in Hload.
  { inject_some. exists []. split; reflexivity. }

do 2 (break_match; try discriminate). inject_some.
fwd eapply IHargs as HH; eauto.  destruct HH as (? & ? & ?).
subst.
eexists (_ :: _). simpl. eauto.
Qed.

Lemma Forall2_eq : forall A (xs ys : list A),
    Forall2 (fun x y => x = y) xs ys ->
    xs = ys.
induction xs; destruct ys; intros0 HH; inversion HH; eauto.
- subst. erewrite IHxs; eauto.
Qed.

Lemma Forall2_eq' : forall A (xs ys : list A),
    xs = ys ->
    Forall2 (fun x y => x = y) xs ys.
induction xs; destruct ys; intros0 HH; inversion HH; eauto.
- subst. econstructor; eauto.
Qed.

Lemma zip_Forall2_eq_l : forall A B (xs : list A) (ys : list B),
    length xs = length ys ->
    Forall2 (fun x p => x = fst p) xs (zip xs ys).
induction xs; destruct ys; intros; try discriminate; constructor; eauto.
Qed.

Lemma zip_Forall2_eq_r : forall A B (xs : list A) (ys : list B),
    length xs = length ys ->
    Forall2 (fun y p => y = snd p) ys (zip xs ys).
induction xs; destruct ys; intros; try discriminate; constructor; eauto.
Qed.

Lemma mem_inj_id_value_inject_transport : forall A B (ge : Genv.t A B) m1 m2,
    forall b ofs head vals l',
    forall (P : Prop),
    Mem.mem_inj inject_id m1 m2 ->
    head <> Vundef ->
    (forall cvs,
        Forall2 (value_inject ge m1) vals cvs ->
        Forall2 (value_inject ge m2) vals cvs) ->
    (Mem.loadv Mint32 m2 (Vptr b ofs) = Some head ->
        load_all (arg_addrs b (Int.add ofs (Int.repr 4)) vals) m2 = Some l' ->
        (forall a b, In (a, b) l' -> value_inject ge m2 a b) ->
        P) ->
    (Mem.loadv Mint32 m1 (Vptr b ofs) = Some head ->
        load_all (arg_addrs b (Int.add ofs (Int.repr 4)) vals) m1 = Some l' ->
        (forall a b, In (a, b) l' -> value_inject ge m1 a b) ->
        P).
intros0 Hmi Hhdef Hvis HP Hhead Hla Hvi.

fwd eapply load_all_mem_inj_id as HH; eauto.
  destruct HH as (lv' & ? & ?).

fwd eapply load_all_arg_addrs_zip with (l := l') as HH; eauto.
  destruct HH as (cvs1 & ? & ?). subst l'.
fwd eapply load_all_arg_addrs_zip with (l := lv') as HH; eauto.
  destruct HH as (cvs2 & ? & ?). subst lv'.

fwd eapply zip_Forall2_eq_l with (xs := vals) (ys := cvs1); eauto.
fwd eapply zip_Forall2_eq_l with (xs := vals) (ys := cvs2); eauto.
fwd eapply zip_Forall2_eq_r with (xs := vals) (ys := cvs1); eauto.
fwd eapply zip_Forall2_eq_r with (xs := vals) (ys := cvs2); eauto.
remember (zip vals cvs1) as ps1.
remember (zip vals cvs2) as ps2.

assert (Forall (fun p => value_inject ge m1 (fst p) (snd p)) ps1).
  { rewrite Forall_forall. destruct x. eauto. }

assert (cvs1 = cvs2).
  { eapply Forall2_eq.
    list_magic_on (vals, (cvs1, (cvs2, (ps1, (ps2, tt))))).
    subst. symmetry.
    eapply lessdef_def_eq; eauto.
    eapply value_inject_defined; eauto. }
  subst cvs2.
replace ps2 with ps1 in * by congruence. clear dependent ps2.

eapply HP; eauto.

- unfold Mem.loadv in *.
  fwd eapply Mem.load_inj as HH; eauto. { reflexivity. } destruct HH as (v' & ? & ?).
    rewrite Z.add_0_r in *.
  replace head with v'; cycle 1.
    { eapply lessdef_def_eq; eauto. rewrite <- val_inject_id. auto. }
  auto.

- cut (Forall (fun p => value_inject ge m2 (fst p) (snd p)) ps1).
    { intros HH. intros. rewrite Forall_forall in HH.
      on _, eapply_lem HH. simpl in *. assumption. }
  specialize (Hvis cvs1). spec_assert Hvis.
    { list_magic_on (vals, (cvs1, (ps1, tt))). subst. auto. }
  list_magic_on (vals, (cvs1, (ps1, tt))).
  subst. auto.
Qed.

Lemma mem_inj_id_value_inject :
  forall m1 m2,
    Mem.mem_inj inject_id m1 m2 ->
    forall {A B} (ge : Genv.t A B) hv cv,
      value_inject ge m1 hv cv ->
      value_inject ge m2 hv cv.
intros0 Hmi. intros ? ? ge.
induction hv using value_rect_mut with
    (Pl := fun hvs => forall cvs,
        Forall2 (value_inject ge m1) hvs cvs ->
        Forall2 (value_inject ge m2) hvs cvs);
intros0 Hvi; simpl in *.

- invc Hvi.
  eapply mem_inj_id_value_inject_transport; eauto.
    { discriminate. }
  clear H1 H2 H4. intros.
  econstructor; eauto.

- invc Hvi.
  eapply mem_inj_id_value_inject_transport; eauto.
    { discriminate. }
  clear H1 H4 H6. intros.
  econstructor; eauto.

- invc Hvi.
  fix_existT. subst.
  econstructor; eauto.
  eapply opaque_type_value_val_inject; eauto.
  + eapply val_inject_id, Val.lessdef_refl.
  + unfold MemInjProps.same_offsets. intros0 HH. invc HH. reflexivity.

- invc Hvi. constructor.

- invc Hvi. econstructor; eauto.
Qed.

Lemma alloc_store :
  forall m lo hi m' b,
    Mem.alloc m lo hi = (m',b) ->
    forall v c,
      hi - lo > size_chunk c ->
      (align_chunk c | lo) ->
      { m'' : mem | Mem.store c m' b lo v = Some m''}.
Proof.
  intros.
  app Mem.valid_access_alloc_same Mem.alloc; try omega.
  app Mem.valid_access_implies Mem.valid_access.
  2: instantiate (1 := Writable); econstructor; eauto.
  eapply Mem.valid_access_store; eauto.
Qed.

Definition writable (m : mem) (b : block) (lo hi : Z) : Prop :=
  forall ofs k,
    lo <= ofs < hi ->
    Mem.perm m b ofs k Freeable.

Lemma alloc_writable :
  forall m lo hi m' b,
    Mem.alloc m lo hi = (m',b) ->
    writable m' b lo hi.
Proof.
  intros.
  unfold writable.
  intros.
  eapply Mem.perm_alloc_2; eauto.
Qed.

Lemma mem_locked_store_nextblock :
  forall m m',
    mem_locked m m' ->
    forall c ofs v m'',
      Mem.store c m' (Mem.nextblock m) ofs v = Some m'' ->
      mem_locked m m''.
Proof.
  intros.
  unfold mem_locked in *.
  unfold mem_locked' in *.
  intros.
  app Mem.load_store_other Mem.store.
  rewrite H0.
  eapply H; eauto.
  left.
  eapply pos_lt_neq; eauto.
Qed.

Lemma writable_storeable :
  forall m b lo hi,
    writable m b lo hi ->
    forall c v ofs,
      lo <= ofs < hi ->
      (align_chunk c | ofs) ->
      hi >= ofs + size_chunk c ->
      {m' : mem | Mem.store c m b ofs v = Some m' /\ writable m' b lo hi }.
Proof.
  intros.
  assert (Mem.valid_access m c b ofs Writable).
  unfold Mem.valid_access. split; auto.
  unfold Mem.range_perm. intros.
  unfold writable in H.
  eapply Mem.perm_implies; try apply H; eauto; try solve [econstructor].
  omega.
  app Mem.valid_access_store Mem.valid_access.
  destruct H3.
  exists x. split. apply e.
  unfold writable. intros.
  eapply Mem.perm_store_1; eauto.
Qed.

Lemma writable_storevable :
  forall m b lo hi,
    writable m b lo hi ->
    forall c v ofs,
      lo <= Int.unsigned ofs < hi ->
      (align_chunk c | Int.unsigned ofs) ->
      hi >= (Int.unsigned ofs) + size_chunk c ->
      {m' : mem | Mem.storev c m (Vptr b ofs) v = Some m' /\ writable m' b lo hi }.
Proof.
  intros.
  app writable_storeable writable.
Qed.

Lemma mem_locked_load :
  forall m m',
    mem_locked m m' ->
    forall c b ofs v,
      Mem.load c m b ofs = Some v ->
      Mem.load c m' b ofs = Some v.
Proof.
  intros.
  unfold mem_locked in *.
  unfold mem_locked' in *.
  eapply H; eauto.
  eapply load_lt_nextblock; eauto.
Qed.

Fixpoint store_multi chunk m b ofs vs : option mem :=
    match vs with
    | [] => Some m
    | v :: vs =>
            match Mem.store chunk m b ofs v with
            | Some m' => store_multi chunk m' b (ofs + size_chunk chunk) vs
            | None => None
            end
    end.

Fixpoint load_multi chunk m b ofs n : option (list val) :=
    match n with
    | O => Some []
    | S n =>
            match Mem.load chunk m b ofs with
            | Some v =>
                    match load_multi chunk m b (ofs + size_chunk chunk) n with
                    | Some vs => Some (v :: vs)
                    | None => None
                    end
            | None => None
            end
    end.

Lemma shrink_range_perm : forall m b lo1 hi1 lo2 hi2 k p,
        Mem.range_perm m b lo1 hi1 k p ->
        lo1 <= lo2 ->
        hi2 <= hi1 ->
        Mem.range_perm m b lo2 hi2 k p.
intros0 Hrp Hlo Hhi. unfold Mem.range_perm in *. intros.
eapply Hrp. lia.
Qed.

Lemma perm_store : forall chunk m1 b ofs v m2,
    Mem.store chunk m1 b ofs v = Some m2 ->
    forall b' ofs' k p,
    Mem.perm m1 b' ofs' k p <-> Mem.perm m2 b' ofs' k p.
intros. split.
- eapply Mem.perm_store_1; eauto.
- eapply Mem.perm_store_2; eauto.
Qed.

Lemma range_perm_store : forall chunk m1 b ofs v m2,
    Mem.store chunk m1 b ofs v = Some m2 ->
    forall b' lo hi k p,
    Mem.range_perm m1 b' lo hi k p <-> Mem.range_perm m2 b' lo hi k p.
intros. unfold Mem.range_perm. split; intros.
- rewrite <- perm_store; eauto.
- rewrite -> perm_store; eauto.
Qed.

Lemma load_multi_spec : forall chunk m b ofs n vs i v,
    load_multi chunk m b ofs n = Some vs ->
    nth_error vs i = Some v ->
    Mem.load chunk m b (ofs + size_chunk chunk * Z.of_nat i) = Some v.
first_induction n; intros0 Hload Hnth; simpl in Hload.
  { inject_some. destruct i; simpl in Hnth. all: discriminate. }

do 2 (break_match; try discriminate). inject_some.
destruct i.
- simpl in Hnth. inject_some.
  rewrite Nat2Z.inj_0. replace (ofs + _) with ofs by ring. auto.
- simpl in Hnth.
  rewrite Nat2Z.inj_succ. unfold Z.succ.
  replace (_ + _) with ((ofs + size_chunk chunk) + (size_chunk chunk * Z.of_nat i)) by ring.
  eapply IHn; eauto.
Qed.

Lemma valid_access_store_multi : forall chunk m b ofs vs,
    Mem.range_perm m b ofs (ofs + size_chunk chunk * Zlength vs) Cur Writable ->
    (align_chunk chunk | ofs) ->
    { m' : mem | store_multi chunk m b ofs vs = Some m' }.
first_induction vs; intros; simpl in *.
  { eauto. }

rename a into v.

fwd eapply Mem.valid_access_store with (m1 := m) (v := v) as HH.
  { econstructor; eauto. eapply shrink_range_perm; eauto.
    - lia.
    - rewrite Zlength_cons. rewrite <- Zmult_succ_r_reverse.
      assert (0 <= size_chunk chunk * Zlength vs).
        { eapply Z.mul_nonneg_nonneg.
          - destruct chunk; simpl; lia.
          - rewrite Zlength_correct. eapply Zle_0_nat. }
      lia.
  }
  destruct HH as [m' ?].
  rewrite range_perm_store in * by eauto.

fwd eapply IHvs with (m := m') (ofs := ofs + size_chunk chunk)
    (chunk := chunk) as HH; eauto.
  { eapply shrink_range_perm; eauto.
    - assert (0 <= size_chunk chunk) by (destruct chunk; simpl; lia).
      lia.
    - rewrite Zlength_cons. rewrite <- Zmult_succ_r_reverse.
      assert (0 <= size_chunk chunk) by (destruct chunk; simpl; lia).
      lia.
  }
  { eapply Z.divide_add_r; eauto.
    destruct chunk; simpl; eapply Zmod_divide; eauto. all: lia. }
  destruct HH as [m'' ?].

exists m''.
on _, fun H => rewrite H. eauto.
Qed.

Lemma Zlength_nonneg : forall A (xs : list A),
    0 <= Zlength xs.
intros. rewrite Zlength_correct.
eapply Zle_0_nat.
Qed.

Lemma alloc_range_perm : forall m lo hi m' b,
    Mem.alloc m lo hi = (m', b) ->
    Mem.range_perm m' b lo hi Cur Freeable.
intros0 Halloc.
unfold Mem.range_perm. intros. break_and.
fwd eapply Mem.valid_access_alloc_same with
    (m1 := m) (lo := lo) (hi := hi) (m2 := m') (b := b)
    (chunk := Mint8unsigned) (ofs := ofs) as HH; simpl in *; eauto.
  { lia. }
  { eapply Zmod_divide. lia. eapply Zmod_1_r. }
  unfold Mem.valid_access, Mem.range_perm in HH.
  destruct HH as [HH ?].
fwd eapply (HH ofs).
  { simpl. lia. }
  { auto. }
Qed.

Lemma load_store_multi_other : forall chunk m1 b ofs vs m2,
    store_multi chunk m1 b ofs vs = Some m2 ->
    forall chunk' b' ofs',
    b' <> b \/
        ofs' + size_chunk chunk' <= ofs \/
        ofs + size_chunk chunk * Zlength vs <= ofs' ->
    Mem.load chunk' m2 b' ofs' = Mem.load chunk' m1 b' ofs'.
first_induction vs; intros0 Hstore; intros0 Hnc.
  { simpl in Hstore. inject_some. eauto. }

simpl in Hstore. break_match; try discriminate. rename m2 into m3, m into m2.

fwd eapply Mem.load_store_other with (chunk' := chunk'); eauto.
  { break_or; [|break_or].
    - left. eauto.
    - right. left. eauto.
    - right. right.
      rewrite Zlength_cons in *. rewrite <- Zmult_succ_r_reverse in *.
      assert (0 <= size_chunk chunk * Zlength vs).
        { eapply Z.mul_nonneg_nonneg.
          - destruct chunk; simpl; lia.
          - eapply Zlength_nonneg. }
      lia.
  }

fwd eapply IHvs with (ofs' := ofs') (chunk' := chunk'); eauto.
  { break_or; [|break_or].
    - left. eauto.
    - right. left.
      assert (0 <= size_chunk chunk) by (destruct chunk; simpl; lia).
      lia.
    - right. right.
      rewrite Zlength_cons in *. rewrite <- Zmult_succ_r_reverse in *.
      lia.
  }

congruence.
Qed.

Lemma int_modulus_big : forall x,
    x < 256 ->
    x < Int.modulus.
intros. unfold Int.modulus.
replace 256 with (two_power_nat 8) in * by reflexivity.
rewrite two_power_nat_equiv in *.
fwd eapply Z.pow_le_mono_r with (a := 2) (b := 8) (c := Z.of_nat Int.wordsize).
  { lia. }
  { unfold Int.wordsize. simpl. lia. }
lia.
Qed.

Lemma int_unsigned_big : forall x,
    x < 256 ->
    x <= Int.max_unsigned.
intros.
fwd eapply int_modulus_big with (x := x); eauto.
unfold Int.max_unsigned. lia.
Qed.

Lemma store_multi_load_all_args : forall m1 b args ofs argvs m2,
    length args = length argvs ->
    0 <= ofs ->
    ofs + Zlength args * 4 <= Int.max_unsigned ->
    store_multi Mint32 m1 b ofs argvs = Some m2 ->
    Forall (fun v => v = Val.load_result Mint32 v) argvs ->
    load_all (arg_addrs b (Int.repr ofs) args) m2 = Some (zip args argvs).
first_induction args; destruct argvs; intros0 Hlen Hofs1 Hofs2 Hstore Hi32;
  try discriminate.
  { reflexivity. }

simpl in Hstore. simpl.
break_match_hyp; try discriminate. rename m2 into m3, m into m2.

fwd eapply Zlength_nonneg with (xs := a :: args).
rewrite Int.unsigned_repr by lia.

erewrite load_store_multi_other; eauto; cycle 1.
  { right. left. simpl. lia. }
erewrite Mem.load_store_same by eauto.

rewrite Int.add_unsigned.
rewrite Int.unsigned_repr by lia.
rewrite Int.unsigned_repr; cycle 1.
  { split; [lia|]. eapply int_unsigned_big. lia. }

invc Hi32.
erewrite IHargs; eauto.
- congruence.
- lia.
- rewrite Zlength_cons in Hofs2. unfold Z.succ in Hofs2. lia.
Qed.

Definition max_arg_count := Int.max_unsigned / 4 - 1.

Lemma max_arg_count_ok :
    4 + max_arg_count * 4 <= Int.max_unsigned.
unfold max_arg_count.
rewrite Z.mul_sub_distr_r.
remember (_ / 4 * 4) as x.  replace (4 + (x - 1 * 4)) with x by lia.  subst x.
remember Int.max_unsigned as x.
cut (0 <= x - x / 4 * 4).  { intro. lia. }
rewrite <- Zmod_eq by lia.
fwd eapply (Z_mod_lt x 4) as HH.  { lia. } break_and. auto.
Qed.

Lemma max_arg_count_value_size_ok : forall x,
    x <= max_arg_count ->
    4 + x * 4 <= Int.max_unsigned.
intros.
eapply Z.le_trans with (m := 4 + max_arg_count * 4).
  2: eapply max_arg_count_ok.
eapply Zplus_le_compat_l.
eapply Zmult_le_compat_r; eauto.
lia.
Qed.

Lemma max_arg_count_big : forall x,
    x < 256 ->
    x <= max_arg_count.
intros.
unfold max_arg_count.
cut (x + 1 <= Int.max_unsigned / 4). { intro. lia. }
eapply Z.div_le_lower_bound. { lia. }
unfold Int.max_unsigned.
cut (4 * (x + 1) + 1 <= Int.modulus). { intro. lia. }
cut (2048 <= Int.modulus). { intro. lia. }
change 2048 with (2 ^ 11). unfold Int.modulus. rewrite two_power_nat_equiv.
eapply Z.pow_le_mono_r.
- lia.
- unfold Int.wordsize. simpl. lia.
Qed.

Lemma value_inject_32bit : forall A B (ge : Genv.t A B) m hv cv,
    value_inject ge m hv cv ->
    Val.load_result Mint32 cv = cv.
intros0 Hval. invc Hval.
- reflexivity.
- reflexivity.
- eapply opaque_type_value_32bit; eauto.
Qed.

Lemma alloc_mem_inj_id : forall m1 lo hi m2 b,
    Mem.alloc m1 lo hi = (m2, b) ->
    Mem.mem_inj inject_id m1 m2.
intros.
eapply Mem.alloc_right_inj.
- eapply Mem.mext_inj. eapply Mem.extends_refl.
- eassumption.
Qed.

Definition range_undef m b lo hi :=
    forall chunk ofs v,
        lo <= ofs < hi ->
        Mem.load chunk m b ofs = Some v -> v = Vundef.

(* mem_inj can be carried through a store to a previously nonexistent block *)
Lemma store_new_block_mem_inj_id : forall m1 chunk m2 b ofs v m3,
    Mem.mem_inj inject_id m1 m2 ->
    (Mem.mem_contents m1) !! b = ZMap.init Undef ->
    Mem.store chunk m2 b ofs v = Some m3 ->
    Mem.mem_inj inject_id m1 m3.
intros.

eapply Mem.mk_mem_inj.

- intros. unfold inject_id in *. inject_some.
  unfold Mem.perm.
  replace (Mem.mem_access m3) with (Mem.mem_access m2); cycle 1.
    { symmetry. eapply Mem.store_access; eauto. }
  eapply Mem.mi_perm; eauto.

- intros. unfold inject_id in *. inject_some.
  destruct chunk0; simpl; eapply Zmod_divide; lia || eapply Zmod_0_l.

- intros. unfold inject_id in *. inject_some.

  fwd eapply Mem.store_mem_contents as HH; eauto. rewrite HH. clear HH.
  rewrite PMap.gsspec. break_match.

  + (* values inside the modified block *)
    replace (ofs0 + 0) with ofs0 by lia.
    subst b2.
    on (_ = ZMap.init Undef), fun H => rewrite H.
    rewrite ZMap.gi. constructor.

  + (* values inside other blocks *)
    eapply Mem.mi_memval; eauto.
Qed.

Lemma store_multi_new_block_mem_inj_id : forall m1 chunk m2 b ofs vs m3,
    Mem.mem_inj inject_id m1 m2 ->
    (Mem.mem_contents m1) !! b = ZMap.init Undef ->
    store_multi chunk m2 b ofs vs = Some m3 ->
    Mem.mem_inj inject_id m1 m3.
first_induction vs; intros0 Hinj Hnew Hstore; simpl in Hstore.
  { inject_some. eauto. }

break_match; try discriminate. rename m3 into m4, m into m3.
eapply IHvs with (m2 := m3); eauto.
eapply store_new_block_mem_inj_id; eauto.
Qed.

Lemma load_all_load_multi' : forall b ofs args m l,
    load_all (arg_addrs b ofs args) m = Some l ->
    0 <= Int.unsigned ofs ->
    Int.unsigned ofs + 4 * Zlength args <= Int.max_unsigned ->
    exists vs,
        load_multi Mint32 m b (Int.unsigned ofs) (length args) = Some vs /\
        l = zip args vs.
first_induction args; intros0 Hla Hmin Hmax; simpl in Hla.
  { inject_some. simpl. eauto. }

do 2 (break_match; try discriminate). inject_some.

assert (Hzlen : 4 * Zlength (a :: args) = 4 + 4 * Zlength args).
  { rewrite Zlength_cons. unfold Z.succ. ring. }
assert (Hi4 : Int.unsigned (Int.repr 4) = 4).
  { eapply Int.unsigned_repr. split.
    - lia.
    - eapply int_unsigned_big. lia. }
assert (Hofs4 : Int.unsigned (Int.add ofs (Int.repr 4)) = Int.unsigned ofs + 4).
  { rewrite Int.add_unsigned.
    rewrite Int.unsigned_repr, Hi4; [ reflexivity | split ]; rewrite Hi4.
    - lia.
    - rewrite Hzlen in Hmax.
      assert (0 <= 4 * Zlength args).
        { eapply Z.mul_nonneg_nonneg.
          - lia.
          - eapply Zlength_nonneg. }
      lia. }

fwd eapply IHargs as HH; eauto.  { lia. } { lia. }
  destruct HH as (vs & ? & ?). subst.

eexists. simpl.
on _, fun H => rewrite H.
rewrite <- Hofs4.  on _, fun H => rewrite H.
eauto.
Qed.

Lemma load_all_load_multi_4 : forall b args m l,
    load_all (arg_addrs b (Int.repr 4) args) m = Some l ->
    Zlength args <= max_arg_count ->
    exists vs,
        load_multi Mint32 m b 4 (length args) = Some vs /\
        l = zip args vs.
intros.
assert (Hi4 : Int.unsigned (Int.repr 4) = 4).
  { eapply Int.unsigned_repr. split; [lia|]. eapply int_unsigned_big. lia. }
rewrite <- Hi4.
eapply load_all_load_multi'; eauto; rewrite Hi4.
- lia.
- rewrite Z.mul_comm. eapply max_arg_count_value_size_ok. eauto.
Qed.

Lemma load_multi_load_all' : forall m b ofs n vs args,
    load_multi Mint32 m b ofs n = Some vs ->
    length args = n ->
    0 <= ofs ->
    ofs + 4 * Zlength args <= Int.max_unsigned ->
    load_all (arg_addrs b (Int.repr ofs) args) m = Some (zip args vs).
first_induction n; intros0 Hload Hlen Hmin Hmax; simpl in Hload.
  { inject_some. destruct args; try discriminate. simpl. reflexivity. }

do 2 (break_match; try discriminate). inject_some. destruct args; try discriminate.

assert (4 * Zlength (v0 :: args) = 4 + 4 * Zlength args).
  { rewrite Zlength_cons. unfold Z.succ. ring. }
assert (0 <= Zlength args) by eapply Zlength_nonneg.

fwd eapply IHn; eauto.  { lia. } { lia. }

simpl.
replace (Int.unsigned (Int.repr ofs)) with ofs; cycle 1.
  { symmetry. eapply Int.unsigned_repr. lia. }
replace (Int.add _ _) with (Int.repr (ofs + 4)); cycle 1.
  { rewrite Int.add_unsigned. rewrite 2 Int.unsigned_repr; eauto.
    - split; [lia|]. eapply int_unsigned_big. lia.
    - lia. }

on _, fun H => rewrite H.
on _, fun H => rewrite H.
eauto.
Qed.

Lemma load_multi_load_all_4 : forall m b n vs args,
    load_multi Mint32 m b 4 n = Some vs ->
    length args = n ->
    Zlength args <= max_arg_count ->
    load_all (arg_addrs b (Int.repr 4) args) m = Some (zip args vs).
intros.
eapply load_multi_load_all'; eauto.
- lia.
- rewrite Z.mul_comm. eapply max_arg_count_value_size_ok. eauto.
Qed.

Lemma load_all_inj_id : forall m1 m2 lp lv lp',
    Mem.mem_inj inject_id m1 m2 ->
    load_all lp m1 = Some lv ->
    Forall2 (fun a b => Val.inject inject_id (snd a) (snd b)) lp lp' ->
    exists lv',
        load_all lp' m2 = Some lv' /\
        Forall2 (fun a b => Val.inject inject_id (snd a) (snd b)) lv lv'.
first_induction lp; intros0 Hmi Hload Hvi; simpl in Hload.
  { inject_some. on >Forall2, invc. exists []. eauto. }

break_match. do 2 (break_match; try discriminate). inject_some. on >Forall2, invc.
simpl in * |-.

unfold Mem.loadv in * |-. break_match; try discriminate.
on >Val.inject, invc.
destruct y. simpl in * |-. subst.

unfold inject_id in *. inject_some.

fwd eapply Mem.load_inj as HH; eauto.  destruct HH as (v2 & ? & ?).
  rewrite Int.add_zero. rewrite Z.add_0_r in *.

fwd eapply IHlp as HH; eauto.  destruct HH as (lv' & ? & ?).

simpl.
do 2 on _, fun H => rewrite H.
eexists. split; [ reflexivity | ].
econstructor; eauto.
Qed.

Lemma inject_id_compose_self :
    compose_meminj inject_id inject_id = inject_id.
unfold compose_meminj, inject_id. rewrite Z.add_0_r in *. reflexivity.
Qed.

Section MEM_SIM.
Local Open Scope positive_scope.

Definition closure_sig_higher v :=
    match v with
    | HigherValue.Close fname free => Some (fname, length free)
    | _ => None
    end.

Definition Plt_dec : forall a b, ({ a < b } + { a >= b })%positive.
intros. destruct (a ?= b)%positive eqn:?.
- right. rewrite Pos.compare_eq_iff in *. lia.
- left. rewrite Pos.compare_lt_iff in *. lia.
- right. rewrite Pos.compare_gt_iff in *. lia.
Defined.

Definition pos_range_dec : forall min max x,
    ({ x >= min /\ x < max } + { x < min \/ x >= max })%positive.
intros.
destruct (Plt_dec x min), (Plt_dec x max).
- right. left. auto.
- right. left. auto.
- left. split; auto.
- right. right. auto.
Defined.

Definition mem_sim (mi mi' : block -> option (block * Z)) m1 m1' m2 m2' :=
    (* mi' maps new blocks on the left to new blocks on the right. *)
    (forall b,
        b >= Mem.nextblock m1 ->
        b < Mem.nextblock m1' ->
        exists b',
            mi' b = Some (b', 0%Z) /\
            b' >= Mem.nextblock m2 /\
            b' < Mem.nextblock m2') /\
    (* mi' behaves like mi on old blocks on the left. *)
    (forall b,
        b < Mem.nextblock m1 \/ b >= Mem.nextblock m1' ->
        mi' b = mi b) /\
    (* The new mappings introduced by mi' are injective. *)
    (forall b1 b2 b' delta1 delta2,
        b1 >= Mem.nextblock m1 ->
        b1 < Mem.nextblock m1' ->
        b2 >= Mem.nextblock m1 ->
        b2 < Mem.nextblock m1' ->
        mi' b1 = Some (b', delta1) ->
        mi' b2 = Some (b', delta2) ->
        b1 = b2) /\
    Mem.nextblock m1 <= Mem.nextblock m1' /\
    Mem.nextblock m2 <= Mem.nextblock m2'.

Lemma mem_sim_refl : forall mi m1 m1' m2 m2',
    Mem.nextblock m1 = Mem.nextblock m1' ->
    Mem.nextblock m2 = Mem.nextblock m2' ->
    mem_sim mi mi m1 m1' m2 m2'.
intros0 Hnext1 Hnext2. repeat apply conj; intros.
- exfalso. rewrite <- Hnext1 in *. lia.
- reflexivity.
- exfalso. rewrite <- Hnext1 in *. lia.
- rewrite Hnext1. lia.
- rewrite Hnext2. lia.
Qed.

(* Compose memory simulation "vertically", by adding more steps. *)
Lemma mem_sim_compose : forall mi mi' mi'' m1 m1' m1'' m2 m2' m2'',
    mem_sim mi mi' m1 m1' m2 m2' ->
    mem_sim mi' mi'' m1' m1'' m2' m2'' ->
    mem_sim mi mi'' m1 m1'' m2 m2''.
unfold mem_sim. intros0 Hsim Hsim'.
destruct Hsim as (Hnew & Hold & Hinj & Hext1 & Hext2).
destruct Hsim' as (Hnew' & Hold' & Hinj' & Hext1' & Hext2').
repeat apply conj; intros.

- assert (HH : b >= Mem.nextblock m1' \/ b < Mem.nextblock m1'). { lia. } destruct HH.
  + destruct (Hnew' ?? ** ** ) as (b' & ? & ? & ?).
    exists b'. repeat apply conj; eauto. lia.
  + destruct (Hnew ?? ** ** ) as (b' & ? & ? & ?).
    fwd eapply Hold' as HH; eauto.
    exists b'. repeat apply conj; eauto.
    * congruence.
    * lia.

- eapply eq_trans.
  + eapply Hold'. break_or; [left; lia | right; eauto].
  + eapply Hold. break_or; [left; eauto | right; lia].

- destruct (Plt_dec b1 (Mem.nextblock m1')), (Plt_dec b2 (Mem.nextblock m1')).

  + rewrite Hold' in *; eauto.

  + exfalso.
    (* impossible.  b1 is old, b2 is new, so they can't both map to b'. *)
    rewrite (Hold' b1) in *; eauto.
    fwd eapply (Hnew b1) as HH; eauto. destruct HH as (b1' & ? & ? & ?).
    fwd eapply (Hnew' b2) as HH; eauto. destruct HH as (b2' & ? & ? & ?).
    assert (b1' = b2') by congruence.
    assert (b1' < b2') by lia.
    subst b1'. lia.

  + exfalso.
    (* impossible.  b1 is old, b2 is new, so they can't both map to b'. *)
    rewrite (Hold' b2) in *; eauto.
    fwd eapply (Hnew' b1) as HH; eauto. destruct HH as (b1' & ? & ? & ?).
    fwd eapply (Hnew b2) as HH; eauto. destruct HH as (b2' & ? & ? & ?).
    assert (b1' = b2') by congruence.
    assert (b1' > b2') by lia.
    subst b1'. lia.

  + eauto.

- lia.
- lia.
Qed.

Lemma alloc_mem_sim : forall m1 m2 lo hi m1' b1 mi,
    Mem.alloc m1 lo hi = (m1', b1) ->
    Mem.inject mi m1 m2 ->
    exists mi' m2' b2,
        Mem.alloc m2 lo hi = (m2', b2) /\
        Mem.inject mi' m1' m2' /\
        mem_sim mi mi' m1 m1' m2 m2' /\
        mi' b1 = Some (b2, 0%Z).
intros0 Halloc Hinj.
fwd eapply Mem.alloc_parallel_inject with (lo2 := lo) (hi2 := hi) as HH; eauto.
  { lia. } { lia. }
  destruct HH as (mi' & m2' & b2 & ? & ? & ? & ? & ?).

fwd eapply Mem.nextblock_alloc with (m1 := m1); eauto.
fwd eapply Mem.alloc_result with (m1 := m1); eauto.
fwd eapply Mem.nextblock_alloc with (m1 := m2); eauto.
fwd eapply Mem.alloc_result with (m1 := m2); eauto.
rewrite <- Pos.add_1_l in *.

exists mi', m2', b2. repeat apply conj; eauto.
unfold mem_sim. repeat apply conj; eauto.

- intros.
  assert (b = b1). { subst b1. lia. }
  subst b.
  exists b2. split; eauto. subst. split; lia.

- intros.
  assert (b <> b1). { subst b1. lia. }
  eauto.

- intros b1' b2'. intros.
  assert (b1' = Mem.nextblock m1) by (zify; lia).
  assert (b2' = Mem.nextblock m1) by (zify; lia).
  congruence.

- lia.
- lia.
Qed.

End MEM_SIM.

Lemma build_constr_inject' : forall A B (ge : Genv.t A B) m0 m1 m2 m3 m4 b tag args argvs,
    Forall2 (value_inject ge m0) args argvs ->
    Zlength args <= max_arg_count ->
    Mem.alloc m0 (-4) ((1 + Zlength args) * 4) = (m1, b) ->
    Mem.store Mint32 m1 b (-4) (Vint (Int.repr ((1 + Zlength args) * 4))) = Some m2 ->
    Mem.store Mint32 m2 b 0 (Vint tag) = Some m3 ->
    store_multi Mint32 m3 b 4 argvs = Some m4 ->
    value_inject ge m4 (Constr tag args) (Vptr b Int.zero).
intros0 Hargs Hmax Hm1 Hm2 Hm3 Hm4.

assert ((Mem.mem_contents m1) !! b = ZMap.init Undef).
  { erewrite Mem.contents_alloc; eauto.
    erewrite <- Mem.alloc_result; eauto.
    erewrite PMap.gss. reflexivity. }

assert (Mem.mem_inj inject_id m0 m4).
  { rewrite <- inject_id_compose_self. eapply Mem.mem_inj_compose with (m2 := m1).
    - eapply alloc_mem_inj_id; eauto.
    - eapply store_multi_new_block_mem_inj_id; eauto.
      eapply store_new_block_mem_inj_id; eauto.
      eapply store_new_block_mem_inj_id; eauto.
      eapply Mem.mext_inj, Mem.extends_refl. }

econstructor.

- simpl.
  rewrite Int.unsigned_zero.
  erewrite load_store_multi_other; eauto; cycle 1.
    { right. left. simpl. lia. }
  fwd eapply Mem.load_store_same as HH; eauto.

- eapply store_multi_load_all_args; eauto.
  + eapply Forall2_length; eauto.
  + rewrite Int.unsigned_zero, Int.unsigned_repr; cycle 1.
      { split; [lia|]. eapply int_unsigned_big. lia. }
    lia.
  + rewrite Int.unsigned_zero, Int.unsigned_repr; cycle 1.
      { split; [lia|]. eapply int_unsigned_big. lia. }
    rewrite Z.add_0_l. eapply max_arg_count_value_size_ok. eauto.
  + list_magic_on (args, (argvs, tt)).
    symmetry. eapply value_inject_32bit. eassumption.

- intros0 Hin.
  eapply In_nth_error in Hin. destruct Hin as [n ?].
  on _, eapply_lem zip_nth_error. break_and.
  fwd eapply Forall2_nth_error; eauto.

  eapply mem_inj_id_value_inject; eauto.
Qed.

Lemma build_constr_ok' : forall A B (ge : Genv.t A B) m0 tag args argvs,
    Forall2 (value_inject ge m0) args argvs ->
    Zlength args <= max_arg_count ->
    exists m1 m2 m3 m4 b,
        Mem.alloc m0 (-4) ((1 + Zlength args) * 4) = (m1, b) /\
        Mem.store Mint32 m1 b (-4) (Vint (Int.repr ((1 + Zlength args) * 4))) = Some m2 /\
        Mem.store Mint32 m2 b 0 (Vint tag) = Some m3 /\
        store_multi Mint32 m3 b 4 argvs = Some m4 /\
        value_inject ge m4 (Constr tag args) (Vptr b Int.zero).

intros.
destruct (Mem.alloc m0 (-4) ((1 + Zlength args) * 4)) as [m1 b] eqn:?.

fwd eapply Mem.valid_access_store with
    (m1 := m1) (b := b) (ofs := -4) (chunk := Mint32)
    (v := Vint (Int.repr ((1 + Zlength args) * 4)))  as HH.
  { eapply Mem.valid_access_implies with (p1 := Freeable); cycle 1.
      { constructor. }
    eapply Mem.valid_access_alloc_same; eauto.
    - lia.
    - unfold size_chunk. rewrite Zlength_correct.
      fwd eapply Zlength_nonneg with (xs := args). lia.
    - simpl. eapply Zmod_divide; eauto; lia.
  }
  destruct HH as [m2 ?].

fwd eapply Mem.valid_access_store
    with (m1 := m2) (b := b) (ofs := 0) (chunk := Mint32) (v := Vint tag) as HH.
  { eapply Mem.valid_access_implies with (p1 := Freeable); cycle 1.
      { constructor. }
    eapply Mem.store_valid_access_1; eauto.
    eapply Mem.valid_access_alloc_same; eauto.
    - clear. lia.
    - unfold size_chunk. rewrite Zlength_correct.
      fwd eapply Zlength_nonneg with (xs := args). lia.
    - simpl. eapply Zmod_divide; eauto; lia.
  }
  destruct HH as [m3 ?].

fwd eapply (valid_access_store_multi Mint32 m3 b 4 argvs) as HH; eauto.
  { eapply Mem.range_perm_implies with (p1 := Freeable); [ | constructor ].
    eapply shrink_range_perm with (lo1 := -4).
    - erewrite <- 2 range_perm_store by eauto. eapply alloc_range_perm. eauto.
    - clear. lia.
    - unfold size_chunk. fwd eapply Forall2_length as HH; eauto. clear -HH.
      replace ((1 + Zlength args) * 4) with (4 + 4 * Zlength args) by ring.
      rewrite 2 Zlength_correct. rewrite HH. lia.
  }
  { simpl. clear. eapply Zmod_divide; eauto. lia. }
  destruct HH as [m4 ?].

exists m1, m2, m3, m4, b.
split; eauto.
split; eauto.
split; eauto.
split; eauto.

eapply build_constr_inject'; eauto.
Qed.

Definition val_defined_dec a : { a <> Vundef } + { ~ a <> Vundef }.
destruct a; left + right; congruence.
Defined.

Definition require {A B} : { A } + { B } -> option A.
destruct 1; left + right; solve [eauto].
Defined.

Lemma require_decidable : forall A,
    forall (dec : { A } + { ~ A }),
    A ->
    exists pf, require dec = Some pf.
destruct dec; intro; try contradiction.
eexists. reflexivity.
Qed.

Local Open Scope option_monad.
Definition build_constr m tag args :=
    let '(m, b) := Mem.alloc m (-4) ((1 + Zlength args) * 4) in
    require (Forall_dec _ val_defined_dec args) >>= fun Hargdef =>
    Mem.store Mint32 m b (-4) (Vint (Int.repr ((1 + Zlength args) * 4))) >>= fun m =>
    Mem.store Mint32 m b 0 (Vint tag) >>= fun m =>
    store_multi Mint32 m b 4 args >>= fun m =>
    Some (m, Vptr b Int.zero).

Lemma build_constr_inject : forall A B (ge : Genv.t A B) m1 m2 tag args hargs v,
    build_constr m1 tag args = Some (m2, v) ->
    Forall2 (value_inject ge m1) hargs args ->
    Zlength args <= max_arg_count ->
    value_inject ge m2 (Constr tag hargs) v.
intros0 Hbuild Hvi Hlen.
unfold build_constr in Hbuild. break_match. break_bind_option. inject_some.
assert (Hlen_eq : length hargs = length args) by eauto using Forall2_length.
eapply build_constr_inject'; eauto.
all: rewrite Zlength_correct in *.
all: rewrite Hlen_eq in *.
all: eauto.
Qed.

Lemma require_bind_eq : forall (A : Prop) B (k : A -> option B) rhs,
    forall (dec : { A } + { ~ A }),
    A ->
    (forall pf, k pf = rhs) ->
    require dec >>= k = rhs.
intros0 HA Hk.
destruct dec; [ | contradiction ].
simpl. eauto.
Qed.

Lemma build_constr_ok : forall A B (ge : Genv.t A B) m1 tag args hargs,
    Forall2 (value_inject ge m1) hargs args ->
    Zlength args <= max_arg_count ->
    exists v m2,
        build_constr m1 tag args = Some (m2, v) /\
        value_inject ge m2 (Constr tag hargs) v.
intros.
assert (Hlen_eq : length hargs = length args) by eauto using Forall2_length.
rewrite Zlength_correct, <- Hlen_eq, <- Zlength_correct in *.
fwd eapply build_constr_ok' as HH; eauto.
rewrite Zlength_correct, Hlen_eq, <- Zlength_correct in *.
destruct HH as (? & ? & ? & m' & b & ? & ? & ? & ? & ?).

eexists _, _.
split; eauto.
unfold build_constr.
on _, fun H => (rewrite H; clear H).
eapply require_bind_eq.
  { list_magic_on (hargs, (args, tt)). eauto using value_inject_defined. }
  intro.
on _, fun H => (rewrite H; clear H; simpl).
on _, fun H => (rewrite H; clear H; simpl).
on _, fun H => (rewrite H; clear H; simpl).
reflexivity.
Qed.

Lemma build_constr_mem_inj_id : forall m1 tag args v m2,
    build_constr m1 tag args = Some (m2, v) ->
    Mem.mem_inj inject_id m1 m2.
intros0 Hbuild.
unfold build_constr in Hbuild. break_match. break_bind_option. inject_some.

rename m2 into m4, m3 into m3, m0 into m2, m1 into m0, m into m1.

assert ((Mem.mem_contents m1) !! b = ZMap.init Undef).
  { erewrite Mem.contents_alloc; eauto.
    erewrite <- Mem.alloc_result; eauto.
    erewrite PMap.gss. reflexivity. }

rewrite <- inject_id_compose_self. eapply Mem.mem_inj_compose with (m2 := m1).
- eapply alloc_mem_inj_id; eauto.
- eapply store_multi_new_block_mem_inj_id; eauto.
  eapply store_new_block_mem_inj_id; eauto.
  eapply store_new_block_mem_inj_id; eauto.
  eapply Mem.mext_inj, Mem.extends_refl.
Qed.

Check store_multi.

Lemma store_multi_mapped_inject : forall f chunk m1 b1 ofs vs1 m1' m2 b2 vs2,
    Mem.inject f m1 m2 ->
    store_multi chunk m1 b1 ofs vs1 = Some m1' ->
    f b1 = Some (b2, 0%Z) ->
    Forall2 (Val.inject f) vs1 vs2 ->
    exists m2',
        store_multi chunk m2 b2 ofs vs2 = Some m2' /\
        Mem.inject f m1' m2'.
first_induction vs1; intros0 Hmi Hstore Hf Hvi.
all: invc Hvi.
  { simpl in *. inject_some. exists m2. split; eauto. }

simpl in *. break_match_hyp; try discriminate.
rename m1' into m1'', m into m1'.
fwd eapply Mem.store_mapped_inject with (m1 := m1) as HH; eauto.
  destruct HH as (m2' & ? & ?).
fwd eapply IHvs1 with (m1 := m1') as HH; eauto.
  destruct HH as (m2'' & ? & ?).

exists m2''.
rewrite Z.add_0_r in *. find_rewrite. find_rewrite. eauto.
Qed.

Check Mem.nextblock_store.

Lemma nextblock_store_multi : forall chunk m1 b ofs vs m2,
    store_multi chunk m1 b ofs vs = Some m2 ->
    Mem.nextblock m2 = Mem.nextblock m1.
first_induction vs; intros0 Hstore; simpl in *.
  { inject_some. reflexivity. }

break_match; try discriminate.
erewrite IHvs by eauto. eapply Mem.nextblock_store; eauto.
Qed.

(*
*)

Definition valid_ptr m v :=
    match v with
    | Vptr b _ => Mem.valid_block m b
    | _ => True
    end.

Lemma mem_sim_valid_val_inject : forall v1 v2 mi mi' m1 m1' m2 m2',
    Val.inject mi v1 v2 ->
    Mem.inject mi m1 m2 ->
    mem_sim mi mi' m1 m1' m2 m2' ->
    valid_ptr m1 v1 ->
    Val.inject mi' v1 v2.
intros0 Hvi Hmi Hsim Hvalid.
invc Hvi; try solve [econstructor; eauto].
simpl in Hvalid.
econstructor; eauto.
destruct Hsim as (Hnew & Hold & Hinj & Hext1 & Hext2).
rewrite Hold; eauto.
Qed.

Lemma mem_sim_valid_val_inject_list : forall vs1 vs2 mi mi' m1 m1' m2 m2',
    Forall2 (Val.inject mi) vs1 vs2 ->
    Mem.inject mi m1 m2 ->
    mem_sim mi mi' m1 m1' m2 m2' ->
    Forall (valid_ptr m1) vs1 ->
    Forall2 (Val.inject mi') vs1 vs2.
induction vs1; intros0 Hvi Hmi Hsim Hvalid; invc Hvi; invc Hvalid;
  econstructor; eauto using mem_sim_valid_val_inject.
Qed.

Lemma build_constr_mem_inject : forall m1 tag args1 m1' v1,
    forall mi m2 args2,
    build_constr m1 tag args1 = Some (m1', v1) ->
    Mem.inject mi m1 m2 ->
    MemInjProps.same_offsets mi ->
    Forall2 (Val.inject mi) args1 args2 ->
    Forall (valid_ptr m1) args1 ->
    exists mi' m2' v2,
        build_constr m2 tag args2 = Some (m2', v2) /\
        Mem.inject mi' m1' m2' /\
        Val.inject mi' v1 v2 /\
        mem_sim mi mi' m1 m1' m2 m2'.

intros0 Hbuild Hmi Hoff Hvi Hvalid.
unfold build_constr in * |-. break_match_hyp.
rewrite Z.add_comm in *. break_bind_option. inject_some. rewrite Z.add_comm in *.
rename m1' into m1'''', m into m1', m0 into m1'', m3 into m1'''.
rename b into b1.

fwd eapply alloc_mem_sim as HH; eauto.
  destruct HH as (mi' & m2' & b2 & ? & ? & ? & ?).

fwd eapply Mem.store_mapped_inject with (m1 := m1') as HH; eauto.
  destruct HH as (m2'' & ? & ?).

fwd eapply Mem.store_mapped_inject with (m1 := m1'') as HH; eauto.
  destruct HH as (m2''' & ? & ?).

fwd eapply store_multi_mapped_inject with (m1 := m1''') as HH; eauto.
  { eapply mem_sim_valid_val_inject_list; eauto. }
  destruct HH as (m2'''' & ? & ?).

eexists mi', m2'''', _.
split; cycle 1.
  { split; [|split]; eauto.
    eapply mem_sim_compose; cycle 1.
      { eapply mem_sim_refl; symmetry; eapply nextblock_store_multi; eauto. }
    eapply mem_sim_compose; cycle 1.
      { eapply mem_sim_refl; symmetry; eapply Mem.nextblock_store; eauto. }
    eapply mem_sim_compose; cycle 1.
      { eapply mem_sim_refl; symmetry; eapply Mem.nextblock_store; eauto. }
    eauto. }

assert (Hzlen : Zlength args1 = Zlength args2).
  { rewrite 2 Zlength_correct. f_equal. eauto using Forall2_length. }

unfold build_constr.
rewrite <- Hzlen. on (Mem.alloc _ _ _ = _), fun H => rewrite H.
eapply require_bind_eq.
  { list_magic_on (args1, (args2, tt)).
    assert (args1_i <> Vundef).
      { eapply Forall_nth_error with (P := fun v => v <> Vundef); eauto. }
    on >Val.inject, invc; eauto. discriminate. }
  intro.
rewrite Z.add_0_r in *. on (Mem.store _ m2' _ _ _ = _), fun H => rewrite H.  simpl.
on (Mem.store _ m2'' _ _ _ = _), fun H => rewrite H. simpl.
on (store_multi _ m2''' _ _ _ = _), fun H => rewrite H. simpl.
reflexivity.
Qed.

Definition cm_func f := Econst (Oaddrsymbol f Int.zero).
Definition cm_malloc_sig := ef_sig EF_malloc.
Definition cm_int i := Econst (Ointconst (Int.repr i)).

Section BUILD_CONSTR_CMINOR.

Local Notation "A + B" := (Ebinop Oadd A B) : expr_scope.
Local Notation "A <-call ( B , C , D )" := (Scall (Some A) B C D) (at level 70).
Local Notation "A <- B" := (Sassign A B) (at level 70).
Local Notation "A ;; B" := (Sseq A B) (at level 50).

Delimit Scope expr_scope with expr.

Fixpoint store_args_cminor base args off :=
    match args with
    | [] => Sskip
    | arg :: args =>
            Sstore Mint32 (base + cm_int off)%expr arg ;;
            store_args_cminor base args (off + 4)
    end.

Lemma valid_pointer_mem_inj_id : forall m m' b ofs,
    Mem.valid_pointer m b ofs = true ->
    Mem.mem_inj inject_id m m' ->
    Mem.valid_pointer m' b ofs = true.
intros0 Hvalid Hmem.
unfold Mem.valid_pointer in *.
destruct (Mem.perm_dec m _ _ _ _); try discriminate.
fwd eapply Mem.mi_perm; try eassumption. { reflexivity. }
destruct (Mem.perm_dec m' _ _ _ _); try reflexivity.

exfalso.
rewrite Z.add_0_r in *. eauto.
Qed.

Lemma weak_valid_pointer_mem_inj_id : forall m m' b ofs,
    (Mem.valid_pointer m b ofs || Mem.valid_pointer m b (ofs - 1)) = true ->
    Mem.mem_inj inject_id m m' ->
    (Mem.valid_pointer m' b ofs || Mem.valid_pointer m' b (ofs - 1)) = true.
intros.
rewrite orb_true_iff in *.
break_or; [left | right]; eapply valid_pointer_mem_inj_id; eauto.
Qed.

Lemma cmpu_bool_mem_inj_id : forall m m' cmp a b r,
    Val.cmpu_bool (Mem.valid_pointer m) cmp a b = Some r ->
    Mem.mem_inj inject_id m m' ->
    Val.cmpu_bool (Mem.valid_pointer m') cmp a b = Some r.
intros0 Hcmpu Hmem.
destruct a, b; try discriminate; simpl in *.

- eauto.

- break_match_hyp; try discriminate.
  rewrite andb_true_iff in *. break_and. find_rewrite. simpl.
  erewrite weak_valid_pointer_mem_inj_id; eauto.

- break_match_hyp; try discriminate.
  rewrite andb_true_iff in *. break_and. find_rewrite. simpl.
  erewrite weak_valid_pointer_mem_inj_id; eauto.

- break_if.

  + break_match_hyp; try discriminate.
    rewrite andb_true_iff in *. break_and.
    do 2 erewrite weak_valid_pointer_mem_inj_id by eauto.
    simpl. eauto.

  + break_match_hyp; try discriminate.
    rewrite andb_true_iff in *. break_and.
    do 2 erewrite valid_pointer_mem_inj_id by eauto.
    simpl. eauto.

Qed.

Lemma eval_binop_mem_inj_id : forall op a b r m m',
    eval_binop op a b m = Some r ->
    r <> Vundef ->
    Mem.mem_inj inject_id m m' ->
    eval_binop op a b m' = Some r.
destruct op; intros0 Heval Hdef Hmem; simpl; eauto.

- (* Ocmpu *)
  unfold eval_binop, Val.cmpu, Val.of_optbool in *.
  inject_some. f_equal.
  break_match_hyp; try (exfalso; congruence).
  erewrite cmpu_bool_mem_inj_id; eauto.
Qed.

Lemma eval_unop_undef : forall op v v',
    eval_unop op v = Some v' ->
    v = Vundef ->
    v' = Vundef.
destruct op; intros0 Heval Hundef; subst v; simpl in *;
  discriminate || inject_some; eauto.
Qed.

Lemma eval_binop_undef1 : forall op v1 v2 m v',
    eval_binop op v1 v2 m = Some v' ->
    v1 = Vundef ->
    v' = Vundef.
destruct op; intros0 Heval Hundef; subst v1; simpl in *;
  discriminate || inject_some; eauto.
Qed.

Lemma eval_binop_undef2 : forall op v1 v2 m v',
    eval_binop op v1 v2 m = Some v' ->
    v2 = Vundef ->
    v' = Vundef.
destruct op; intros0 Heval Hundef; subst v2; simpl in *.
all: destruct v1; try discriminate.
all: invc Heval; reflexivity.
Qed.

Lemma eval_unop_defined : forall op v v',
    eval_unop op v = Some v' ->
    v' <> Vundef ->
    v <> Vundef.
intros0 Heval Hdef. contradict Hdef. eauto using eval_unop_undef.
Qed.

Lemma eval_binop_defined1 : forall op v1 v2 m v',
    eval_binop op v1 v2 m = Some v' ->
    v' <> Vundef ->
    v1 <> Vundef.
intros0 Heval Hdef. contradict Hdef. eauto using eval_binop_undef1.
Qed.

Lemma eval_binop_defined2 : forall op v1 v2 m v',
    eval_binop op v1 v2 m = Some v' ->
    v' <> Vundef ->
    v2 <> Vundef.
intros0 Heval Hdef. contradict Hdef. eauto using eval_binop_undef2.
Qed.

Lemma eval_expr_mem_inj_id : forall m m' ge sp e a b,
    eval_expr ge sp e m a b ->
    b <> Vundef ->
    Mem.mem_inj inject_id m m' ->
    eval_expr ge sp e m' a b.
induction 1; intros0 Hdef Hmem; try solve [econstructor; eauto].

- econstructor; eauto.
  eapply IHeval_expr; eauto using eval_unop_defined.

- econstructor; eauto using eval_binop_defined1, eval_binop_defined2.
  eapply eval_binop_mem_inj_id; eauto.

- destruct vaddr; try discriminate.
  econstructor; eauto.
  + eapply IHeval_expr; eauto. discriminate.
  + simpl.
    fwd eapply Mem.load_inj as HH; try eassumption. { reflexivity. }
      destruct HH as (v' & ? & ?).
    rewrite val_inject_id in *.
    fwd eapply lessdef_def_eq; eauto. subst v'.
    rewrite Z.add_0_r in *. eauto.
Qed.

Lemma eval_exprlist_mem_inj_id : forall m m' ge sp e es vs,
    eval_exprlist ge sp e m es vs ->
    Forall (fun v => v <> Vundef) vs ->
    Mem.mem_inj inject_id m m' ->
    eval_exprlist ge sp e m' es vs.
induction 1; intros0 Hdef Hmem; invc Hdef;
  econstructor; eauto using eval_expr_mem_inj_id.
Qed.

Lemma store_args_cminor_effect : forall m0 ge sp e m base b ofs delta es vs m' f k,
    store_multi Mint32 m b (ofs + delta) vs = Some m' ->
    eval_expr ge sp e m0 base (Vptr b (Int.repr ofs)) ->
    eval_exprlist ge sp e m0 es vs ->
    Forall (fun v => v <> Vundef) vs ->
    Mem.mem_inj inject_id m0 m ->
    (Mem.mem_contents m0) !! b = ZMap.init Undef ->
    0 <= ofs ->
    0 <= delta ->
    ofs + delta + 4 * Zlength es <= Int.max_unsigned ->
    star Cminor.step ge
        (State f (store_args_cminor base es delta) k sp e m)
     E0 (State f Sskip k sp e m').
first_induction es; intros0 Hstore Hbase Heval Hdef Hnewblock Hmem Hmin1 Hmin2 Hmax.
all: on >eval_exprlist, invc.

  { simpl in *. inject_some. eapply star_refl. }

simpl in Hstore. break_match; try discriminate.

fwd eapply Zlength_nonneg with (xs := a :: es).

invc Hdef.
fwd eapply eval_expr_mem_inj_id with (a := a); eauto.
fwd eapply eval_expr_mem_inj_id with (a := base); eauto. { discriminate. }
fwd eapply eval_exprlist_mem_inj_id; eauto.

eapply star_left with (t1 := E0) (t2 := E0); eauto.
  { simpl. econstructor. }
eapply star_left with (t1 := E0) (t2 := E0); eauto.
  { econstructor.
    - econstructor; eauto.
      + econstructor. simpl. reflexivity.
      + simpl. reflexivity.
    - eauto.
    - simpl. rewrite Int.add_unsigned.
      rewrite Int.unsigned_repr with (z := ofs) by lia.
      rewrite Int.unsigned_repr with (z := delta) by lia.
      rewrite Int.unsigned_repr by lia.
      eauto.
  }
eapply star_left with (t1 := E0) (t2 := E0); eauto.
  { econstructor. }

eapply (IHes m0); try eassumption.
- rewrite Z.add_assoc. eauto.
- eapply store_new_block_mem_inj_id; eauto.
- lia.
- rewrite Zlength_cons in *. unfold Z.succ in *. rewrite Z.mul_add_distr_l in *.
  lia.
Qed.

Definition build_constr_cminor malloc_id id tag args :=
    let sz := 4 * (1 + Zlength args) in
    id <-call (cm_malloc_sig, cm_func malloc_id, [cm_int sz]) ;;
    Sstore Mint32 (Evar id) (Econst (Ointconst tag)) ;;
    store_args_cminor (Evar id) args 4.

Fixpoint expr_no_access id e :=
    match e with
    | Evar id' => id <> id'
    | Econst _ => True
    | Eunop _ a => expr_no_access id a
    | Ebinop _ a b => expr_no_access id a /\ expr_no_access id b
    | Eload _ a => expr_no_access id a
    end.

Definition eval_expr_no_access : forall ge sp e m a b id v,
    eval_expr ge sp e m a b ->
    expr_no_access id a ->
    eval_expr ge sp (PTree.set id v e) m a b.
induction 1; intros0 Hacc; econstructor; eauto.
- rewrite PTree.gso; eauto.
- invc Hacc. eauto.
- invc Hacc. eauto.
Qed.

Definition eval_exprlist_no_access : forall ge sp e m a b id v,
    eval_exprlist ge sp e m a b ->
    Forall (expr_no_access id) a ->
    eval_exprlist ge sp (PTree.set id v e) m a b.
induction 1; intros0 Hacc; invc Hacc; econstructor; eauto using eval_expr_no_access.
Qed.

Lemma E0_E0_E0 : E0 = Eapp E0 E0.
reflexivity.
Qed.

Lemma build_constr_cminor_effect : forall malloc_id m tag args argvs v m',
    forall ge f id k sp e fp,
    build_constr m tag argvs = Some (m', v) ->
    eval_exprlist ge sp e m args argvs ->
    Forall (expr_no_access id) args ->
    Zlength args <= max_arg_count ->
    Genv.find_symbol ge malloc_id = Some fp ->
    Genv.find_funct ge (Vptr fp Int.zero) = Some (External EF_malloc) ->
    plus Cminor.step ge
        (State f (build_constr_cminor malloc_id id tag args) k sp e m)
     E0 (State f Sskip k sp (PTree.set id v e) m').
intros0 Hbuild Heval Hacc Hargc Hmsym Hmfun.

unfold build_constr in Hbuild. break_match. break_bind_option. inject_some.

assert (Hzlen : Zlength args = Zlength argvs).
  { do 2 rewrite Zlength_correct. f_equal.
    clear -Heval.  induction Heval; simpl; f_equal; eauto. }

assert ((Mem.mem_contents m0) !! b = ZMap.init Undef).
  { erewrite Mem.contents_alloc; eauto.
    erewrite <- Mem.alloc_result; eauto.
    erewrite PMap.gss. reflexivity. }

eapply plus_left. 3: eapply E0_E0_E0. { econstructor. }
eapply star_left. 3: eapply E0_E0_E0. { econstructor. }
eapply star_left. 3: eapply E0_E0_E0. {
  econstructor.
  - econstructor. simpl. rewrite Hmsym. reflexivity.
  - repeat econstructor.
  - rewrite Hmfun. reflexivity.
  - reflexivity.
}
eapply star_left. 3: eapply E0_E0_E0. {
  econstructor. econstructor.
  - rewrite Int.unsigned_repr; cycle 1.
      { replace (4 * _) with (4 + Zlength args * 4) by ring.
        split.
        - fwd eapply Zlength_nonneg with (xs := args). lia.
        - eapply max_arg_count_value_size_ok. eauto. }
    rewrite Z.mul_comm, Hzlen. eauto.
  - rewrite Z.mul_comm, Hzlen. eauto.
}
eapply star_left. 3: eapply E0_E0_E0. { econstructor. }
eapply star_left. 3: eapply E0_E0_E0. { econstructor. }
eapply star_left. 3: eapply E0_E0_E0. {
  econstructor.
  - econstructor. simpl. rewrite PTree.gss. reflexivity.
  - econstructor. simpl. reflexivity.
  - simpl. rewrite Int.unsigned_zero. eauto.
}
eapply star_left. 3: eapply E0_E0_E0. { econstructor. }

eapply store_args_cminor_effect with (ofs := 0) (m0 := m0).
- simpl. eauto.
- econstructor. rewrite PTree.gss. reflexivity.
- eapply eval_exprlist_mem_inj_id; cycle 1.
  + eauto.
  + eapply alloc_mem_inj_id; eauto.
  + eapply eval_exprlist_no_access; eauto.
- eauto.
- eapply store_new_block_mem_inj_id; eauto.
  eapply store_new_block_mem_inj_id; eauto.
  eapply Mem.mext_inj, Mem.extends_refl.
- eauto.
- lia.
- lia.
- rewrite Z.add_0_l. rewrite Z.mul_comm.
  eapply max_arg_count_value_size_ok. eauto.
Qed.

End BUILD_CONSTR_CMINOR.

Lemma build_close_inject' : forall A B (ge : Genv.t A B) m0 m1 m2 m3 m4 b fname free freev,
    forall bcode fp,
    Genv.find_symbol ge fname = Some bcode ->
    Genv.find_funct_ptr ge bcode = Some fp ->
    Forall2 (value_inject ge m0) free freev ->
    Zlength free <= max_arg_count ->
    Mem.alloc m0 (-4) ((1 + Zlength free) * 4) = (m1, b) ->
    Mem.store Mint32 m1 b (-4) (Vint (Int.repr ((1 + Zlength free) * 4))) = Some m2 ->
    Mem.store Mint32 m2 b 0 (Vptr bcode Int.zero) = Some m3 ->
    store_multi Mint32 m3 b 4 freev = Some m4 ->
    value_inject ge m4 (Close fname free) (Vptr b Int.zero).
intros0 Hsym Hfp Hfree Hmax Hm1 Hm2 Hm3 H4.

assert ((Mem.mem_contents m1) !! b = ZMap.init Undef).
  { erewrite Mem.contents_alloc; eauto.
    erewrite <- Mem.alloc_result; eauto.
    erewrite PMap.gss. reflexivity. }

assert (Mem.mem_inj inject_id m0 m4).
  { rewrite <- inject_id_compose_self. eapply Mem.mem_inj_compose with (m2 := m1).
    - eapply alloc_mem_inj_id; eauto.
    - eapply store_multi_new_block_mem_inj_id; eauto.
      eapply store_new_block_mem_inj_id; eauto.
      eapply store_new_block_mem_inj_id; eauto.
      eapply Mem.mext_inj, Mem.extends_refl. }

econstructor.

- simpl.
  rewrite Int.unsigned_zero.
  erewrite load_store_multi_other; eauto; cycle 1.
    { right. left. simpl. lia. }
  fwd eapply Mem.load_store_same as HH; eauto.

- eauto.
- eauto.

- eapply store_multi_load_all_args; eauto.
  + eapply Forall2_length; eauto.
  + rewrite Int.unsigned_zero, Int.unsigned_repr; cycle 1.
      { split; [lia|]. eapply int_unsigned_big. lia. }
    lia.
  + rewrite Int.unsigned_zero, Int.unsigned_repr; cycle 1.
      { split; [lia|]. eapply int_unsigned_big. lia. }
    rewrite Z.add_0_l. eapply max_arg_count_value_size_ok. eauto.
  + list_magic_on (free, (freev, tt)).
    symmetry. eapply value_inject_32bit. eassumption.

- intros0 Hin.
  eapply In_nth_error in Hin. destruct Hin as [n ?].
  on _, eapply_lem zip_nth_error. break_and.
  fwd eapply Forall2_nth_error; eauto.

  eapply mem_inj_id_value_inject; eauto.
Qed.

Lemma build_close_ok' : forall A B (ge : Genv.t A B) m0 fname free freev,
    forall bcode fp,
    Genv.find_symbol ge fname = Some bcode ->
    Genv.find_funct_ptr ge bcode = Some fp ->
    Forall2 (value_inject ge m0) free freev ->
    Zlength free <= max_arg_count ->
    exists m1 m2 m3 m4 b,
        Mem.alloc m0 (-4) ((1 + Zlength free) * 4) = (m1, b) /\
        Mem.store Mint32 m1 b (-4) (Vint (Int.repr ((1 + Zlength free) * 4))) = Some m2 /\
        Mem.store Mint32 m2 b 0 (Vptr bcode Int.zero) = Some m3 /\
        store_multi Mint32 m3 b 4 freev = Some m4 /\
        value_inject ge m4 (Close fname free) (Vptr b Int.zero).

intros.
destruct (Mem.alloc m0 (-4) ((1 + Zlength free) * 4)) as [m1 b] eqn:?.

fwd eapply Mem.valid_access_store with
    (m1 := m1) (b := b) (ofs := -4) (chunk := Mint32)
    (v := Vint (Int.repr ((1 + Zlength free) * 4))) as HH.
  { eapply Mem.valid_access_implies with (p1 := Freeable); cycle 1.
      { constructor. }
    eapply Mem.valid_access_alloc_same; eauto.
    - lia.
    - unfold size_chunk. rewrite Zlength_correct.
      fwd eapply Zlength_nonneg with (xs := free). lia.
    - simpl. eapply Zmod_divide; eauto; lia.
  }
  destruct HH as [m2 ?].

fwd eapply Mem.valid_access_store with
    (m1 := m2) (b := b) (ofs := 0) (chunk := Mint32) (v := Vptr bcode Int.zero) as HH.
  { eapply Mem.valid_access_implies with (p1 := Freeable); cycle 1.
      { constructor. }
    eapply Mem.store_valid_access_1; eauto.
    eapply Mem.valid_access_alloc_same; eauto.
    - clear. lia.
    - unfold size_chunk. rewrite Zlength_correct.
      fwd eapply Zlength_nonneg with (xs := free). lia.
    - simpl. eapply Zmod_divide; eauto; lia.
  }
  destruct HH as [m3 ?].

fwd eapply (valid_access_store_multi Mint32 m3 b 4 freev) as HH; eauto.
  { eapply Mem.range_perm_implies with (p1 := Freeable); [ | constructor ].
    eapply shrink_range_perm with (lo1 := -4).
    - erewrite <- 2 range_perm_store by eauto. eapply alloc_range_perm. eauto.
    - clear. lia.
    - unfold size_chunk. fwd eapply Forall2_length as HH; eauto. clear -HH.
      replace ((1 + Zlength free) * 4) with (4 + 4 * Zlength free) by ring.
      rewrite 2 Zlength_correct. rewrite HH. lia.
  }
  { simpl. clear. eapply Zmod_divide; eauto. lia. }
  destruct HH as [m4 ?].

exists m1, m2, m3, m4, b.
split; eauto.
split; eauto.
split; eauto.
split; eauto.

eapply build_close_inject'; eauto.
Qed.

Local Open Scope option_monad.
Definition build_close {A B} (ge : Genv.t A B) m fname free :=
    Genv.find_symbol ge fname >>= fun bcode =>
    Genv.find_funct_ptr ge bcode >>= fun fp =>
    let '(m, b) := Mem.alloc m (-4) ((1 + Zlength free) * 4) in
    Mem.store Mint32 m b (-4) (Vint (Int.repr ((1 + Zlength free) * 4))) >>= fun m =>
    Mem.store Mint32 m b 0 (Vptr bcode Int.zero) >>= fun m =>
    store_multi Mint32 m b 4 free >>= fun m =>
    Some (m, Vptr b Int.zero).

Lemma build_close_inject : forall A B (ge : Genv.t A B) m1 m2 fname free hfree v,
    build_close ge m1 fname free = Some (m2, v) ->
    Forall2 (value_inject ge m1) hfree free ->
    Zlength free <= max_arg_count ->
    value_inject ge m2 (Close fname hfree) v.
intros0 Hbuild Hvi Hlen.
unfold build_close in Hbuild. break_match. break_bind_option. inject_some.
assert (Hlen_eq : length hfree = length free) by eauto using Forall2_length.
eapply build_close_inject'; eauto.
all: rewrite Zlength_correct in *.
all: rewrite Hlen_eq in *.
all: eauto.
Qed.

Lemma build_close_ok : forall A B (ge : Genv.t A B) m1 fname free hfree,
    forall bcode fp,
    Genv.find_symbol ge fname = Some bcode ->
    Genv.find_funct_ptr ge bcode = Some fp ->
    Forall2 (value_inject ge m1) hfree free ->
    Zlength free <= max_arg_count ->
    exists v m2,
        build_close ge m1 fname free = Some (m2, v) /\
        value_inject ge m2 (Close fname hfree) v.
intros.
assert (Hlen_eq : length hfree = length free) by eauto using Forall2_length.
rewrite Zlength_correct, <- Hlen_eq, <- Zlength_correct in *.
fwd eapply build_close_ok' as HH; eauto.
rewrite Zlength_correct, Hlen_eq, <- Zlength_correct in *.
destruct HH as (? & ? & ? & m' & b & ? & ? & ? & ? & ?).

eexists _, _.
split; eauto.
unfold build_close.
on _, fun H => (rewrite H; clear H).
on _, fun H => (rewrite H; clear H; simpl).
on _, fun H => (rewrite H; clear H; simpl).
on _, fun H => (rewrite H; clear H; simpl).
on _, fun H => (rewrite H; clear H; simpl).
on _, fun H => (rewrite H; clear H; simpl).
reflexivity.
Qed.

Lemma build_close_mem_inj_id : forall A B (ge : Genv.t A B) m1 fname free v m2,
    build_close ge m1 fname free = Some (m2, v) ->
    Mem.mem_inj inject_id m1 m2.
intros0 Hbuild.
unfold build_close in Hbuild. break_match. break_bind_option. inject_some.

rename m2 into m4, m3 into m3, m0 into m2, m1 into m0, m into m1.

assert ((Mem.mem_contents m1) !! b = ZMap.init Undef).
  { erewrite Mem.contents_alloc; eauto.
    erewrite <- Mem.alloc_result; eauto.
    erewrite PMap.gss. reflexivity. }

rewrite <- inject_id_compose_self. eapply Mem.mem_inj_compose with (m2 := m1).
- eapply alloc_mem_inj_id; eauto.
- eapply store_multi_new_block_mem_inj_id; eauto.
  eapply store_new_block_mem_inj_id; eauto.
  eapply store_new_block_mem_inj_id; eauto.
  eapply Mem.mext_inj, Mem.extends_refl.
Qed.


Require Import EquivDec.
Require Import List.

Require Import Utils.
Require Import Lattices.

Require Import Instr.
Require Import AbstractCommon.
Require Import Memory.
Require Import AbstractMachine.
Require Import QuasiAbstractMachine.
Require Import Refinement.

Open Scope list_scope.

Set Implicit Arguments.

Section Ref.

Context {T: Type}
        {Latt: JoinSemiLattice T}.

Definition match_tags (t1 t2 : T) (m2 : memory T unit) : Prop :=
  t1 = t2.
Hint Unfold match_tags : core.

Definition valid_update (m2 m2' : memory T unit) : Prop := True.
Hint Unfold valid_update : core.

Lemma valid_update_match_tags :
  forall t1 t2 m2 m2',
    match_tags t1 t2 m2 ->
    valid_update m2 m2' ->
    match_tags t1 t2 m2'.
Proof. eauto. Qed.

Notation meminj := (meminj T unit).
Notation Meminj := (Meminj T T T unit match_tags).
Notation match_atoms := (match_atoms T T T unit match_tags).
Notation match_vals := (match_vals T unit).
Notation match_ptrs := (match_ptrs T unit).
Notation update_meminj := (update_meminj T unit).

Hint Resolve match_vals_eq : core.
Hint Constructors Memory.match_atoms : core.
Hint Constructors Memory.match_vals : core.
Hint Constructors Memory.match_ptrs : core.
Hint Resolve update_meminj_eq : core.

Inductive match_stk_elmt (mi : meminj) : StkElmt T T -> StkElmt T unit -> memory T unit -> Prop :=
| mse_data : forall a1 a2 m2
                    (ATOMS : match_atoms mi a1 a2 m2),
               match_stk_elmt mi (AData a1) (AData a2) m2
| mse_ret : forall pc b m2, match_stk_elmt mi (ARet pc b) (ARet pc b) m2.
Hint Constructors match_stk_elmt : core.

Definition match_stacks (mi : meminj) : list (StkElmt T T) -> list (StkElmt T unit) -> memory T unit -> Prop :=
  fun s1 s2 m2 => Forall2 (fun se1 se2 => match_stk_elmt mi se1 se2 m2) s1 s2.
Hint Unfold match_stacks : core.

Inductive match_states : @a_state T -> @qa_state T -> Prop :=
| aqa_intro : forall mi m1 m2 p stk1 stk2 pc
                     (INJ : Meminj m1 m2 mi)
                     (STK : match_stacks mi stk1 stk2 m2),
                match_states (AState m1 p stk1 pc) (AState m2 p stk2 pc).
Hint Constructors match_states : core.

Lemma alloc_match_stacks :
  forall size
         lab a1 m1 b1 m1'
         a2 m2 b2 m2'
         mi stk1 stk2
         (STK : match_stacks mi stk1 stk2 m2)
         (ALLOC1 : a_alloc size lab a1 m1 = Some (b1, m1'))
         (ALLOC2 : qa_alloc size a2 m2 = Some (b2, m2'))
         (INJ : Meminj m1 m2 mi),
    match_stacks (update_meminj mi b2 b1) stk1 stk2 m2'.
Proof.
  intros.
  induction STK; constructor; trivial.
  inv H; constructor.
  inv ATOMS. constructor; auto.
  inv VALS; try inv PTRS; do 2 constructor.
  rewrite update_meminj_neq; auto.
  eapply mi_valid in BLOCK; eauto.
  destruct BLOCK as [? [? [? [? ?]]]].
  unfold qa_alloc, alloc in ALLOC2.
  destruct (zreplicate size a2); inv ALLOC2.
  eapply Mem.alloc_get_fresh in H3; eauto.
  congruence.
Qed.

Lemma match_stacks_app :
  forall mi stk1 args2 stk2' m2
         (STKS : match_stacks mi stk1 (args2 ++ stk2') m2),
    exists args1 stk1',
      stk1 = args1 ++ stk1' /\
      match_stacks mi args1 args2 m2 /\
      match_stacks mi stk1' stk2' m2.
Proof.
  intros.
  gdep stk1.
  induction args2 as [|arg args2 IH]; intros stk1 STKS.
  - exists nil. exists stk1. eauto.
  - simpl in STKS.
    inv STKS.
    exploit IH; eauto.
    intros [? [? [? [? ?]]]]. subst.
    repeat eexists; eauto.
    trivial.
Qed.

Lemma match_stacks_length :
  forall mi stk1 stk2 m2
         (STKS : match_stacks mi stk1 stk2 m2),
    length stk1 = length stk2.
Proof. induction 1; simpl; eauto. Qed.
Hint Resolve match_stacks_length : core.

Lemma match_stacks_all_data :
  forall mi stk1 stk2 m2
         (STKS : match_stacks mi stk1 stk2 m2)
         (DATA : forall se2, In se2 stk2 -> exists a2, se2 = AData a2),
    forall se1, In se1 stk1 -> exists a1, se1 = AData a1.
Proof.
  induction 1 as [|se1 se2 stk1 stk2 STKELMT STKS IHSTKS]; intros; inv H.
  - inv STKELMT; eauto.
    specialize (DATA (ARet pc b)).
    destruct DATA; simpl; eauto.
    congruence.
  - apply IHSTKS; simpl in *; auto.
Qed.
Hint Resolve match_stacks_all_data : core.

Lemma match_stacks_app_2 :
  forall mi stk11 stk12 stk21 stk22 m2
         (STKS1 : match_stacks mi stk11 stk21 m2)
         (STKS2 : match_stacks mi stk12 stk22 m2),
    match_stacks mi (stk11 ++ stk12) (stk21 ++ stk22) m2.
Proof. intros. eauto using Forall2_app. Qed.
Hint Resolve match_stacks_app_2 : core.

Hint Constructors pop_to_return : core.

Lemma match_stacks_pop_to_return :
  forall mi stk1 stk2 stk2' pc b m2
         (STKS : match_stacks mi stk1 stk2 m2)
         (POP : pop_to_return stk2 (ARet pc b :: stk2')),
    exists stk1',
      pop_to_return stk1 (ARet pc b :: stk1') /\
      match_stacks mi stk1' stk2' m2.
Proof.
  intros.
  gdep stk2.
  induction stk1 as [|se1 stk1 IH]; intros;
  inv POP; inv STKS;
  match goal with
    | H : match_stk_elmt _ _ _ _ |- _ =>
      inv H; eauto
  end.
  exploit IH; eauto.
  intros [? [? ?]].
  eauto.
Qed.

Lemma match_stacks_index_list :
  forall mi n s1 s2 x2 m2
         (IDX : index_list n s2 = Some x2)
         (STKS : match_stacks mi s1 s2 m2),
    exists x1,
      index_list n s1 = Some x1 /\
      match_stk_elmt mi x1 x2 m2.
Proof.
  induction n as [|n IH]; intros; inv STKS; simpl in *; allinv; eauto.
Qed.

Lemma match_stacks_update_list :
  forall mi n se1 s1 se2 s2 s2' m2
         (STKS : match_stacks mi s1 s2 m2)
         (STKELMTS : match_stk_elmt mi se1 se2 m2)
         (UPD : update_list n se2 s2 = Some s2'),
    exists s1',
      update_list n se1 s1 = Some s1' /\
      match_stacks mi s1' s2' m2.
Proof.
  intros mi n.
  induction n as [|n IH]; intros; inv STKS; simpl in *; try congruence;
  allinv; eauto.
  match goal with
    | H : (match ?UP with _ => _ end) = Some _ |- _ =>
      destruct UP as [s2''|] eqn:?; try congruence
  end.
  allinv.
  exploit (@IH se1); eauto.
  intros [s1'' [EQ ?]].
  rewrite EQ.
  eauto.
Qed.

Lemma match_stacks_swap :
  forall mi n s1 s2 s2' m2
         (SWAP : swap n s2 = Some s2')
         (STKS : match_stacks mi s1 s2 m2),
    exists s1',
      swap n s1 = Some s1' /\
      match_stacks mi s1' s2' m2.
Proof.
  unfold swap.
  intros.
  destruct s2 as [|se2 s2]; try congruence.
  destruct (index_list n (se2 :: s2)) as [se2'|] eqn:IDX2; try congruence.
  exploit match_stacks_index_list; eauto.
  intros [se1' [IDX1 STKELMTS]].
  inversion STKS as [|se1 ?]; subst.
  rewrite IDX1.
  eapply match_stacks_update_list; eauto.
Qed.

Lemma match_atoms_mem_irrel :
  forall mi a1 a2 m2 m2'
         (ATOMS : match_atoms mi a1 a2 m2),
    match_atoms mi a1 a2 m2'.
Proof. intros. inv ATOMS; eauto. Qed.
Hint Resolve match_atoms_mem_irrel : mem_irrel.

Lemma match_stk_elmt_mem_irrel :
  forall mi se1 se2 m2 m2'
         (STKELMT : match_stk_elmt mi se1 se2 m2),
    match_stk_elmt mi se1 se2 m2'.
Proof. intros. inv STKELMT; eauto with mem_irrel. Qed.
Hint Resolve match_stk_elmt_mem_irrel : mem_irrel.

Lemma match_stacks_mem_irrel :
  forall mi s1 s2 m2 m2'
         (STKS : match_stacks mi s1 s2 m2),
    match_stacks mi s1 s2 m2'.
Proof. intros. induction STKS; eauto with mem_irrel. Qed.
Hint Resolve match_stacks_mem_irrel : mem_irrel.

Hint Unfold a_alloc : core.
Hint Unfold qa_alloc : core.

Inductive parametric_asyscall : ASysCall T -> Prop :=
| masc_intro : forall ar f
                      (EXT : forall mi args1 args2 m2,
                               Forall2 (fun arg1 arg2 => match_atoms mi arg1 arg2 m2)
                                       args1 args2 ->
                               match_options (fun a1 a2 => match_atoms mi a1 a2 m2)
                                             (f T args1) (f unit args2)),
                 parametric_asyscall {| asi_arity := ar; asi_sem := f |}.

Inductive ForallO {T} (P : T -> Prop) : option T -> Prop :=
| Forall_None : ForallO P None
| Forall_Some : forall t, P t -> ForallO P (Some t).

Definition parametric_asystable (t : ASysTable T) : Prop :=
  forall id, ForallO parametric_asyscall (t id).

Variable atable : ASysTable T.
Hypothesis Hatable : parametric_asystable atable.

Ltac inv_match :=
  repeat match goal with
           | STK : Forall2 _ _ nil |- _ => inv STK
           | STK : Forall2 _ _ (_ :: _) |- _ => inv STK
           | STKELMT : match_stk_elmt _ _ _ _ |- _ => inv STKELMT
           | ATOMS : match_atoms _ _ (_,_) _ |- _ => inv ATOMS
           | VALS : match_vals _ _ (Vint _) |- _ => inv VALS
           | VALS : match_vals _ _ (Vptr _) |- _ => inv VALS
           | PTRS : match_ptrs _ _ _ |- _ => inv PTRS
           | TAGS : match_tags _ _ _ |- _ => unfold match_tags in TAGS; subst
         end.

Lemma match_stacks_map_adata :
  forall mi stk1 args2 m2
         (MATCH : match_stacks mi stk1 (map AData args2) m2),
  exists args1,
    stk1 = map AData args1 /\
    Forall2 (fun a1 a2 => match_atoms mi a1 a2 m2) args1 args2.
Proof.
  unfold match_stacks.
  intros.
  gdep stk1.
  induction args2 as [|a2 args2 IH]; simpl; intros; inv_match.
  - eexists nil. simpl. intuition.
  - exploit IH; eauto.
    intros (args1 & ? & MATCH). subst.
    eexists (a1 :: args1). eauto.
Qed.

Lemma a_qa_simulation :
  forall s1 s2 e s2'
         (STEP : step_rules fetch_rule atable s2 e s2')
         (MATCH : match_states s1 s2),
    exists s1',
      a_step atable s1 e s1' /\
      match_states s1' s2'.
Proof.
  intros.
  inv STEP;
  inv MATCH;
  unfold match_stacks in *;
  inv_match;
  match goal with
    | H : run_tmr _ _ _ _ = Some _ |- _ =>
      unfold run_tmr, Rules.apply_rule in H; simpl in H;
      unfold Vector.nth_order in H; simpl in H
    | INSTR : context[SysCall ?id],
      TABLE : atable ?id = Some _ |- _ =>
      specialize (Hatable id);
      rewrite TABLE in Hatable;
      inv Hatable
  end;
  try match goal with
        | MATCH : parametric_asyscall _ |- _ =>
          inv MATCH
      end;
  simpl in *; unfold Vector.nth_order; simpl;
  try congruence;
  repeat match goal with
           | H : context[if ?b then _ else _] |- _ =>
             destruct b eqn:?; simpl in H
           | H : Some _ = Some _ |- _ => inv H
           | H : _ === _ |- _ => compute in H; subst
           | H1 : ?x = ?a,
             H2 : ?x = ?b |- _ =>
             assert (a = b) by congruence; clear H2
         end;
  try congruence;

  try match goal with
        | H : add _ _ = Some _ |- _ =>
          exploit add_defined; eauto; intros [? [? ?]]
        | SUB : sub _ _ = Some _ |- _ =>
          exploit (sub_defined T unit); eauto; intros [? [? ?]]
        | H : qa_alloc _ _ _ = Some _ |- _ =>
          exploit (meminj_alloc T T T unit _ _ valid_update_match_tags); eauto;
          try solve [constructor; eauto];
          intros [? [? [? ?]]];
          exploit alloc_match_stacks; eauto; intro
        | H : load _ _ = Some _ |- _ =>
          exploit meminj_load; eauto;
          try solve [econstructor; eauto]; intros [[? ?] [? H']];
          inv H'; inv_match
        | H : Forall2 _ _ (_ ++ _) |- _ =>
          exploit match_stacks_app; eauto; intros [? [? [? [? ?]]]]; subst
        | H : pop_to_return _ _ |- _ =>
          exploit match_stacks_pop_to_return; eauto; intros [? [? ?]]
      end;

  (* For some weird reason, trying to merge this match with the previous one doesn't work. *)
  try match goal with
        | H : store _ _ _ = Some _ |- _ =>
          exploit (meminj_store T T T unit _ _ valid_update_match_tags);
          eauto; try solve [econstructor; eauto]; intros [? [? ?]]
        | H : swap _ _ = Some _ |- _ =>
          exploit match_stacks_swap; eauto; intros [? [? ?]]
        | H1 : Forall2 _ _ _,
          H2 : index_list _ _ = Some _ |- _ =>
          exploit match_stacks_index_list; eauto; intros [? [? ?]]
        | H : context[SysCall _],
          EXT : context[match_options _ _ _] |- _ =>
          exploit match_stacks_map_adata; eauto; intros (? & ? & ?); subst;
          exploit EXT; eauto; intros RES;
          match goal with
            | RES : match_options _ ?r1 ?r2,
              EQ : ?r2 = Some _ |- _ =>
              rewrite EQ in RES; inv RES
          end
        | H : context[SizeOf] |- _ =>
          exploit mi_valid'; eauto; intros (? & ? & FRAMES);
          apply Forall2_length in FRAMES; rewrite <- FRAMES
      end;

  (* Always using mem_irrel causes spurious existentials to be generated *)
  solve [eexists; split; [> once (econstructor;
                                  simpl; solve [simpl; eauto 9 using Forall2_length
                                               |eauto 9 with mem_irrel]) ..]].
Qed.

Program Definition abstract_quasi_abstract_sref :=
  @strong_refinement (abstract_machine atable)
                     (tini_quasi_abstract_machine atable)
                     eq match_states _.
Next Obligation.
  exploit a_qa_simulation; eauto.
  intros [? [? ?]].
  repeat eexists; eauto.
  destruct e2; constructor; auto.
Qed.

Definition emptyinj : meminj := fun _ => None.
Hint Unfold emptyinj : core.

Definition emptyinj_meminj :
  Meminj (Mem.empty _ _) (Mem.empty _ _) emptyinj.
Proof.
  unfold emptyinj.
  constructor; simpl; congruence.
Qed.
Hint Resolve emptyinj_meminj : core.

Lemma match_init_stacks: forall m2 d1,
 match_stacks emptyinj
              (map (fun a : PcAtom T => let (i,l) := a in AData (Vint i,l)) d1)
              (map (fun a : PcAtom T => let (i,l) := a in AData (Vint i,l)) d1)
              m2.
Proof.
  induction d1 as [|[xv xl] d1 IH]; intros;
  (simpl; constructor; auto).
Qed.
Hint Resolve match_init_stacks : core.

Program Definition abstract_quasi_abstract_ref :=
  @refinement_from_state_refinement (abstract_machine atable)
                                    (tini_quasi_abstract_machine atable)
                                    abstract_quasi_abstract_sref eq
                                    _.

Next Obligation.
  destruct i2 as [[p d] def]. simpl.
  econstructor; eauto.
Qed.

End Ref.


(** Events which define the API to the system. *)
Require Import Coq.Lists.List.
Require Import Coq.NArith.NArith.
Require Import Coq.PArith.PArith.
Require Import ListString.All.

Import ListNotations.
Local Open Scope type.

(** The id of a client socket. *)
Module ClientSocketId.
  (** A socket id is a natural number. *)
  Inductive t : Set :=
  | New : N -> t.
End ClientSocketId.

(** The kind of commands. *)
Module Command.
  (** The list of commands. *)
  Inductive t : Set :=
  | Log
  | FileRead
  | ServerSocketBind
  | ClientSocketRead | ClientSocketWrite | ClientSocketClose
  | Time.

  (** The type of the parameters of a request. *)
  Definition request (command : t) : Set :=
    match command with
    | Log => LString.t
    | FileRead => LString.t
    | ServerSocketBind => N
    | ClientSocketRead => ClientSocketId.t
    | ClientSocketWrite => ClientSocketId.t * LString.t
    | ClientSocketClose => ClientSocketId.t
    | Time => unit
    end.

  (** The type of the parameters of an answer. *)
  Definition answer (command : t) : Set :=
    match command with
    | Log => bool
    | FileRead => option LString.t
    | ServerSocketBind => option ClientSocketId.t
    | ClientSocketRead => option LString.t
    | ClientSocketWrite => bool
    | ClientSocketClose => bool
    | Time => N
    end.

  (** Decide the equality of commands. *)
  Definition eq_dec (command1 command2 : t) :
    {command1 = command2} + {command1 <> command2}.
    destruct command1; destruct command2;
      try (left; congruence);
      try (right; congruence).
  Defined.
End Command.

(** The type of an output. *)
Module Output.
  (** An output is a command, a channel id and an argument. *)
  Record t : Set := New {
    command : Command.t;
    id : positive;
    argument : Command.request command }.
End Output.

(** The type of an input. *)
Module Input.
  (** An input is a command, a channel id and an argument. *)
  Record t : Set := New {
    command : Command.t;
    id : positive;
    argument : Command.answer command }.
End Input.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University

  This file is part of Velisarios.

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

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

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

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export PBFTprops3.

Section PBFTprops4.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { pbft_context : PBFTcontext      }.
  Context { pbft_auth    : PBFTauth         }.
  Context { pbft_keys    : PBFTinitial_keys }.
  Context { pbft_hash    : PBFThash         }.

  Lemma find_pre_prepare_certificate_in_prepared_infos_some_implies :
    forall F n P nfo,
      find_pre_prepare_certificate_in_prepared_infos F n P = Some nfo
      -> In nfo P
         /\ n = prepared_info2seq nfo
         /\ F nfo = true.
  Proof.
    induction P; introv find; simpl in *; ginv.
    smash_pbft; apply IHP in find; tcsp.
  Qed.

  Lemma info_is_prepared_implies_prepared_info_has_correct_digest :
    forall p, info_is_prepared p = true -> prepared_info_has_correct_digest p = true.
  Proof.
    introv h.
    unfold info_is_prepared in h; smash_pbft.
  Qed.
  Hint Resolve info_is_prepared_implies_prepared_info_has_correct_digest : pbft.

  Lemma valid_prepared_info_implies_prepared_info_has_correct_digest :
    forall L p, valid_prepared_info L p = true -> prepared_info_has_correct_digest p = true.
  Proof.
    introv h.
    unfold valid_prepared_info in h; smash_pbft.
  Qed.
  Hint Resolve valid_prepared_info_implies_prepared_info_has_correct_digest : pbft.

  Lemma create_new_prepare_message_true_implies_correct :
    forall (sn : SeqNum) v keys P pp d (n : SeqNum),
      n < sn
      -> create_new_prepare_message sn v keys P = (true,(pp,d))
      -> correct_new_view_opre_prepare v n P pp = true.
  Proof.
    introv ltsn create.
    unfold create_new_prepare_message in create; smash_pbft.

    unfold correct_new_view_opre_prepare; simpl; smash_pbft;
      allrw SeqNumLt_true; allrw SeqNumLt_false; simpl in *; try omega; GC.

    unfold oexists_last_prepared; simpl.

    match goal with
    | [ |- ?x = _ ] => remember x as b; symmetry in Heqb; destruct b; auto;[]
    end.
    assert False; tcsp.
    rewrite existsb_false in Heqb.

    pose proof (Heqb x) as q; clear Heqb.

    match goal with
    | [ H : find_pre_prepare_certificate_in_prepared_infos _ _ _ = _ |- _ ] =>
      apply find_pre_prepare_certificate_in_prepared_infos_some_implies in H
    end.
    repnd.
    autodimp q hyp.
    smash_pbft.

    match goal with
    | [ H : _ <> _ |- _ ] => destruct H
    end.
    match goal with
    | [ H : valid_prepared_info _ _ = _ |- _ ] =>
      apply valid_prepared_info_implies_prepared_info_has_correct_digest in H
    end.
    unfold prepared_info_has_correct_digest in *; smash_pbft.
  Qed.

  Lemma create_new_prepare_messages_implies_correct_OPs :
    forall n sns v keys P OP NP,
      (forall (x : SeqNum) ppd,
          In x sns
          -> create_new_prepare_message x v keys P = (true, ppd)
          -> n < x)
      -> create_new_prepare_messages sns v keys P = (OP, NP)
      -> forallb
           (correct_new_view_opre_prepare v n P)
           (map fst OP) = true.
  Proof.
    induction sns; introv imp create; simpl in *; smash_pbft; dands; tcsp;
      try (complete (eapply IHsns; eauto)).
    repnd; simpl in *.

    pose proof (imp a (x2,x1)) as q.
    repeat (autodimp q hyp).

    eapply create_new_prepare_message_true_implies_correct;[|eauto]; tcsp.
  Qed.

  Lemma view_change2view_refresh_view_change :
    forall e st,
      view_change2view (refresh_view_change e st) = view_change2view e.
  Proof.
    tcsp.
  Qed.
  Hint Rewrite view_change2view_refresh_view_change : pbft.

  Lemma correct_view_change_implies_same_views :
    forall v vc,
      correct_view_change v vc = true
      -> v = view_change2view vc.
  Proof.
    introv cor; unfold correct_view_change in cor; smash_pbft.
    unfold same_views in *; smash_pbft.
  Qed.

  Lemma ViewLe_true :
    forall v1 v2, ViewLe v1 v2 = true <-> v1 <= v2.
  Proof.
    introv; unfold ViewLe.
    rewrite Nat.leb_le; tcsp.
  Qed.

  Lemma ViewLe_false :
    forall v1 v2, ViewLe v1 v2 = false <-> v1 > v2.
  Proof.
    introv; unfold ViewLe.
    rewrite leb_iff_conv. tcsp.
  Qed.

  Lemma le_max_view_left :
    forall (a b : View), a <= max_view a b.
  Proof.
    introv; destruct a, b; unfold max_view; smash_pbft.
  Qed.
  Hint Resolve le_max_view_left : pbft.

  Lemma le_max_view_right :
    forall (a b : View), a <= max_view b a.
  Proof.
    introv; destruct a, b; unfold max_view; smash_pbft.
    allrw ViewLe_false; simpl in *; omega.
  Qed.
  Hint Resolve le_max_view_right : pbft.

  Lemma le_max_seq_num :
    forall (a b : SeqNum), a <= max_seq_num a b.
  Proof.
    introv; destruct a, b; unfold max_seq_num; simpl; smash_pbft;
      allrw SeqNumLe_true; auto; try omega.
  Qed.
  Hint Resolve le_max_seq_num : pbft.

  Lemma le_max_seq_num_right :
    forall (a b : SeqNum), b <= max_seq_num a b.
  Proof.
    introv; destruct a, b; unfold max_seq_num; simpl; smash_pbft;
      allrw SeqNumLe_true; auto; try omega.
  Qed.
  Hint Resolve le_max_seq_num_right : pbft.

  Lemma le_max_seq_num_op :
    forall (a : SeqNum) b, a <= max_seq_num_op a b.
  Proof.
    introv; destruct b; simpl; eauto 3 with pbft.
  Qed.
  Hint Resolve le_max_seq_num_op : pbft.

  Lemma PreparedInfos2max_seq_none_implies :
    forall F l,
      PreparedInfos2max_seq F l = None
      -> forall p, In p l -> F p = false.
  Proof.
    induction l; introv prep i; simpl in *; smash_pbft.
    repndors; subst; tcsp.
  Qed.

  Lemma PreparedInfos2max_seq_is_max :
    forall pi F l n,
      In pi l
      -> F pi = true
      -> PreparedInfos2max_seq F l = Some n
      -> prepared_info2seq pi <= n.
  Proof.
    induction l; introv i Fpi prep; simpl in *; tcsp; repndors; subst; smash_pbft;[].
    remember (PreparedInfos2max_seq F l) as m; symmetry in Heqm; destruct m; simpl in *; smash_pbft.
    eapply PreparedInfos2max_seq_none_implies in Heqm;[|eauto]; pbft_simplifier.
  Qed.
  Hint Resolve PreparedInfos2max_seq_is_max : pbft.

  Lemma implies_in_from_min_to_max :
    forall (n x m : SeqNum),
      n < x
      -> x <= m
      -> In x (from_min_to_max n m).
  Proof.
    introv h q.
    unfold from_min_to_max; smash_pbft; simpl in *; try omega;[].
    apply in_map_iff.
    exists x; simpl; dands; autorewrite with pbft; auto.
    apply in_seq; simpl; dands; try omega.
  Qed.
  Hint Resolve implies_in_from_min_to_max : pbft.

  Lemma in_from_min_to_max_trans :
    forall (x n m k : SeqNum),
      k <= m
      -> In x (from_min_to_max n k)
      -> In x (from_min_to_max n m).
  Proof.
    introv lek i.
    unfold from_min_to_max in *; smash_pbft.

    - apply in_map_iff in i; exrepnd; subst; simpl in *.
      allrw in_seq; repnd; try omega.

    - allrw in_map_iff; exrepnd; subst; simpl in *.
      allrw in_seq; repnd; try omega.
      exists x0; simpl; dands; auto.
      apply in_seq; dands; simpl; try omega.
  Qed.
  Hint Resolve in_from_min_to_max_trans : pbft.

  Lemma view_change_cert2max_seq_preps_vc_none_implies :
    forall F l,
      view_change_cert2max_seq_preps_vc F l = None
      -> forall p, In p (view_change_cert2prep l) -> F p = false.
  Proof.
    induction l; introv prep i; simpl in *; smash_pbft.
    allrw in_app_iff; repndors; tcsp.
    unfold view_change2max_seq_preps in *.
    eapply PreparedInfos2max_seq_none_implies; eauto.
  Qed.

  Lemma implies_prepared_info2max_seq_in_from_min_to_max :
    forall l pi (n m : SeqNum) vc F,
      In pi (view_change_cert2prep l)
      -> F pi = true
      -> n < prepared_info2seq pi
      -> view_change_cert2max_seq_preps_vc F l = Some (m, vc)
      -> In (prepared_info2seq pi) (from_min_to_max n m).
  Proof.
    induction l; introv i Ft ltn eqv; simpl in *; tcsp;
      smash_pbft; simpl in *; try omega.

    - allrw in_app_iff; repndors; tcsp.

      + unfold view_change2max_seq_preps in *.
        dup i as les.
        eapply PreparedInfos2max_seq_is_max in les;[| |eauto];auto;[].
        eapply implies_in_from_min_to_max; simpl in *; try omega.

      + eapply IHl; eauto.

    - allrw in_app_iff; repndors; tcsp.

      + unfold view_change2max_seq_preps in *.
        dup i as les.
        eapply PreparedInfos2max_seq_is_max in les;[| |eauto];auto;[].
        eapply implies_in_from_min_to_max; simpl in *; try omega.

      + dup i as j.
        eapply IHl in j;[| |eauto|eauto];auto; eauto 3 with pbft.

    - allrw in_app_iff; repndors; tcsp.

      + unfold view_change2max_seq_preps in *.
        dup i as les.
        eapply PreparedInfos2max_seq_is_max in les;[| |eauto];auto;[].
        eapply implies_in_from_min_to_max; simpl in *; try omega.

      + eapply view_change_cert2max_seq_preps_vc_none_implies in i;[|eauto]; pbft_simplifier.

    - allrw in_app_iff; repndors; tcsp.

      + unfold view_change2max_seq_preps in *.
        dup i as les.
        eapply PreparedInfos2max_seq_none_implies in i;[|eauto]; pbft_simplifier.

      + eapply IHl; eauto.
  Qed.
  Hint Resolve implies_prepared_info2max_seq_in_from_min_to_max : pbft.

  Lemma from_min_to_max_of_view_changes_nil_implies_all_sequence_numbers_are_accounted_for_op_true :
    forall entry OP,
      is_some (vce_view_change entry) = true
      -> from_min_to_max_of_view_changes entry = []
      -> all_sequence_numbers_are_accounted_for_op
           (view_change_cert2prep (view_change_entry2view_changes entry))
           (view_change_cert2max_seq (view_change_entry2view_changes entry))
           OP = true.
  Proof.
    introv issome h.
    unfold from_min_to_max_of_view_changes in h.
    destruct entry, vce_view_change; simpl in *; tcsp; GC.
    unfold all_sequence_numbers_are_accounted_for_op.
    unfold all_sequence_numbers_are_accounted_for.

    remember (view_change_cert2max_seq (v :: vce_view_changes)) as maxVop.
    symmetry in HeqmaxVop.
    destruct maxVop; simpl in *;
      [|unfold view_change_cert2max_seq in *; simpl in *; smash_pbft];[].

    unfold from_min_to_max_op in h.

    rewrite forallb_forall.
    introv i.
    unfold sequence_number_is_accounted_for; smash_pbft;[].

    unfold from_min_to_max_of_view_changes_cert in *.
    rewrite HeqmaxVop in *; simpl in *.

    (* WARNING *)
    clear HeqmaxVop.

    assert (view_change2prep v ++ view_change_cert2prep vce_view_changes
            = view_change_cert2prep (v :: vce_view_changes)) as xx by tcsp.
    rewrite xx in *; clear xx.

    (* WARNING *)
    remember (v :: vce_view_changes) as l; clear Heql.
    remember (valid_prepared_info (view_change_cert2prep l)) as F; clear HeqF.

    smash_pbft;[|].

    - unfold view_change_cert2max_seq_preps in *; smash_pbft;[].
      eapply implies_prepared_info2max_seq_in_from_min_to_max in i;
        [| |eauto|eauto];auto.
      rewrite h in *; simpl in *; tcsp.

    - unfold view_change_cert2max_seq_preps in *; smash_pbft;[].
      eapply view_change_cert2max_seq_preps_vc_none_implies in i;[|eauto]; pbft_simplifier.
  Qed.
  Hint Resolve from_min_to_max_of_view_changes_nil_implies_all_sequence_numbers_are_accounted_for_op_true : pbft.

  Lemma view_change_cert_max_seq_preps_vc_none_implies_all_sequence_numbers_are_accounted_for :
    forall k min OP,
      view_change_cert2max_seq_preps_vc (valid_prepared_info (view_change_cert2prep k)) k = None
      -> all_sequence_numbers_are_accounted_for (view_change_cert2prep k) min OP = true.
  Proof.
    introv vcmax.
    unfold all_sequence_numbers_are_accounted_for.
    apply forallb_forall.
    introv i.
    unfold sequence_number_is_accounted_for; smash_pbft.
    assert False; tcsp.
    remember (valid_prepared_info (view_change_cert2prep k)) as F; clear HeqF.
    eapply view_change_cert2max_seq_preps_vc_none_implies in vcmax;[|eauto]; pbft_simplifier.
  Qed.
  Hint Resolve view_change_cert_max_seq_preps_vc_none_implies_all_sequence_numbers_are_accounted_for : pbft.

  Lemma create_new_prepare_message_true_of_valid_prepared_info_in_implies :
    forall x l v keys ppd,
      In x l
      -> valid_prepared_info l x = true
      -> create_new_prepare_message (prepared_info2seq x) v keys l = (true, ppd)
      -> same_digests (prepared_info2digest x) (pre_prepare2digest (fst ppd)) = true
         /\ same_seq_nums (prepared_info2seq x) (pre_prepare2seq (fst ppd)) = true.
  Proof.
    introv i valid create.
    repnd; simpl in *.
    unfold create_new_prepare_message in create; smash_pbft.
    rename_hyp_with find_pre_prepare_certificate_in_prepared_infos fprep.
    apply find_pre_prepare_certificate_in_prepared_infos_some_implies in fprep.
    repnd.

    unfold same_seq_nums; smash_pbft; dands; auto;[].
    unfold pre_prepare2digest; simpl.

    unfold valid_prepared_info in *; smash_pbft.
    unfold last_prepared_info in *.
    allrw forallb_forall.
    applydup valid0 in fprep0.
    smash_pbft;[|].

    - match goal with
      | [ H : info_is_prepared x0 = true |- _ ] => rename H into isprep
      end.
      unfold info_is_prepared in isprep.
      smash_pbft.
      unfold prepared_info_has_correct_digest in *; smash_pbft.

    - applydup fprep2 in i.
      smash_pbft;[].
      try omega.
  Qed.
  Hint Resolve create_new_prepare_message_true_of_valid_prepared_info_in_implies : pbft.

  Lemma create_new_prepare_message_false_of_valid_prepared_info_in_implies :
    forall x l v keys ppd,
      In x l
      -> valid_prepared_info l x = true
      -> create_new_prepare_message (prepared_info2seq x) v keys l = (false, ppd)
      -> False.
  Proof.
    introv i valid create.
    repnd; simpl in *.
    unfold create_new_prepare_message in create; smash_pbft.
    rename_hyp_with find_pre_prepare_certificate_in_prepared_infos fprep.
    eapply find_pre_prepare_certificate_in_prepared_infos_none_implies in i; eauto.
    repndors; pbft_simplifier.
  Qed.
  Hint Resolve create_new_prepare_message_false_of_valid_prepared_info_in_implies : pbft.

  Lemma create_new_prepare_messages_of_valid_prepared_info_in_implies :
    forall N v keys l OP NP x,
      create_new_prepare_messages N v keys l = (OP, NP)
      -> In x l
      -> valid_prepared_info l x = true
      -> In (prepared_info2seq x) N
      -> exists_prepared_info_in_pre_prepares x (map fst OP) = true.
  Proof.
    induction N; introv create i valid j; simpl in *; tcsp.
    repndors; subst; smash_pbft.
  Qed.
  Hint Resolve create_new_prepare_messages_of_valid_prepared_info_in_implies : pbft.

  Lemma create_new_prepare_messages_implies_all_sequence_numbers_are_accounted_for :
    forall l v keys OP NP min max vc,
      create_new_prepare_messages (from_min_to_max min max) v keys (view_change_cert2prep l) = (OP, NP)
      -> view_change_cert2max_seq l = Some min
      -> view_change_cert2max_seq_preps_vc (valid_prepared_info (view_change_cert2prep l)) l = Some (max, vc)
      -> all_sequence_numbers_are_accounted_for (view_change_cert2prep l) min (map fst OP) = true.
  Proof.
    introv create vcmin vcmax.
    unfold all_sequence_numbers_are_accounted_for.
    apply forallb_forall.
    introv i.
    unfold sequence_number_is_accounted_for; smash_pbft.
  Qed.
  Hint Resolve create_new_prepare_messages_implies_all_sequence_numbers_are_accounted_for : pbft.

  Lemma check_broadcast_new_view_generates :
    forall i state entry nv entry' OP NP,
      check_broadcast_new_view i state entry = Some (nv, entry', OP, NP)
      -> correct_new_view nv = true.
  Proof.
    introv check.
    dup check as check_backup.
    hide_hyp check_backup.
    unfold check_broadcast_new_view in check; smash_pbft.

    rename_hyp_with view_changed_entry changed.
    dup changed as changed_backup.
    hide_hyp changed_backup.
    unfold view_changed_entry in changed; smash_pbft.

    pose proof (implies_length_view_change_entry2view_changes entry (length (vce_view_changes entry))) as lenvcs.
    repeat (autodimp lenvcs hyp); allrw; auto;[].

    remember (replace_own_view_change_in_entry (refresh_view_change x state) entry) as entry'.
    remember (view_change_cert2max_seq (view_change_entry2view_changes entry')) as minop.
    symmetry in Heqminop.
    rename_hyp_with create_new_prepare_messages cr.
    destruct minop as [min|];
      [|applydup create_new_prepare_messages_view_change_cert2max_seq_none_implies in cr as eqs; auto;
        repnd; subst; simpl in *;
        rewrite eqs in *; simpl in *; GC;
        unfold correct_new_view; simpl; smash_pbft; try omega;
        destruct entry, vce_view_change; simpl in *; smash_pbft; try omega;
        [eapply from_min_to_max_of_view_changes_nil_implies_all_sequence_numbers_are_accounted_for_op_true in eqs;
         simpl in *; auto; exact eqs|];[];
        match goal with
        | [ H : correct_view_change _ _ = _ |- _ ] =>
          applydup correct_view_change_implies_same_views in H as sv; simpl in sv
        end; autorewrite with pbft in *; subst; tcsp];[].

    assert (forall n, In n (from_min_to_max_of_view_changes entry') -> n <= max_O OP) as imp1.
    { introv i; eapply view_changed_entry_some_and_check_broadcast_new_view_implies_le; eauto. }

    clear check_backup.
    clear changed_backup.

    rename_hyp_with correct_view_change corvcs.
    assert (vce_view entry = view_change2view x) as eqviews.
    {
      unfold view_change_entry2view_changes in corvcs.
      subst entry'; simpl in *.
      destruct entry; simpl in *; smash_pbft.
      unfold correct_view_change in *; smash_pbft.
      unfold same_views in *; smash_pbft.
    }

    unfold correct_new_view; simpl; smash_pbft; try omega;
      try (complete (destruct entry, vce_view_change; simpl in *; smash_pbft; try omega));
      [| |].

    - rename_hyp_with correct_new_view_opre_prepare_op coro.
      rename_hyp_with correct_new_view_npre_prepare_op corn.
      rename_hyp_with SeqNumDeq nrep1.

      hide_hyp imp1.
      hide_hyp coro.
      hide_hyp corn.
      hide_hyp nrep1.

      rewrite Heqminop; simpl.
      remember (replace_own_view_change_in_entry (refresh_view_change x state) entry) as l.

      unfold from_min_to_max_of_view_changes in *; simpl in *.
      unfold from_min_to_max_of_view_changes_cert in *; simpl in *.
      rewrite Heqminop in *; simpl in *.

      unfold view_change_cert2max_seq_preps in *; smash_pbft.

    - match goal with
      | [ H1 : create_new_prepare_messages _ _ _ _ = _, H2 : forallb _ _ = false |- _ ] =>
        apply (create_new_prepare_messages_implies_correct_NPs
                 min (pre_prepares2max_seq (map fst OP))) in H1
      end.

      {
        rewrite Heqminop in *; simpl in *; autorewrite with pbft in *; smash_pbft.
      }

      introv i create; repnd.
      dands; eauto 2 with pbft.
      rewrite <- max_O_as_pre_prepares2max_seq.

      applydup imp1 in i.
      apply le_lt_or_eq in i0; repndors; tcsp;[].
      apply implies_eq_seq_nums in i0.

      assert False; tcsp.

      clear imp1.
      unfold from_min_to_max_of_view_changes in *.
      unfold from_min_to_max_of_view_changes_cert in *.

      applydup in_from_min_to_max_op_implies in i.
      exrepnd.
      rewrite i2 in *; ginv.
      rewrite i3 in *; ginv.
      simpl in *.

      pose proof (max_O_in OP) as q.

      apply (view_change_cert2max_seq_preps_implies_exists_create_new_prepare_message
               (view_change2view x) (local_keys state)) in i3.
      exrepnd.

      match goal with
      | [ H1 : create_new_prepare_message _ _ _ _ = (false, _),
          H2 : create_new_prepare_messages _ _ _ _ = _
      |- _ ] =>
        applydup create_new_prepare_message_implies_same_sequence_number in H1 as eqsn;
          dup H2 as c1; dup H2 as c2; dup H2 as c3; rename H1 into fcreate
      end.

      (* c1 part *)
      eapply create_new_prepare_message_true_implies_oprep_not_nil in c1;
        [| |eauto]; eauto 2 with pbft;[].

      (* c2 part *)
      eapply false_implies_in_create_new_prepare_messages_n_pre_prepare in c2;
        [| |exact fcreate];[|unfold from_min_to_max_of_view_changes;allrw;simpl;auto];[].

      (* c3 part *)
      apply create_new_prepare_messages_implies_norepeatsb in c3; eauto 2 with pbft;[].

      autodimp q hyp; eauto 2 with pbft;[].
      exrepnd.

      eapply norepeatsb_pre_prepare2seq_oprep_nprep_implies;[eauto| |eauto|eauto].
      congruence.

    - match goal with
      | [ H1 : create_new_prepare_messages _ _ _ _ = _, H2 : forallb _ _ = false |- _ ] =>
        apply (create_new_prepare_messages_implies_correct_OPs min) in H1
      end.

      {
        rewrite Heqminop in *; simpl in *; autorewrite with pbft in *; smash_pbft.
      }

      introv i create.
      dands; eauto 2 with pbft.
  Qed.
  Hint Resolve check_broadcast_new_view_generates : pbft.

End PBFTprops4.

Hint Resolve info_is_prepared_implies_prepared_info_has_correct_digest : pbft.
Hint Resolve valid_prepared_info_implies_prepared_info_has_correct_digest : pbft.
Hint Resolve le_max_view_left : pbft.
Hint Resolve le_max_view_right : pbft.
Hint Resolve le_max_seq_num : pbft.
Hint Resolve le_max_seq_num_right : pbft.
Hint Resolve le_max_seq_num_op : pbft.
Hint Resolve PreparedInfos2max_seq_is_max : pbft.
Hint Resolve implies_in_from_min_to_max : pbft.
Hint Resolve in_from_min_to_max_trans : pbft.
Hint Resolve implies_prepared_info2max_seq_in_from_min_to_max : pbft.
Hint Resolve from_min_to_max_of_view_changes_nil_implies_all_sequence_numbers_are_accounted_for_op_true : pbft.
Hint Resolve view_change_cert_max_seq_preps_vc_none_implies_all_sequence_numbers_are_accounted_for : pbft.
Hint Resolve create_new_prepare_message_true_of_valid_prepared_info_in_implies : pbft.
Hint Resolve create_new_prepare_message_false_of_valid_prepared_info_in_implies : pbft.
Hint Resolve create_new_prepare_messages_of_valid_prepared_info_in_implies : pbft.
Hint Resolve create_new_prepare_messages_implies_all_sequence_numbers_are_accounted_for : pbft.
Hint Resolve check_broadcast_new_view_generates : pbft.

Hint Rewrite @view_change2view_refresh_view_change : pbft.