From Undecidability Require Import TM.Util.Prelim TM.Util.Relations TM.Util.TM_facts.

Set Default Proof Using "Type".

(* * Tapes-Lift *)

(* Select the [m] elements of [V], of that their index is in [I] *)
Definition select (m n: nat) (X: Type) (I : Vector.t (Fin.t n) m) (V : Vector.t X n) : Vector.t X m :=
  Vector.map (Vector.nth V) I.

Corollary select_nth m n X (I : Vector.t (Fin.t n) m) (V : Vector.t X n) (k : Fin.t m) :
  (select I V) [@ k] = V [@ (I [@ k])].
Proof. now apply Vector.nth_map. Qed.

(* Relational tapes-lift *)
Section LiftTapes_Rel.

  Variable (sig : finType) (F : Type).
  Variable m n : nat.

  Variable I : Vector.t (Fin.t n) m.

  Definition not_index (i : Fin.t n) : Prop :=
    ~ Vector.In i I.

  Variable (R : pRel sig F m).

  Definition LiftTapes_select_Rel : pRel sig F n :=
    fun t '(y, t') => R (select I t) (y, select I t').

  Definition LiftTapes_eq_Rel : pRel sig F n :=
    ignoreParam (fun t t' => forall i : Fin.t n, not_index i -> t'[@i] = t[@i]).

  Definition LiftTapes_Rel := LiftTapes_select_Rel ∩ LiftTapes_eq_Rel.

  Variable T : tRel sig m.

  Definition LiftTapes_T : tRel sig n :=
    fun t k => T (select I t) k.

End LiftTapes_Rel.

Arguments not_index : simpl never.
Arguments LiftTapes_select_Rel {sig F m n} I R x y /.
Arguments LiftTapes_eq_Rel {sig F m n} I x y /.
Arguments LiftTapes_Rel {sig F m n } I R x y /.
Arguments LiftTapes_T {sig m n} I T x y /.

Lemma vector_hd_nth (X : Type) (n : nat) (xs : Vector.t X (S n)) : Vector.hd xs = xs[@Fin0].
Proof. now destruct_vector. Qed.

Lemma vector_tl_nth (X : Type) (n : nat) (i : Fin.t (S n)) (xs : Vector.t X (S (S n))) : (Vector.tl xs)[@i] = xs[@Fin.FS i].
Proof. now destruct_vector. Qed.

Section Fill.

  Fixpoint lookup_index_vector {m n : nat} (I : Vector.t (Fin.t n) m) : Fin.t n -> option (Fin.t m) :=
    match I with
    | Vector.nil _ => fun (i : Fin.t n) => None
    | Vector.cons _ i' m' I' =>
      fun (i : Fin.t n) =>
        if Fin.eqb i i' then Some Fin0
        else match lookup_index_vector I' i with
             | Some j => Some (Fin.FS j)
             | None => None
             end
    end.

  Lemma Some_inj (X : Type) (x y : X) :
    Some x = Some y -> x = y.
  Proof. congruence. Qed.

  Lemma lookup_index_vector_Some (m n : nat) (I : Vector.t (Fin.t n) m) (i : Fin.t n) (j : Fin.t m) :
    dupfree I ->
    I[@j] = i ->
    lookup_index_vector I i = Some j.
  Proof.
    induction 1 as [ | m i' I' H1 H2 IH]; intros Heq; cbn in *.
    - contradict (fin_destruct_O j).
    - destruct (Fin.eqb i i') eqn:Eqb; cbn in *.
      + f_equal. apply Fin.eqb_eq in Eqb as ->.
        pose proof (fin_destruct_S j) as [(j'&->) | ->]; cbn in *.
        * exfalso. contradict H1. eapply vect_nth_In; eauto.
        * reflexivity.
      + destruct (lookup_index_vector I' i) as [j' | ] eqn:El.
        * pose proof (fin_destruct_S j) as [(j''&->) | ->]; cbn in *.
          -- specialize IH with (1 := Heq). apply Some_inj in IH as ->. reflexivity.
          -- subst. enough (Fin.eqb i i = true) by congruence. now apply Fin.eqb_eq.
        * exfalso. pose proof (fin_destruct_S j) as [(j''&->) | ->]; cbn in *.
          -- specialize IH with (1 := Heq). congruence.
          -- subst. enough (Fin.eqb i i = true) by congruence. now apply Fin.eqb_eq.
  Qed.

  Lemma lookup_index_vector_Some' (m n : nat) (I : Vector.t (Fin.t n) m) (i : Fin.t n) (j : Fin.t m) :
    lookup_index_vector I i = Some j ->
    I[@j] = i.
  Proof.
    revert i j. induction I as [ | i' n' I' IH ]; intros i j Hj.
    - destruct_fin j.
    - pose proof (fin_destruct_S j) as [(j'&->) | ->]; cbn in *.
      + destruct (Fin.eqb i i'); inv Hj.
        destruct (lookup_index_vector I' i) as [ j'' | ] eqn:Ej''.
        * apply Some_inj in H0. apply Fin.FS_inj in H0 as ->. now apply IH.
        * congruence.
      + destruct (Fin.eqb i i') eqn:Ei'.
        * now apply Fin.eqb_eq in Ei'.
        * destruct (lookup_index_vector I' i) as [ j'' | ] eqn:Ej''.
          -- congruence.
          -- congruence.
  Qed.

  Lemma lookup_index_vector_None (m n : nat) (I : Vector.t (Fin.t n) m) (i : Fin.t n) :
    (~ Vector.In i I) ->
    lookup_index_vector I i = None.
  Proof.
    intros HNotIn.
    destruct (lookup_index_vector I i) eqn:E; auto.
    exfalso. apply lookup_index_vector_Some' in E.
    contradict HNotIn. eapply vect_nth_In; eauto.
  Qed.

  Variable X : Type.

  (* Replace the elements of [init] of which the index is in [I] with the element in [V] of that index. *)
  Definition fill {m n : nat} (I : Vector.t (Fin.t n) m) (init : Vector.t X n) (V : Vector.t X m) : Vector.t X n :=
    tabulate (fun i => match lookup_index_vector I i with
                    | Some j => V[@j]
                    | None => init[@i]
                    end).

  Section Test.
    Variable (a b x y z : X).

    (* The following goals should hold by computation *)
    Goal fill [|Fin0; Fin1|] [|x;y;z|] [|a;b|] = [|a;b;z|].
    Proof. cbn. reflexivity. Qed.

    Goal fill [|Fin2; Fin1|] [|x;y;z|] [|a;b|] = [|x;b;a|].
    Proof. cbn. reflexivity. Qed.

    Goal fill [|Fin1; Fin0|] [|x;y;z|] [|a;b|] = [|b;a;z|]. (* [a] and [b] are swapped, [z] is unchanged. *)
    Proof. cbn. reflexivity. Qed.

    (* This didn't hold (by computation) for the old version with replacement *)
    Goal forall (ss : Vector.t X 3), fill [|Fin0; Fin1|] ss [|a;b|] = [|a;b; ss[@Fin2]|].
    Proof. intros. cbn. reflexivity. Qed.

  End Test.

  Variable m n : nat.
  Implicit Types (i : Fin.t n) (j : Fin.t m).
  Implicit Types (I : Vector.t (Fin.t n) m) (init : Vector.t X n) (V : Vector.t X m).

  Lemma fill_correct_nth I init V i j :
    dupfree I ->
    I[@j] = i ->
    (fill I init V)[@i] = V[@j].
  Proof.
    intros HDup Heq.
    unfold fill. simpl_vector.
    erewrite lookup_index_vector_Some; eauto.
  Qed.

  Lemma fill_not_index I init V (i : Fin.t n) :
    not_index I i ->
    (fill I init V)[@i] = init[@i].
  Proof.
    intros HNotIn. unfold not_index in HNotIn.
    unfold fill. simpl_vector.
    erewrite lookup_index_vector_None; eauto.
  Qed.

  Definition fill_default I (def : X) V :=
    fill I (Vector.const def n) V.

  Corollary fill_default_not_index I V def i :
    not_index I i ->
    (fill_default I def V)[@i] = def.
  Proof. intros. unfold fill_default. rewrite fill_not_index; auto. apply Vector.const_nth. Qed.

End Fill.

Section loop_map.
  Variable A B : Type.
  Variable (f : A -> A) (h : A -> bool) (g : A -> B).
  Hypothesis step_map_comp : forall a, g (f a) = g a.

  Lemma loop_map k a1 a2 :
    loop f h a1 k = Some a2 ->
    g a2 = g a1.
  Proof using step_map_comp.
    revert a1 a2. induction k as [ | k' IH]; intros; cbn in *.
    - destruct (h a1); now inv H.
    - destruct (h a1).
      + now inv H.
      + apply IH in H. now rewrite step_map_comp in H.
  Qed.

End loop_map.

Section LiftNM.

  Variable sig : finType.

  Variable m n : nat.

  Variable F : finType.

  Variable pM : pTM sig F m.

  Variable I : Vector.t ((Fin.t n)) m.
  Variable I_dupfree : dupfree I.

  Definition LiftTapes_trans :=
    fun '(q, sym ) =>
      let (q', act) := trans (m := projT1 pM) (q, select I sym) in
      (q', fill_default I (None, Nmove) act).

  Definition LiftTapes_TM : TM sig n :=
    {|
      trans := LiftTapes_trans;
      start := start (projT1 pM);
      halt := halt (m := projT1 pM);
    |}.

  Definition LiftTapes : pTM sig F n := (LiftTapes_TM; projT2 pM).

  Definition selectConf : mconfig sig (state LiftTapes_TM) n -> mconfig sig (state (projT1 pM)) m :=
    fun c => mk_mconfig (cstate c) (select I (ctapes c)).

  Lemma current_chars_select (t : tapes sig n) :
    current_chars (select I t) = select I (current_chars t).
  Proof. unfold current_chars, select. apply Vector.eq_nth_iff; intros i ? <-. now simpl_tape. Qed.

  Lemma doAct_select (t : tapes sig n) act :
    doAct_multi (select I t) act = select I (doAct_multi t (fill_default I (None, Nmove) act)).
  Proof using I_dupfree.
    unfold doAct_multi, select. apply Vector.eq_nth_iff; intros i ? <-. simpl_tape.
    unfold fill_default. f_equal. symmetry. now apply fill_correct_nth.
  Qed.

  Lemma LiftTapes_comp_step (c1 : mconfig sig (state (projT1 pM)) n) :
    step (M := projT1 pM) (selectConf c1) = selectConf (step (M := LiftTapes_TM) c1).
  Proof using I_dupfree.
    unfold selectConf. unfold step; cbn.
    destruct c1 as [q t] eqn:E1.
    unfold step in *. cbn -[current_chars doAct_multi] in *.
    rewrite current_chars_select.
    destruct (trans (q, select I (current_chars t))) as (q', act) eqn:E; cbn.
    f_equal. apply doAct_select.
  Qed.

  Lemma LiftTapes_lift (c1 c2 : mconfig sig (state LiftTapes_TM) n) (k : nat) :
    loopM (M := LiftTapes_TM) c1 k = Some c2 ->
    loopM (M := projT1 pM) (selectConf c1) k = Some (selectConf c2).
  Proof using I_dupfree.
    intros HLoop.
    eapply loop_lift with (f := step (M := LiftTapes_TM)) (h := haltConf (M := LiftTapes_TM)).
    - cbn. auto.
    - intros ? _. now apply LiftTapes_comp_step.
    - apply HLoop.
  Qed.

  Lemma LiftTapes_comp_eq (c1 c2 : mconfig sig (state LiftTapes_TM) n) (i : Fin.t n) :
    not_index I i ->
    step (M := LiftTapes_TM) c1 = c2 ->
    (ctapes c2)[@i] = (ctapes c1)[@i].
  Proof.
    intros HI H. unfold LiftTapes_TM in *.
    destruct c1 as [state1 tapes1] eqn:E1, c2 as [state2 tapes2] eqn:E2.
    unfold step, select in *. cbn in *.
    destruct (trans (state1, select I (current_chars tapes1))) as (q, act) eqn:E3.
    inv H. erewrite Vector.nth_map2; eauto. now rewrite fill_default_not_index.
  Qed.

  Lemma LiftTapes_eq (c1 c2 : mconfig sig (state LiftTapes_TM) n) (k : nat) (i : Fin.t n) :
    not_index I i ->
    loopM (M := LiftTapes_TM) c1 k = Some c2 ->
    (ctapes c2)[@i] = (ctapes c1)[@i].
  Proof.
    intros Hi HLoop. unfold loopM in HLoop.
    eapply loop_map with (g := fun c => (ctapes c)[@i]); eauto.
    intros. now apply LiftTapes_comp_eq.
  Qed.

  Lemma LiftTapes_Realise (R : Rel (tapes sig m) (F * tapes sig m)) :
    pM ⊨ R ->
    LiftTapes ⊨ LiftTapes_Rel I R.
  Proof using I_dupfree.
    intros H. split.
    - apply (H (select I t) k (selectConf outc)).
      now apply (@LiftTapes_lift (initc LiftTapes_TM t) outc k).
    - hnf. intros i HI. now apply (@LiftTapes_eq (initc LiftTapes_TM t) outc k i HI).
  Qed.

  Lemma LiftTapes_unlift (k : nat)
        (c1 : mconfig sig (state (LiftTapes_TM)) n)
        (c2 : mconfig sig (state (LiftTapes_TM)) m) :
    loopM (M := projT1 pM) (selectConf c1) k = Some c2 ->
    exists c2' : mconfig sig (state (LiftTapes_TM)) n,
      loopM (M := LiftTapes_TM) c1 k = Some c2' /\
      c2 = selectConf c2'.
  Proof using I_dupfree.
    intros HLoop. unfold loopM in *. cbn in *.
    apply loop_unlift with (lift:=selectConf) (f:=step (M:=LiftTapes_TM)) (h:=haltConf (M:=LiftTapes_TM)) in HLoop as (c'&HLoop&->).
    - exists c'. split; auto.
    - auto.
    - intros ? _. apply LiftTapes_comp_step.
  Qed.

  Lemma LiftTapes_Terminates T :
    projT1 pM ↓ T ->
    projT1 LiftTapes ↓ LiftTapes_T I T.
  Proof using I_dupfree.
    intros H initTapes k Term. hnf in *.
    specialize (H (select I initTapes) k Term) as (outc&H).
    pose proof (@LiftTapes_unlift k (initc LiftTapes_TM initTapes) outc H) as (X&X'&->). eauto.
  Qed.

  Lemma LiftTapes_RealiseIn R k :
    pM ⊨c(k) R ->
    LiftTapes ⊨c(k) LiftTapes_Rel I R.
  Proof using I_dupfree.
    intros (H1&H2) % Realise_total. apply Realise_total. split.
    - now apply LiftTapes_Realise.
    - eapply TerminatesIn_monotone.
      + apply LiftTapes_Terminates; eauto.
      + firstorder.
  Qed.

End LiftNM.

Arguments LiftTapes : simpl never.
Notation "pM @ ts" := (LiftTapes pM ts) (at level 41, only parsing).

(* * Tactic Support *)

(* TODO: Some of this is probably deprecated, e.g. the [app_tapes] stuff *)

Lemma smpl_dupfree_helper1 (n : nat) :
  dupfree [|Fin.F1 (n := n)|].
Proof. vector_dupfree. Qed.

Lemma smpl_dupfree_helper2 (n : nat) :
  dupfree [|Fin.FS (Fin.F1 (n := n))|].
Proof. vector_dupfree. Qed.

Ltac smpl_dupfree :=
  once lazymatch goal with
  | [ |- dupfree [|Fin.F1 |] ] => apply smpl_dupfree_helper1
  | [ |- dupfree [|Fin.FS |] ] => apply smpl_dupfree_helper2
  | [ |- dupfree _ ] => now vector_dupfree (* fallback tactic *)
  end.

Ltac smpl_TM_LiftN :=
  once lazymatch goal with
  | [ |- LiftTapes _ _ ⊨ _] =>
    apply LiftTapes_Realise; [ smpl_dupfree | ]
  | [ |- LiftTapes _ _ ⊨c(_) _] => apply LiftTapes_RealiseIn; [ smpl_dupfree | ]
  | [ |- projT1 (LiftTapes _ _) ↓ _] => apply LiftTapes_Terminates; [ smpl_dupfree | ]
  end.
Smpl Add smpl_TM_LiftN : TM_Correct.

Ltac is_num_const n :=
  once lazymatch n with
  | O => idtac
  | S ?n => is_num_const n
  | _ => fail "Not a number"
  end.

(*
Section Test_Is_Num_Const.
  Variable n : nat.
  Eval cbn in ltac:(is_num_const 42).
  Fail Eval cbn in ltac:(is_num_const n).
  Fail Eval cbn in ltac:(is_num_const (S n)).
End Test_Is_Num_Const.
*)

(* This tactical executes [t 0], ..., [t (n-1)]. *)
Ltac do_n_times n t :=
  match n with
  | O => idtac
  | (S ?n') =>
    t 0;
    do_n_times n' ltac:(fun i => let next := constr:(S i) in t next)
  end.
(*
Eval cbn in ltac:(do_n_times 42 ltac:(fun a => idtac a)).
*)

(* This similiar tactical executes [t Fin0], ..., [t Fin_(n-1)]. *)
Ltac do_n_times_fin_rect n m t :=
  once lazymatch n with
  | O => idtac
  | S ?n' =>
    let m' := eval hnf in (pred m) in
    let one := eval cbv in (@Fin.F1 _ : Fin.t m) in
    t one;
    do_n_times_fin_rect n' m' ltac:(fun i => let next := eval hnf in (Fin.FS i) in t next)
  end.

Ltac do_n_times_fin n t := do_n_times_fin_rect n n t.

(*
Eval cbn in ltac:(do_n_times_fin 3 ltac:(fun a => idtac a)).
Eval cbn in ltac:(do_n_times_fin 3 ltac:(fun a => let x := eval simpl in (a : Fin.t 3) in idtac x)).
*)

(* Check whether a vector (syntactically) contains an element *)
Ltac vector_contains a vect :=
  once lazymatch vect with
  | @Vector.nil ?A => fail "Vector doesn't contain" a
  | @Vector.cons ?A a ?n ?vect' => idtac
  | @Vector.cons ?A ?b ?n ?vect' => vector_contains a vect'
  | _ => fail "No vector" vect
  end.

(* Fail Check ltac:(vector_contains 42 (@Vector.nil nat); idtac "yes!"). *)
(* Check ltac:(vector_contains 42 [|4;8;15;16;23;42|]; idtac "yes!"). *)

(*
 * The tactic [simpl_not_in_vector] tries to specialise hypothesises of the form
 * [H : forall i : Fin.t n, not_index [F1; ...; Fk] i -> _]
 * with [i := Fin0], ..., [i := Fin(n-1)] to new assumptions [H_0].
 *)

Lemma splitAllFin k' n (P : Fin.t (k'+n) -> Prop):
  (forall i, P i) -> (forall (i : Fin.t k'), P (Fin.L n i)) /\ (forall (i : Fin.t n), P (Fin.R k' i)).
Proof.
  easy.
Qed.

Fixpoint not_indexb {n} (v : list (Fin.t n)) (i : Fin.t n) {struct v}: bool :=
match v with
  []%list => true
| (i'::v)%list => if Fin.eqb i' i then false else not_indexb v i
end.

Lemma not_index_reflect n m (v : Vector.t _ m) (i : Fin.t n):
  not_index v i <-> not_indexb (Vector.to_list v) i = true.
Proof.
  unfold Vector.to_list. induction v;cbn. easy.
  specialize (Fin.eqb_eq _ h i) as H'.
  destruct Fin.eqb. { destruct H' as [->]. 2:easy. split. 2:easy. destruct 1. constructor. }
  rewrite <- IHv. cbv;intuition. apply H3. now constructor. apply H3.
  inversion H4;subst. now specialize (H2 eq_refl). apply Eqdep_dec.inj_pair2_eq_dec in H8;subst. easy.
  decide equality.
Qed.

Arguments not_indexb : simpl nomatch.

Lemma not_index_reflect_helper n m (v : Vector.t _ m) (P : Fin.t n -> Prop):
(forall i : Fin.t n, not_index v i  -> P i)
-> (forall i : Fin.t n, if not_indexb (Vector.to_list v) i then P i else True).
Proof.
  intros H i. specialize (H i). setoid_rewrite not_index_reflect in H. destruct not_indexb;now eauto.
Qed.

Lemma not_index_reflect_helper2 n' (l : list _) (P : Fin.t n' -> Prop):
(forall i : Fin.t n', if not_indexb l i then P i else True)
-> (forall i : Fin.t n', not_index (Vector.of_list l) i  -> P i).
Proof.
  intros H i. specialize (H i). setoid_rewrite not_index_reflect.
  rewrite VectorSpec.to_list_of_list_opp. destruct not_indexb;now eauto.
Qed.

Local Definition _Flag_DisableWarning := Lock unit.

Local Definition _flag_DisableWarning : _Flag_DisableWarning := tt.

Ltac simpl_not_in_vector_one :=
  let moveCnstLeft :=
    let rec loop k n :=
      lazymatch n with
        S ?n => loop uconstr:(S k) n
      | _ => uconstr:(k + n)
      end
    in loop 0
    in
  once lazymatch goal with
  | [ H : forall i : Fin.t ?n, not_index ?vect i -> _ |- _ ] =>
    specialize (not_index_reflect_helper H);clear H;intros H;
    let n' := moveCnstLeft n in
    change n with n' in H at 1;
    let tmp := fresh "tmp" in
    apply splitAllFin in H as [tmp H];
    cbn [not_indexb Vector.to_list Fin.R Vector.caseS Fin.eqb Vector.nth] in H;
    let helper i :=
      let H' := fresh H "_0" in
      assert (H':= tmp i);
      cbn in H';
      once lazymatch type of H' with
        | if (if Nat.eqb ?k ?k then false else true) then _ else True =>
        fail 1000 "arguments for not_indexb should have been set to [simpl nomatch]";clear H'
        | if not_indexb (?i::_)%list ?i then _ else True => clear H'
        | ?i = ?j => idtac
        | True => clear H'
        | ?G => idtac "simpl_not_in_vector_one is not intended for this kind of non-ground tape index" G
      end
    in
    once lazymatch type of tmp with
      forall i : Fin.t ?n, _ =>
        do_n_times_fin n helper;clear tmp
    end;
    match type of H with
    | forall i : Fin.t 0, _ => clear H
    | forall u, if _ then _ else _ =>
          specialize (not_index_reflect_helper2 H);clear H;intros H;cbn [Vector.of_list] in H
    | forall i : Fin.t _, _[@ _] = _[@ _] => idtac
    | ?t => match goal with
            | H : _Flag_DisableWarning |- _ => idtac
            | |- _ =>  idtac "unexpected case in simpl_not_in_vector_one" t
            end
    end
  end.

Ltac simpl_not_in_vector := repeat simpl_not_in_vector_one.

(* (* Test *) *)
(* Goal True. *)
(*   assert (forall i : Fin.t 10, not_index [|Fin8; Fin1; Fin2; Fin3|] i -> i = i) as HInj by firstorder. *)
(*   simpl_not_in_vector_one. *)
(*   Fail Check HInj. *)
(*   Show Proof. *)
(*   Check (HInj_0 : Fin0 = Fin0). *)
(*   Check (HInj_1 : Fin4 = Fin4). *)
(*   Check (HInj_2 : Fin5 = Fin5). *)
(*   Check (HInj_3 : Fin6 = Fin6). *)
(*   Check (HInj_4 : Fin7 = Fin7). *)
(*   Check (HInj_5 : Fin9 = Fin9). *)
(* Abort. *)

Ltac simpl_not_in := repeat simpl_not_in_vector.


From Coq Require Import ZArith.ZArith MSets.MSetPositive FSets.FMapPositive
     Strings.String Strings.Ascii Bool.Bool Lists.List Strings.HexString.
From Crypto.Util Require Import
     ListUtil
     Strings.String Strings.Decimal Strings.Show
     ZRange.Operations ZRange.Show
     OptionList Bool.Equality.
Require Import Crypto.Util.Option.

Require Import Crypto.Util.ZRange.

From Crypto Require Import IR Stringification.Language AbstractInterpretation.ZRange.

Import ListNotations.

Local Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope zrange_scope.
Local Open Scope Z_scope.

Import IR.Compilers.ToString.
Import Stringification.Language.Compilers.
Import Stringification.Language.Compilers.Options.
Import Stringification.Language.Compilers.ToString.
Import Stringification.Language.Compilers.ToString.int.Notations.

Module Zig.
  Definition comment_module_header_block := List.map (fun line => "// " ++ line)%string.
  Definition comment_block := List.map (fun line => "// " ++ line)%string.

  (* Zig natively supports any integer size between 0 and 4096 bits.
     So, we never need to define our own types. *)
  Definition int_type_to_string_opt_typedef {skip_typedefs : skip_typedefs_opt} {language_naming_conventions : language_naming_conventions_opt} (typedef_private : bool) (prefix : string) (t : ToString.int.type) (typedef : option string) : string :=
    match (if skip_typedefs then None else typedef) with
    | None => (if int.is_unsigned t then "u" else "i") ++ Decimal.Z.to_string (ToString.int.bitwidth_of t)
    | Some typedef => format_typedef_name prefix typedef_private typedef
    end.
  Definition int_type_to_string {language_naming_conventions : language_naming_conventions_opt} (t : ToString.int.type) : string :=
    int_type_to_string_opt_typedef (skip_typedefs:=true) false "" t None.

  Definition primitive_type_to_string_opt_typedef
             {language_naming_conventions : language_naming_conventions_opt} {skip_typedefs : skip_typedefs_opt}
             (all_private : bool)
             (prefix : string) (t : IR.type.primitive)
             (r : option ToString.int.type) (typedef : option string) : string :=
    match t with
    | IR.type.Zptr => "*"
    | IR.type.Z => ""
    end ++ match r with
           | Some int_t => int_type_to_string_opt_typedef all_private prefix int_t typedef
           | None => "ℤ" (* blackboard bold Z for unbounded integers (which don't actually exist, and thus will error) *)
           end.
  Definition primitive_type_to_string {language_naming_conventions : language_naming_conventions_opt} (t : IR.type.primitive)
             (r : option ToString.int.type) : string :=
    primitive_type_to_string_opt_typedef (skip_typedefs:=true) false "" t r None.

  Definition primitive_array_type_to_string
             {language_naming_conventions : language_naming_conventions_opt} {skip_typedefs : skip_typedefs_opt}
             (all_private : bool)
             (prefix : string) (t : IR.type.primitive)
             (r : option ToString.int.type) (len : nat) (typedef : option string) : string :=
    match (if skip_typedefs then None else typedef) with
    | Some typedef => format_typedef_name prefix all_private typedef
    | None => "[" ++ Decimal.Z.to_string (Z.of_nat len) ++ "]" ++
                  primitive_type_to_string t r
    end.

  Definition make_typedef
             {language_naming_conventions : language_naming_conventions_opt}
             {documentation_options : documentation_options_opt}
             (prefix : string) (private : bool)
             (typedef : typedef_info)
    : list string
    := let '(name, (ty, array_len), description) := name_and_type_and_describe_typedef prefix private typedef in
       ((comment_block description)
          ++ [(if private then "const " else "pub const ")
                ++ name ++ " = " ++
                let ty_string := match ty with
                                 | Some ty => int_type_to_string ty
                                 | None => "ℤ" (* blackboard bold Z for unbounded integers (which don't actually exist, and thus will error) *)
                                 end in
                match array_len with
                | None (* just an integer *) => ty_string
                | Some None (* unknown array length *) => "*" ++ ty_string
                | Some (Some len) => "[" ++ Decimal.Z.to_string (Z.of_nat len) ++ "]" ++ ty_string
                end
                ++ ";"]%string)%list.

  Definition header
             {language_naming_conventions : language_naming_conventions_opt}
             {documentation_options : documentation_options_opt}
             {package_namev : package_name_opt}
             {class_namev : class_name_opt}
             {output_options : output_options_opt}
             (machine_wordsize : Z) (internal_private : bool) (private : bool) (prefix : string) (infos : ToString.ident_infos)
             (typedef_map : list typedef_info)
    : list string
    := (["";
         "const std = @import(""std"");";
         "const mode = @import(""builtin"").mode; // Checked arithmetic is disabled in non-debug modes to avoid side channels";
         "";
         "inline fn cast(comptime DestType: type, target: anytype) DestType {";
         "    @setEvalBranchQuota(10000);";
         "    if (@typeInfo(@TypeOf(target)) == .Int) {";
         "        const dest = @typeInfo(DestType).Int;";
         "        const source = @typeInfo(@TypeOf(target)).Int;";
         "        if (dest.bits < source.bits) {";
         "            return @bitCast(DestType, @truncate(std.meta.Int(source.signedness, dest.bits), target));";
         "        } else {";
         "            return @bitCast(DestType, @as(std.meta.Int(source.signedness, dest.bits), target));";
         "        }";
         "    }";
         "    return @as(DestType, target);";
         "}"]
          ++ (if skip_typedefs
              then []
              else List.flat_map
                     (fun td_name =>
                        match List.find (fun '(name, _, _, _) => (td_name =? name)%string) typedef_map with
                        | Some td_info => [""] ++ make_typedef prefix private td_info
                        | None => ["@compilerError(""Could not find typedef info for '" ++ td_name ++ "'"");"]%string
                        end%list)
                     (typedefs_used infos)))%list.

  (* Integer literal to string *)
  Definition int_literal_to_string (prefix : string) (t : IR.type.primitive) (v : BinInt.Z) : string :=
    match t with
    | IR.type.Z => HexString.of_Z v (* Zig can automatically figure out the size of integer literals *)
    | IR.type.Zptr => "@compilerError(""literal address " ++ HexString.of_Z v ++ """);"
    end.

  Import IR.Notations.

  Fixpoint arith_to_string
           {language_naming_conventions : language_naming_conventions_opt} (internal_private : bool)
           (prefix : string) {t} (e : IR.arith_expr t) : string
    := let special_name_ty name ty := ToString.format_special_function_name_ty internal_private prefix name ty in
       let special_name name bw := ToString.format_special_function_name internal_private prefix name false(*unsigned*) bw in
       match e with
       (* integer literals *)
       | (IR.literal v @@@ _) => int_literal_to_string prefix IR.type.Z v
       (* array dereference *)
       | (IR.List_nth n @@@ IR.Var _ v) => "(" ++ v ++ "[" ++ Decimal.Z.to_string (Z.of_nat n) ++ "])"
       (* (de)referencing *)
       | (IR.Addr @@@ IR.Var _ v) => "&" ++ v
       | (IR.Dereference @@@ e) => "( " ++ arith_to_string internal_private prefix e ++ ".* )"
       (* bitwise operations *)
       | (IR.Z_shiftr offset @@@ e) =>
         "(" ++ arith_to_string internal_private prefix e ++ " >> " ++ Decimal.Z.to_string offset ++ ")"
       | (IR.Z_shiftl offset @@@ e) =>
         "(" ++ arith_to_string internal_private prefix e ++ " << " ++ Decimal.Z.to_string offset ++ ")"
       | (IR.Z_land @@@ (e1, e2)) =>
         "(" ++ arith_to_string internal_private prefix e1 ++ " & " ++ arith_to_string internal_private prefix e2 ++ ")"
       | (IR.Z_lor @@@ (e1, e2)) =>
         "(" ++ arith_to_string internal_private prefix e1 ++ " | " ++ arith_to_string internal_private prefix e2 ++ ")"
       | (IR.Z_lxor @@@ (e1, e2)) =>
         "(" ++ arith_to_string internal_private prefix e1 ++ " ^ " ++ arith_to_string internal_private prefix e2 ++ ")"
       | (IR.Z_lnot _ @@@ e) => "(~" ++ arith_to_string internal_private prefix e ++ ")"
       (* arithmetic operations *)
       | (IR.Z_add @@@ (x1, x2)) =>
         "(" ++ arith_to_string internal_private prefix x1 ++ " + " ++ arith_to_string internal_private prefix x2 ++ ")"
       | (IR.Z_mul @@@ (x1, x2)) =>
         "(" ++ arith_to_string internal_private prefix x1 ++ " * " ++ arith_to_string internal_private prefix x2 ++ ")"
       | (IR.Z_sub @@@ (x1, x2)) =>
         "(" ++ arith_to_string internal_private prefix x1 ++ " - " ++ arith_to_string internal_private prefix x2 ++ ")"
       | (IR.Z_bneg @@@ e) => "(~" ++ arith_to_string internal_private prefix e ++ ")"
       | (IR.Z_mul_split lg2s @@@ args) =>
         special_name "mulx" lg2s ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_add_with_get_carry lg2s @@@ args) =>
         special_name "addcarryx" lg2s ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_sub_with_get_borrow lg2s @@@ args) =>
         special_name "subborrowx" lg2s ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_zselect ty @@@ args) =>
         special_name_ty "cmovznz" ty ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_value_barrier ty @@@ args) =>
         special_name_ty "value_barrier" ty ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_static_cast int_t @@@ e) =>
         "cast(" ++ primitive_type_to_string IR.type.Z (Some int_t) ++ ", " ++ arith_to_string internal_private prefix e ++ ")"
       | IR.Var _ v => v
       | IR.Pair A B a b => arith_to_string internal_private prefix a ++ ", " ++ arith_to_string internal_private prefix b
       | (IR.Z_add_modulo @@@ (x1, x2, x3)) => "@compilerError(""addmodulo"");"
       | (IR.List_nth _ @@@ _)
       | (IR.Addr @@@ _)
       | (IR.Z_add @@@ _)
       | (IR.Z_mul @@@ _)
       | (IR.Z_sub @@@ _)
       | (IR.Z_land @@@ _)
       | (IR.Z_lor @@@ _)
       | (IR.Z_lxor @@@ _)
       | (IR.Z_add_modulo @@@ _) => "@compilerError(""bad_arg"");"
       | IR.TT => "@compilerError(""tt"");"
       end%string%Cexpr.

  Definition stmt_to_string
             {language_naming_conventions : language_naming_conventions_opt} (internal_private : bool)
             (prefix : string) (e : IR.stmt) : string :=
    match e with
    | IR.Call val => arith_to_string internal_private prefix val ++ ";"
    | IR.Assign true t sz name val =>
      (* local non-mutable declaration with initialization *)
      "const " ++ name ++ " = " ++ arith_to_string internal_private prefix val ++ ";"
    | IR.Assign false _ sz name val =>
    (* code : name ++ " = " ++ arith_to_string internal_private prefix val ++ ";" *)
      "@compilerError(""trying to assign value to non-mutable variable"");"
    | IR.AssignZPtr name sz val =>
      name ++ ".* = " ++ arith_to_string internal_private prefix val ++ ";"
    | IR.DeclareVar t sz name =>
      "var " ++ name ++ ": " ++ primitive_type_to_string t sz ++ " = undefined;"
    | IR.Comment lines _ =>
      String.concat String.NewLine (comment_block (ToString.preprocess_comment_block lines))
    | IR.AssignNth name n val =>
      name ++ "[" ++ Decimal.Z.to_string (Z.of_nat n) ++ "] = " ++ arith_to_string internal_private prefix val ++ ";"
    end.

  Definition to_strings {language_naming_conventions : language_naming_conventions_opt} (internal_private : bool) (prefix : string) (e : IR.expr) : list string :=
    List.map (stmt_to_string internal_private prefix) e.

  Import Rewriter.Language.Language.Compilers Crypto.Language.API.Compilers IR.OfPHOAS.
  Local Notation tZ := (base.type.type_base base.type.Z).

  Inductive Mode := In | Out.

  Fixpoint to_base_arg_list {language_naming_conventions : language_naming_conventions_opt} {skip_typedefs : skip_typedefs_opt} (internal_private : bool) (all_private : bool) (prefix : string) (mode : Mode) {t} : ToString.OfPHOAS.base_var_data t -> list string :=
    match t return base_var_data t -> _ with
    | tZ =>
      let typ := match mode with In => IR.type.Z | Out => IR.type.Zptr end in
      fun '(n, is_ptr, r, typedef) => [n ++ ": " ++ primitive_type_to_string_opt_typedef all_private prefix typ r typedef]
    | base.type.prod A B =>
      fun '(va, vb) => (to_base_arg_list internal_private all_private prefix mode va ++ to_base_arg_list internal_private all_private prefix mode vb)%list
    | base.type.list tZ =>
      fun '(n, r, len, typedef) =>
        let modifier := match mode with
                        | In => (* arrays for inputs are immutable *) ""
                        | Out => (* arrays for outputs are mutable *) "*"
                        end in
        [ n ++ ": " ++ modifier ++ primitive_array_type_to_string all_private prefix IR.type.Z r len typedef ]
    | base.type.list _ => fun _ => ["@compilerError(""complex list"");"]
    | base.type.option _ => fun _ => ["@compilerError(""option"");"]
    | base.type.unit => fun _ => ["@compilerError(""unit"");"]
    | base.type.type_base t => fun _ => ["@compilerError(""" ++ show t ++ """);"]%string
    end%string.

  Definition to_arg_list {language_naming_conventions : language_naming_conventions_opt} {skip_typedefs : skip_typedefs_opt} (internal_private : bool) (all_private : bool) (prefix : string) (mode : Mode) {t} : var_data t -> list string :=
    match t return var_data t -> _ with
    | type.base t => to_base_arg_list internal_private all_private prefix mode
    | type.arrow _ _ => fun _ => ["@compilerError(""arrow"");"]
    end%string.

  Fixpoint to_arg_list_for_each_lhs_of_arrow {language_naming_conventions : language_naming_conventions_opt} {skip_typedefs : skip_typedefs_opt} (internal_private : bool) (all_private : bool) (prefix : string) {t} : type.for_each_lhs_of_arrow var_data t -> list string
    := match t return type.for_each_lhs_of_arrow var_data t -> _ with
       | type.base t => fun _ => nil
       | type.arrow s d
         => fun '(x, xs)
            => to_arg_list internal_private all_private prefix In x ++ to_arg_list_for_each_lhs_of_arrow internal_private all_private prefix xs
       end%list.

  (** * Language-specific numeric conversions to be passed to the PHOAS -> IR translation *)

  Definition Zig_bin_op_natural_output
    : IR.Z_binop -> ToString.int.type * ToString.int.type -> ToString.int.type
    := fun idc '(t1, t2)
       => ToString.int.union t1 t2.

  Definition Zig_bin_op_casts
    : IR.Z_binop -> option ToString.int.type -> ToString.int.type * ToString.int.type -> option ToString.int.type * (option ToString.int.type * option ToString.int.type)
    := fun idc desired_type '(t1, t2)
       => match desired_type with
          | Some desired_type
            => let ct := ToString.int.union t1 t2 in
               let desired_type' := Some (ToString.int.union ct desired_type) in
               (Some desired_type,
                (get_Zcast_up_if_needed desired_type' (Some t1),
                 get_Zcast_up_if_needed desired_type' (Some t2)))
          | None => (None, (None, None))
          end.

  Definition Zig_un_op_casts
    : IR.Z_unop -> option ToString.int.type -> ToString.int.type -> option ToString.int.type * option ToString.int.type
    := fun idc desired_type t
       => match idc with
          | IR.Z_shiftr offset
            =>
            let t' := ToString.int.union_zrange r[0~>2^offset]%zrange t in
            ((** We cast the result down to the specified type, if needed *)
              get_Zcast_down_if_needed desired_type (Some t'),
              (** We cast the argument up to a large enough type *)
              get_Zcast_up_if_needed (Some t') (Some t))
          | IR.Z_shiftl offset
            =>
            let rpre_out := match desired_type with
                            | Some rout => Some (ToString.int.union_zrange r[0~>2^offset] (ToString.int.unsigned_counterpart_of rout))
                            | None => Some (ToString.int.of_zrange_relaxed r[0~>2^offset]%zrange)
                            end in
            ((** We cast the result down to the specified type, if needed *)
              get_Zcast_down_if_needed desired_type rpre_out,
              (** We cast the argument up to a large enough type *)
              get_Zcast_up_if_needed rpre_out (Some t))
          | IR.Z_lnot ty
            => (
              get_Zcast_down_if_needed desired_type (Some ty),
              (** always cast to the width of the type, unless we are already exactly that type (which the machinery in IR handles *)
              Some ty)
          | IR.Z_value_barrier ty
            => (
              get_Zcast_down_if_needed desired_type (Some ty),
              (** always cast to the width of the type, unless we are already exactly that type (which the machinery in IR handles *)
              Some ty)
          | IR.Z_bneg
            => ((* bneg is !, i.e., takes the argument to 1 if its not zero, and to zero if it is zero; so we don't ever need to cast *)
              None, None)
          end.

  Local Instance ZigLanguageCasts : LanguageCasts :=
    {| bin_op_natural_output := Zig_bin_op_natural_output
       ; bin_op_casts := Zig_bin_op_casts
       ; un_op_casts := Zig_un_op_casts
       ; upcast_on_assignment := true
       ; upcast_on_funcall := true
       ; explicit_pointer_variables := false
    |}.

  Definition to_function_lines {language_naming_conventions : language_naming_conventions_opt} {skip_typedefs : skip_typedefs_opt} (internal_private : bool) (private : bool) (all_private : bool) (inline : bool) (prefix : string) (name : string)
             {t}
             (f : type.for_each_lhs_of_arrow var_data t * var_data (type.base (type.final_codomain t)) * IR.expr)
    : list string :=
    let '(args, rets, body) := f in
    ((if private || inline then "inline fn " else "pub fn ") ++ name ++
      "(" ++ String.concat ", " (to_arg_list internal_private all_private prefix Out rets ++ to_arg_list_for_each_lhs_of_arrow internal_private all_private prefix args) ++
      ") void {")%string :: (["    @setRuntimeSafety(mode == .Debug);"; ""]%string)%list ++ (List.map (fun s => "    " ++ s)%string (to_strings internal_private prefix body)) ++ ["}"%string]%list.

  (** In Zig, there is no munging of return arguments (they remain
      passed by pointers), so all variables are live *)
  Local Instance : consider_retargs_live_opt := fun _ _ _ => true.
  Local Instance : rename_dead_opt := fun s => s.
  (** No need to lift declarations to the top *)
  Local Instance : lift_declarations_opt := false.

  Definition ToFunctionLines
             {absint_opts : AbstractInterpretation.Options}
             {relax_zrange : relax_zrange_opt}
             {language_naming_conventions : language_naming_conventions_opt}
             {documentation_options : documentation_options_opt}
             {output_options : output_options_opt}
             (machine_wordsize : Z)
             (do_bounds_check : bool) (internal_private : bool) (private : bool) (all_private : bool) (inline : bool) (prefix : string) (name : string)
             {t}
             (e : API.Expr t)
             (comment : type.for_each_lhs_of_arrow var_data t -> var_data (type.base (type.final_codomain t)) -> list string)
             (name_list : option (list string))
             (inbounds : type.for_each_lhs_of_arrow Compilers.ZRange.type.option.interp t)
             (outbounds : Compilers.ZRange.type.base.option.interp (type.final_codomain t))
             (intypedefs : type.for_each_lhs_of_arrow var_typedef_data t)
             (outtypedefs : base_var_typedef_data (type.final_codomain t))
    : (list string * ToString.ident_infos) + string :=
    match ExprOfPHOAS do_bounds_check e name_list inbounds intypedefs outtypedefs with
    | inl (indata, outdata, f) =>
      inl (((List.map (fun s => if (String.length s =? 0)%nat then "///" else ("/// " ++ s))%string (comment indata outdata))
              ++ match input_bounds_to_string indata inbounds with
                 | nil => nil
                 | ls => ["/// Input Bounds:"] ++ List.map (fun v => "///   " ++ v)%string ls
                 end
              ++ match bound_to_string outdata outbounds with
                 | nil => nil
                 | ls => ["/// Output Bounds:"] ++ List.map (fun v => "///   " ++ v)%string ls
                 end
              ++ to_function_lines internal_private private all_private inline prefix name (indata, outdata, f))%list%string,
           IR.ident_infos.collect_all_infos f intypedefs outtypedefs)
    | inr nil =>
      inr ("Unknown internal error in converting " ++ name ++ " to Zig")%string
    | inr [err] =>
      inr ("Error in converting " ++ name ++ " to Zig:" ++ String.NewLine ++ err)%string
    | inr errs =>
      inr ("Errors in converting " ++ name ++ " to Zig:" ++ String.NewLine ++ String.concat String.NewLine errs)%string
    end.

  Definition OutputZigAPI : ToString.OutputLanguageAPI :=
    {| ToString.comment_block := comment_block;
       ToString.comment_file_header_block := comment_module_header_block;
       ToString.ToFunctionLines := @ToFunctionLines;
       ToString.header := @header;
       ToString.footer := fun _ _ _ _ _ _ _ _ _ => [];
       ToString.strip_special_infos machine_wordsize infos := infos |}.

End Zig.


From iris.algebra Require Import auth excl gmap.
From iris.base_logic.lib Require Import own invariants gen_heap.
From iris.proofmode Require Import proofmode.
From iris.prelude Require Import options.

(** An "invariant" location is a location that has some invariant about its
value attached to it, and that can never be deallocated explicitly by the
program.  It provides a persistent witness that will always allow reading the
location, guaranteeing that the value read will satisfy the invariant.

This is useful for data structures like RDCSS that need to read locations long
after their ownership has been passed back to the client, but do not care *what*
it is that they are reading in that case. In that extreme case, the invariant
may just be [True].

Since invariant locations cannot be deallocated, they only make sense when
modeling languages with garbage collection.  HeapLang can be used to model
either language by choosing whether or not to use the [Free] operation.  By
using a separate assertion [inv_mapsto_own] for "invariant" locations, we can
keep all the other proofs that do not need it conservative.  *)

Definition inv_heapN: namespace := nroot .@ "inv_heap".
Local Notation "l ↦ v" := (mapsto l (DfracOwn 1) v) (at level 20) : bi_scope.

Definition inv_heap_mapUR (L V : Type) `{Countable L} : ucmra := gmapUR L $ prodR
  (optionR $ exclR $ leibnizO V)
  (agreeR (V -d> PropO)).

Definition to_inv_heap {L V : Type} `{Countable L}
    (h: gmap L (V * (V -d> PropO))) : inv_heap_mapUR L V :=
  prod_map (λ x, Excl' x) to_agree <$> h.

Class inv_heapGpreS (L V : Type) (Σ : gFunctors) `{Countable L} := {
  inv_heapGpreS_inG : inG Σ (authR (inv_heap_mapUR L V))
}.
Local Existing Instance inv_heapGpreS_inG.

Class inv_heapGS (L V : Type) (Σ : gFunctors) `{Countable L} := Inv_HeapG {
  inv_heap_inG : inv_heapGpreS L V Σ;
  inv_heap_name : gname
}.
Local Existing Instance inv_heap_inG.
Global Arguments Inv_HeapG _ _ {_ _ _ _}.
Global Arguments inv_heap_name {_ _ _ _ _} _ : assert.

Definition inv_heapΣ (L V : Type) `{Countable L} : gFunctors :=
  #[ GFunctor (authR (inv_heap_mapUR L V)) ].

Global Instance subG_inv_heapGpreS (L V : Type) `{Countable L} {Σ} :
  subG (inv_heapΣ L V) Σ → inv_heapGpreS L V Σ.
Proof. solve_inG. Qed.

Section definitions.
  Context {L V : Type} `{Countable L}.
  Context `{!invGS_gen hlc Σ, !gen_heapGS L V Σ, gG: !inv_heapGS L V Σ}.

  Definition inv_heap_inv_P : iProp Σ :=
    ∃ h : gmap L (V * (V -d> PropO)),
       own (inv_heap_name gG) (● to_inv_heap h) ∗
       [∗ map] l ↦ p ∈ h, ⌜p.2 p.1⌝ ∗ l ↦ p.1.

  Definition inv_heap_inv : iProp Σ := inv inv_heapN inv_heap_inv_P.

  Definition inv_mapsto_own (l : L) (v : V) (I : V → Prop) : iProp Σ :=
    own (inv_heap_name gG) (◯ {[l := (Excl' v, to_agree I) ]}).

  Definition inv_mapsto (l : L) (I : V → Prop) : iProp Σ :=
    own (inv_heap_name gG) (◯ {[l := (None, to_agree I)]}).

End definitions.

Local Notation "l '↦_' I v" := (inv_mapsto_own l v I%stdpp%type)
  (at level 20, I at level 9, format "l  '↦_' I  v") : bi_scope.

Local Notation "l '↦_' I □" := (inv_mapsto l I%stdpp%type)
  (at level 20, I at level 9, format "l  '↦_' I  '□'") : bi_scope.

(* [inv_heap_inv] has no parameters to infer the types from, so we need to
   make them explicit. *)
Global Arguments inv_heap_inv _ _ {_ _ _ _ _ _ _}.

Global Instance: Params (@inv_mapsto_own) 8 := {}.
Global Instance: Params (@inv_mapsto) 7 := {}.

Section to_inv_heap.
  Context {L V : Type} `{Countable L}.
  Implicit Types (h : gmap L (V * (V -d> PropO))).

  Lemma to_inv_heap_valid h : ✓ to_inv_heap h.
  Proof. intros l. rewrite lookup_fmap. by case (h !! l). Qed.

  Lemma to_inv_heap_singleton l v I :
    to_inv_heap {[l := (v, I)]} =@{inv_heap_mapUR L V} {[l := (Excl' v, to_agree I)]}.
  Proof. by rewrite /to_inv_heap fmap_insert fmap_empty. Qed.

  Lemma to_inv_heap_insert l v I h :
    to_inv_heap (<[l := (v, I)]> h) = <[l := (Excl' v, to_agree I)]> (to_inv_heap h).
  Proof. by rewrite /to_inv_heap fmap_insert. Qed.

  Lemma lookup_to_inv_heap_None h l :
    h !! l = None → to_inv_heap h !! l = None.
  Proof. by rewrite /to_inv_heap lookup_fmap=> ->. Qed.

  Lemma lookup_to_inv_heap_Some h l v I :
    h !! l = Some (v, I) → to_inv_heap h !! l = Some (Excl' v, to_agree I).
  Proof. by rewrite /to_inv_heap lookup_fmap=> ->. Qed.

  Lemma lookup_to_inv_heap_Some_2 h l v' I' :
    to_inv_heap h !! l ≡ Some (v', I') →
    ∃ v I, v' = Excl' v ∧ I' ≡ to_agree I ∧ h !! l = Some (v, I).
  Proof.
    rewrite /to_inv_heap /prod_map lookup_fmap. rewrite fmap_Some_equiv.
    intros ([] & Hsome & [Heqv HeqI]); simplify_eq/=; eauto.
  Qed.
End to_inv_heap.

Lemma inv_heap_init (L V : Type) `{Countable L, !invGS_gen hlc Σ, !gen_heapGS L V Σ, !inv_heapGpreS L V Σ} E :
  ⊢ |==> ∃ _ : inv_heapGS L V Σ, |={E}=> inv_heap_inv L V.
Proof.
  iMod (own_alloc (● (to_inv_heap ∅))) as (γ) "H●".
  { rewrite auth_auth_valid. exact: to_inv_heap_valid. }
  iModIntro.
  iExists (Inv_HeapG L V γ).
  iAssert (inv_heap_inv_P (gG := Inv_HeapG L V γ)) with "[H●]" as "P".
  { iExists _. iFrame. done. }
  iApply (inv_alloc inv_heapN E inv_heap_inv_P with "P").
Qed.

Section inv_heap.
  Context {L V : Type} `{Countable L}.
  Context `{!invGS_gen hlc Σ, !gen_heapGS L V Σ, gG: !inv_heapGS L V Σ}.
  Implicit Types (l : L) (v : V) (I : V → Prop).
  Implicit Types (h : gmap L (V * (V -d> PropO))).

  (** * Helpers *)

  Lemma inv_mapsto_lookup_Some l h I :
    l ↦_I □ -∗ own (inv_heap_name gG) (● to_inv_heap h) -∗
    ⌜∃ v I', h !! l = Some (v, I') ∧ ∀ w, I w ↔ I' w ⌝.
  Proof.
    iIntros "Hl_inv H◯".
    iCombine "H◯ Hl_inv" gives %[Hincl Hvalid]%auth_both_valid_discrete.
    iPureIntro.
    move: Hincl; rewrite singleton_included_l; intros ([v' I'] & Hsome & Hincl).
    apply lookup_to_inv_heap_Some_2 in Hsome as (v'' & I'' & _ & HI & Hh).
    move: Hincl; rewrite HI Some_included_total pair_included
      to_agree_included; intros [??]; eauto.
  Qed.

  Lemma inv_mapsto_own_lookup_Some l v h I :
    l ↦_I v -∗ own (inv_heap_name gG) (● to_inv_heap h) -∗
    ⌜ ∃ I', h !! l = Some (v, I') ∧ ∀ w, I w ↔ I' w ⌝.
  Proof.
    iIntros "Hl_inv H●".
    iCombine "H● Hl_inv" gives %[Hincl Hvalid]%auth_both_valid_discrete.
    iPureIntro.
    move: Hincl; rewrite singleton_included_l; intros ([v' I'] & Hsome & Hincl).
    apply lookup_to_inv_heap_Some_2 in Hsome as (v'' & I'' & -> & HI & Hh).
    move: Hincl; rewrite HI Some_included_total pair_included
      Excl_included to_agree_included; intros [-> ?]; eauto.
  Qed.

  (** * Typeclass instances *)

  (* FIXME(Coq #6294): needs new unification
  The uses of [apply:] and [move: ..; rewrite ..] (by lack of [apply: .. in ..])
  in this file are needed because Coq's default unification algorithm fails. *)
  Global Instance inv_mapsto_own_proper l v :
    Proper (pointwise_relation _ iff ==> (≡)) (inv_mapsto_own l v).
  Proof.
    intros I1 I2 ?. rewrite /inv_mapsto_own. do 2 f_equiv.
    apply: singletonM_proper. f_equiv. by apply: to_agree_proper.
  Qed.
  Global Instance inv_mapsto_proper l :
    Proper (pointwise_relation _ iff ==> (≡)) (inv_mapsto l).
  Proof.
    intros I1 I2 ?. rewrite /inv_mapsto. do 2 f_equiv.
    apply: singletonM_proper. f_equiv. by apply: to_agree_proper.
  Qed.

  Global Instance inv_heap_inv_persistent : Persistent (inv_heap_inv L V).
  Proof. apply _. Qed.

  Global Instance inv_mapsto_persistent l I : Persistent (l ↦_I □).
  Proof. apply _. Qed.

  Global Instance inv_mapsto_timeless l I : Timeless (l ↦_I □).
  Proof. apply _. Qed.

  Global Instance inv_mapsto_own_timeless l v I : Timeless (l ↦_I v).
  Proof. apply _. Qed.

  (** * Public lemmas *)

  Lemma make_inv_mapsto l v I E :
    ↑inv_heapN ⊆ E →
    I v →
    inv_heap_inv L V -∗ l ↦ v ={E}=∗ l ↦_I v.
  Proof.
    iIntros (HN HI) "#Hinv Hl".
    iMod (inv_acc_timeless _ inv_heapN with "Hinv") as "[HP Hclose]"; first done.
    iDestruct "HP" as (h) "[H● HsepM]".
    destruct (h !! l) as [v'| ] eqn: Hlookup.
    - (* auth map contains l --> contradiction *)
      iDestruct (big_sepM_lookup with "HsepM") as "[_ Hl']"; first done.
      by iCombine "Hl Hl'" gives %[??].
    - iMod (own_update with "H●") as "[H● H◯]".
      { apply lookup_to_inv_heap_None in Hlookup.
        apply (auth_update_alloc _
          (to_inv_heap (<[l:=(v,I)]> h)) (to_inv_heap ({[l:=(v,I)]}))).
        rewrite to_inv_heap_insert to_inv_heap_singleton.
        by apply: alloc_singleton_local_update. }
      iMod ("Hclose" with "[H● HsepM Hl]").
      + iExists _.
        iDestruct (big_sepM_insert _ _ _ (_,_) with "[$HsepM $Hl]")
          as "HsepM"; auto with iFrame.
      + iModIntro. by rewrite /inv_mapsto_own to_inv_heap_singleton.
  Qed.

  Lemma inv_mapsto_own_inv l v I : l ↦_I v -∗ l ↦_I □.
  Proof.
    apply own_mono, auth_frag_mono. rewrite singleton_included pair_included.
    right. split; [apply: ucmra_unit_least|done].
  Qed.

  (** An accessor to make use of [inv_mapsto_own].
    This opens the invariant *before* consuming [inv_mapsto_own] so that you can use
    this before opening an atomic update that provides [inv_mapsto_own]!. *)
  Lemma inv_mapsto_own_acc_strong E :
    ↑inv_heapN ⊆ E →
    inv_heap_inv L V ={E, E ∖ ↑inv_heapN}=∗ ∀ l v I, l ↦_I v -∗
      (⌜I v⌝ ∗ l ↦ v ∗ (∀ w, ⌜I w ⌝ -∗ l ↦ w ==∗
        inv_mapsto_own l w I ∗ |={E ∖ ↑inv_heapN, E}=> True)).
  Proof.
    iIntros (HN) "#Hinv".
    iMod (inv_acc_timeless _ inv_heapN _ with "Hinv") as "[HP Hclose]"; first done.
    iIntros "!>" (l v I) "Hl_inv".
    iDestruct "HP" as (h) "[H● HsepM]".
    iDestruct (inv_mapsto_own_lookup_Some with "Hl_inv H●") as %(I'&?&HI').
    setoid_rewrite HI'.
    iDestruct (big_sepM_delete with "HsepM") as "[[HI Hl] HsepM]"; first done.
    iIntros "{$HI $Hl}" (w ?) "Hl".
    iMod (own_update_2 with "H● Hl_inv") as "[H● H◯]".
    { apply (auth_update _ _ (<[l := (Excl' w, to_agree I')]> (to_inv_heap h))
             {[l := (Excl' w, to_agree I)]}).
      apply: singleton_local_update.
      { by apply lookup_to_inv_heap_Some. }
      apply: prod_local_update_1. apply: option_local_update.
      apply: exclusive_local_update. done. }
    iDestruct (big_sepM_insert _ _ _ (w, I') with "[$HsepM $Hl //]") as "HsepM".
    { apply lookup_delete. }
    rewrite insert_delete_insert -to_inv_heap_insert. iIntros "!> {$H◯}".
    iApply ("Hclose" with "[H● HsepM]"). iExists _; by iFrame.
  Qed.

  (** Derive a more standard accessor. *)
  Lemma inv_mapsto_own_acc E l v I:
    ↑inv_heapN ⊆ E →
    inv_heap_inv L V -∗ l ↦_I v ={E, E ∖ ↑inv_heapN}=∗
      (⌜I v⌝ ∗ l ↦ v ∗ (∀ w, ⌜I w ⌝ -∗ l ↦ w ={E ∖ ↑inv_heapN, E}=∗ l ↦_I w)).
  Proof.
    iIntros (?) "#Hinv Hl".
    iMod (inv_mapsto_own_acc_strong with "Hinv") as "Hacc"; first done.
    iDestruct ("Hacc" with "Hl") as "(HI & Hl & Hclose)".
    iIntros "!> {$HI $Hl}" (w) "HI Hl".
    iMod ("Hclose" with "HI Hl") as "[$ $]".
  Qed.

  Lemma inv_mapsto_acc l I E :
    ↑inv_heapN ⊆ E →
    inv_heap_inv L V -∗ l ↦_I □ ={E, E ∖ ↑inv_heapN}=∗
    ∃ v, ⌜I v⌝ ∗ l ↦ v ∗ (l ↦ v ={E ∖ ↑inv_heapN, E}=∗ ⌜True⌝).
  Proof.
    iIntros (HN) "#Hinv Hl_inv".
    iMod (inv_acc_timeless _ inv_heapN _ with "Hinv") as "[HP Hclose]"; first done.
    iModIntro.
    iDestruct "HP" as (h) "[H● HsepM]".
    iDestruct (inv_mapsto_lookup_Some with "Hl_inv H●") as %(v&I'&?&HI').
    iDestruct (big_sepM_lookup_acc with "HsepM") as "[[#HI Hl] HsepM]"; first done.
    setoid_rewrite HI'.
    iExists _. iIntros "{$HI $Hl} Hl".
    iMod ("Hclose" with "[H● HsepM Hl]"); last done.
    iExists _. iFrame "H●". iApply ("HsepM" with "[$Hl //]").
  Qed.

End inv_heap.

Typeclasses Opaque inv_heap_inv inv_mapsto inv_mapsto_own.


Require Import Bedrock PreAutoSep Sys.
Import XCAP.

Definition goodSize' (n : nat) := (N.of_nat n < 1 + Npow2 32)%N.

Lemma wordToNat_ninj : forall sz (u v : word sz),
  u <> v
  -> wordToNat u <> wordToNat v.
  intros; intro; apply H.
  assert (natToWord sz (wordToNat u) = natToWord sz (wordToNat v)) by congruence.
  repeat rewrite natToWord_wordToNat in H1.
  assumption.
Qed.

Lemma get_memoryIn' : forall m w init,
  (wordToNat w < init)%nat
  -> goodSize' init
  -> smem_get' (allWordsUpto 32 init) w (memoryIn' m _) = m w.
  induction init; simpl; intuition.
  destruct (H.addr_dec $(init) w).
  unfold H.mem_get, ReadByte.
  congruence.
  apply IHinit.
  apply wordToNat_ninj in n.
  rewrite wordToNat_natToWord_idempotent in n.
  omega.
  generalize H0; clear.
  unfold goodSize'.
  generalize (Npow2 32); intros.
  apply Nlt_out in H0.
  rewrite N2Nat.inj_add in H0.
  autorewrite with N in *.
  pre_nomega.
  simpl in *.
  omega.
  generalize H0; clear.
  unfold goodSize'.
  generalize (Npow2 32).
  intros.
  nomega.
Qed.

Lemma pow2_N : forall n,
  N.of_nat (pow2 n) = Npow2 n.
  intros.
  assert (N.to_nat (N.of_nat (pow2 n)) = N.to_nat (Npow2 n)).
  autorewrite with N.
  symmetry; apply Npow2_nat.
  assert (N.of_nat (N.to_nat (N.of_nat (pow2 n))) = N.of_nat (N.to_nat (Npow2 n))) by congruence.
  autorewrite with N in *.
  assumption.
Qed.

Lemma get_memoryIn : forall m w,
  smem_get w (memoryIn m) = m w.
  intros.
  unfold smem_get, memoryIn, HT.memoryIn, H.all_addr.
  rewrite allWords_eq.
  apply get_memoryIn'.
  apply wordToNat_bound.
  hnf.
  rewrite pow2_N.
  reflexivity.
Qed.

Require Import DepList.

Fixpoint smem_put ls (sm : smem' ls) (w : W) (v : B) : smem' ls :=
  match sm with
    | HNil => HNil
    | HCons w' _ v' sm' =>
      HCons (if H.addr_dec w w' then Some v else v') (smem_put _ sm' w v)
  end.

Fixpoint smem_clear ls (sm : smem' ls) (w : W) : smem' ls :=
  match sm with
    | HNil => HNil
    | HCons w' _ v sm' =>
      HCons (if H.addr_dec w w' then None else v) (smem_clear _ sm' w)
  end.

Fixpoint smem_graft (sm sm' : smem) (p : W) (len : nat) : smem :=
  match len with
    | O => sm
    | S len' =>
      match smem_get p sm' with
        | None => sm
        | Some v => smem_put _ (smem_graft sm sm' (p ^+ $1) len') p v
      end
  end.

Section OpSem.
  Variable m : module.
  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Definition labelSys' (l_pre : string * spec) :=
    (Global (fst l_pre), Precondition (snd l_pre) None).

  Definition labelSys (l : LabelMap.key) (pre : assert) :=
    fst l = "sys"
    /\ In (snd l, pre) (map labelSys' (
      ("abort", abortS)
      :: ("printInt", printIntS)
      :: ("listen", listenS)
      :: ("accept", acceptS)
      :: ("read", readS)
      :: ("write", writeS)
      :: ("declare", declareS)
      :: ("wait", waitS)
      :: ("close", closeS)
      :: nil)).

  Hypothesis impSys :
    LabelMap.fold (fun l pre P => labelSys l pre /\ P) (Imports m) True.

  Lemma preserve : forall (ls : list (LabelMap.key * assert)) Q,
    fold_left (fun P p => labelSys (fst p) (snd p) /\ P) ls Q
    -> Q.
    induction ls; simpl in *; intuition.
    apply IHls in H; tauto.
  Qed.

  Theorem impSys' : forall l pre, LabelMap.MapsTo l pre (Imports m)
    -> labelSys l pre.
    rewrite LabelMap.fold_1 in impSys; intros.
    apply LabelMap.elements_1 in H.
    generalize dependent True.
    clear impSys; induction H; simpl in *; intuition.

    hnf in H; simpl in H; intuition subst.
    apply preserve in impSys; tauto.

    eauto.
  Qed.

  Hypothesis agree : forall l pre bl, LabelMap.MapsTo l (pre, bl) (Blocks m)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (Imports m)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Hypothesis ok : moduleOk m.

  Hint Constructors reachable sys_step sys_reachable.

  Definition goodState (st : state') :=
    exists l pre, Labels stn l = Some (fst st)
      /\ interp (specs m stn) (pre (stn, snd st))
      /\ (LabelMap.MapsTo l pre (Imports m)
        \/ exists bl, LabelMap.MapsTo l (pre, bl) (Blocks m)).

  Lemma locals_mapped' : forall specs stn st vs ns sp P,
    interp specs (![array (toArray ns vs) sp * P] (stn, st))
    -> mapped sp (length ns * 4) (Mem st).
    induction ns; simpl; intuition; hnf; intuition.
    unfold array in H.
    assert (interp specs (![ptsto32m' nil sp 0 (vs a :: toArray ns vs) * P] (stn0, st))).
    eapply ILTacCommon.interp_interp_himp; eauto.
    eapply himp_star_frame; [ apply Arrays.ptsto32m'_in | reflexivity ].
    clear H.
    simpl in *.
    assert (n < 4 \/ (n >= 4 /\ n - 4 < length ns * 4))%nat by omega.
    intuition.
    rewrite sepFormula_eq in H2; propxFo.
    unfold smem_get_word, H.footprint_w in H6.
    repeat match type of H6 with
             | match ?E with None => _ | _ => _ end = _ => case_eq E; intros;
               try match goal with
                     | [ H : _ = _ |- _ ] => rewrite H in H6
                   end; try discriminate
           end.
    inversion H3; clear H3; subst.

    Lemma unsplit_smem_get' : forall a v ls m m',
      smem_get' ls a m = Some v
      -> smem_get' ls a (join' ls m m') = Some v.
      induction ls; simpl; intuition.
      destruct (H.addr_dec a0 a); subst.
      rewrite H; auto.
      eauto.
    Qed.

    Lemma unsplit_smem_get : forall a m v m0 m1,
      smem_get a m = Some v
      -> split m0 m m1
        -> smem_get a m0 = Some v.
      unfold split; intuition subst; apply unsplit_smem_get'; auto.
    Qed.

    do 2 (eapply unsplit_smem_get in H11; eauto).
    rewrite get_memoryIn in H11.
    replace (sp ^+ $0 ^+ $3) with (sp ^+ $3) in * by words.
    congruence.

    inversion H13; clear H13; subst.
    do 2 (eapply unsplit_smem_get in H10; eauto).
    rewrite get_memoryIn in H10.
    replace (sp ^+ $0 ^+ $2) with (sp ^+ $2) in * by words.
    congruence.

    inversion H12; clear H12; subst.
    do 2 (eapply unsplit_smem_get in H9; eauto).
    rewrite get_memoryIn in H9.
    replace (sp ^+ $0 ^+ $1) with (sp ^+ $1) in * by words.
    congruence.

    inversion H13; clear H13; subst.
    do 2 (eapply unsplit_smem_get in H; eauto).
    rewrite get_memoryIn in H.
    congruence.

    inversion H12.

    assert (interp specs (![array (toArray ns vs) (sp ^+ $4) * ((sp ^+ $ (0)) =*> vs a * P)] (stn0, st))).
    eapply ILTacCommon.interp_interp_himp; eauto.
    clear.

    Lemma comeOnOut : forall P Q R,
      P * Q * R ===> Q * (P * R).
      clear; sepLemma.
    Qed.

    etransitivity; [ apply comeOnOut | ].
    apply Himp_star_frame; [ | apply Himp_refl ].
    eapply Himp_trans; [ | apply ptsto32m'_out ].
    apply ptsto32m'_shift_base'; auto.

    clear H2.
    apply IHns in H3.
    hnf in H3.
    eapply H3.
    eauto.
    replace (sp ^+ $4 ^+ $(n - 4)) with (sp ^+ $(n)); auto.
    rewrite natToW_minus by auto.
    unfold natToW.
    W_eq.
  Qed.

  Lemma locals_mapped : forall specs ns vs res sp stn st P,
    interp specs (![locals ns vs res sp * P] (stn, st))
    -> mapped sp (length ns * 4) (Mem st).
    unfold locals; intros.
    assert (interp specs
      (![array (toArray ns vs) sp * ([|NoDup ns|] *
        (sp ^+ $ (Datatypes.length ns * 4)) =?> res * P)]
      (stn0, st))).
    generalize H; clear; intros; step auto_ext.
    eapply locals_mapped'; eauto.
  Qed.

  Lemma array8_mapped : forall specs stn bs p m,
    interp specs (array8 bs p stn m)
    -> forall n, (n < length bs)%nat
      -> smem_get (p ^+ $(n)) m <> None.
    induction bs; simpl; post.
    intuition.
    destruct n.
    replace (p ^+ $0) with p in H1 by words.
    eapply split_smem_get in H2; eauto.
    rewrite H1 in H2; discriminate.
    eapply IHbs in H4; try tauto.
    instantiate (1 := n); auto.
    replace (p ^+ $1 ^+ $(n)) with (p ^+ $(S n))
      by (rewrite natToW_S; unfold natToW; W_eq).
    case_eq (smem_get (p ^+ $(S n)) x0); intros; auto.
    eapply split_smem_get in H2; eauto.
    congruence.
  Qed.

  Lemma bytes_mapped : forall specs p sz stn st P,
    interp specs (![p =?>8 sz * P] (stn, st))
    -> mapped p sz (Mem st).
    unfold buffer; rewrite sepFormula_eq; post.
    hnf; intros.
    eapply split_comm in H1; eapply split_semp in H1; eauto; subst.
    eapply array8_mapped in H; eauto.
    case_eq (smem_get (p ^+ $(n)) x2); intros; try congruence.
    eapply split_smem_get in H0; eauto.
    rewrite get_memoryIn in H0.
    congruence.
  Qed.

  Lemma prove_ReadWord : forall stn m (p : W) v st,
    evalInstrs stn st (Assign Rv (LvMem p) :: nil) <> None
    -> (forall st', evalInstrs stn st (Assign Rv (LvMem p) :: nil) = Some st'
      -> Regs st' Rv = v)
    -> Mem st = m
    -> ReadWord stn m p = Some v.
    intros.
    match goal with
      | [ H : (?X <> None)%type |- _ ] => case_eq X; intros; try tauto
    end.
    Transparent evalInstrs.
    simpl in *.
    subst.
    destruct (ReadWord stn0 (Mem st) p); simpl in *; try congruence.
    injection H2; clear H2; intros; subst; auto.
    specialize (H0 _ eq_refl).
    subst; auto.
  Qed.

  Lemma evalInstrs_slot : forall stn st n,
    evalInstrs stn st (Assign Rv (LvMem (Imm (Regs st Sp ^+ $(n)))) :: nil)
    = evalInstrs stn st (Assign Rv (LvMem (Sp + $(n))%loc) :: nil).
    auto.
  Qed.

  Opaque evalInstrs.

  Lemma specs_hit : forall w pre,
    specs m stn w = Some pre
    -> exists l, Labels stn l = Some w
      /\ (LabelMap.MapsTo l pre (Imports m)
        \/ exists bl, LabelMap.MapsTo l (pre, bl) (Blocks m)).
    intros.
    apply specs_hit in H; post; eauto.
    apply specs'_hit in H0; post; eauto.
  Qed.

  Lemma smem_get'_emp : forall p ls,
    smem_get' ls p (smem_emp' ls) = None.
    induction ls; simpl; intuition.
    destruct (H.addr_dec a p); auto.
  Qed.

  Lemma smem_get_emp : forall p,
    smem_get p smem_emp = None.
    intros; apply smem_get'_emp.
  Qed.

  Lemma must_be' : forall p ls m1 m2,
    smem_get' ls p m1 = None
    -> smem_get' ls p m2 = None
    -> smem_get' ls p (join' ls m1 m2) = None.
    clear; induction ls; simpl; intuition.
    destruct (H.addr_dec a p); subst; intuition.
    rewrite H; auto.
  Qed.

  Lemma must_be : forall m m1 m2 p,
    split m m1 m2
    -> smem_get p m <> None
    -> smem_get p m1 = None
    -> smem_get p m2 <> None.
    destruct 1; intuition subst.
    unfold smem_get, join in H1.
    rewrite must_be' in H1; eauto.
  Qed.

  Lemma characterize_array8_fwd : forall specs stn bs base m m',
    interp specs (array8 bs base stn m)
    -> (forall p, (forall n, (n < length bs)%nat -> p <> base ^+ $(n))
      -> smem_get p m' = smem_get p m)
    -> (forall p, smem_get p m <> None ->
      exists n, (n < length bs)%nat /\ p = base ^+ $(n)).
    clear; induction bs; simpl; propxFo.

    hnf in H3; subst.
    rewrite smem_get_emp in H1; tauto.
    destruct (weq p base); subst.
    exists 0; intuition.
    unfold H.addr in *; W_eq.

    assert (smem_get p x0 <> None).
    eapply must_be; eauto.
    case_eq (smem_get p x0); intros; try congruence.
    clear H.
    edestruct IHbs; eauto.
    instantiate (1 := p); congruence.
    intuition subst.
    exists (S x1); intuition.
    change ($(S x1)) with (natToW (S x1)).
    rewrite (natToW_S x1).
    unfold natToW.
    unfold H.addr in *.
    W_eq.
  Qed.

  Lemma split_None : forall p m m1 m2,
    smem_get p m = None
    -> split m m1 m2
    -> smem_get p m2 = None.
    intros; case_eq (smem_get p m2); intros; auto.
    eapply split_smem_get in H0; eauto.
    congruence.
  Qed.

  Lemma split'_None' : forall p ls m1 m2,
    smem_get' ls p m1 = None
    -> smem_get' ls p m2 = smem_get' ls p (join' ls m1 m2).
    induction ls; simpl; intuition.
    destruct (H.addr_dec a p); subst; intuition.
    rewrite H; auto.
  Qed.

  Lemma split_None' : forall p m m1 m2,
    split m m1 m2
    -> smem_get p m1 = None
    -> smem_get p m2 = smem_get p m.
    destruct 1; subst; apply split'_None'.
  Qed.

  Lemma characterize_array8_bwd : forall specs stn bs base m,
    interp specs (array8 bs base stn m)
    -> (forall n, (n < length bs)%nat
      -> smem_get (base ^+ $(n)) m <> None).
    induction bs; simpl; propxFo.

    intuition.

    destruct n.
    erewrite split_smem_get in H1.
    discriminate.
    eauto.
    replace (base ^+ $0) with base by words.
    eauto.

    eapply IHbs.
    eauto.
    instantiate (1 := n); omega.
    replace (base ^+ $1 ^+ $(n)) with (base ^+ $(S n))
      by (rewrite natToW_S; unfold natToW; words).
    eauto using split_None.
  Qed.

  Lemma semp_eta' : forall ls, NoDup ls
    -> forall m,
      (forall p, In p ls -> smem_get' ls p m = None)
      -> m = smem_emp' ls.
    clear; induction 1; simpl; intuition.
    rewrite (hlist_nil_only _ m); auto.
    rewrite (hlist_eta _ m); f_equal.
    specialize (H1 x); destruct (H.addr_dec x x); tauto.
    apply IHNoDup; intros.
    specialize (H1 p); destruct (H.addr_dec x p); subst; eauto; tauto.
  Qed.

  Lemma semp_eta : forall m,
    (forall p, smem_get p m = None)
    -> semp m.
    intros; apply semp_eta'; auto.
    apply H.NoDup_all_addr.
  Qed.

  Lemma get_clear_ne' : forall a a' ls (sm : smem' ls),
    a <> a'
    -> smem_get' ls a (smem_clear _ sm a') = smem_get' ls a sm.
    induction sm; simpl; intuition.
    destruct (H.addr_dec x a); auto.
    destruct (H.addr_dec a' x); congruence.
  Qed.

  Lemma get_clear_ne : forall a a' sm,
    a <> a'
    -> smem_get a (smem_clear _ sm a') = smem_get a sm.
    intros; apply get_clear_ne'; auto.
  Qed.

  Lemma get_clear_eq' : forall a ls (sm : smem' ls),
    smem_get' ls a (smem_clear _ sm a) = None.
    induction sm; simpl; intuition.
    destruct (H.addr_dec x a); auto.
    destruct (H.addr_dec a x); congruence.
  Qed.

  Lemma get_clear_eq : forall a sm,
    smem_get a (smem_clear _ sm a) = None.
    intros; apply get_clear_eq'.
  Qed.

  Hint Rewrite get_clear_eq get_clear_ne
    using solve [ assumption | W_neq ] : get.

  Lemma get_put_eq' : forall a v ls (sm : smem' ls),
    In a ls
    -> smem_get' ls a (smem_put _ sm a v) = Some v.
    induction sm; simpl; intuition.
    subst.
    destruct (H.addr_dec a a); intuition idtac.
    destruct (H.addr_dec x a); intuition idtac.
    subst.
    destruct (H.addr_dec a a); intuition idtac.
  Qed.

  Lemma allWordsUpto_universal : forall width init w,
    (wordToNat w < init)%nat
    -> (init <= pow2 width)%nat
    -> In w (allWordsUpto width init).
    induction init; simpl; intuition.
    destruct (weq w $(init)); subst; auto; right.
    assert (wordToNat w <> init).
    intro; apply n.
    subst.
    symmetry; apply natToWord_wordToNat.
    auto.
  Qed.

  Lemma allWords_universal : forall sz w,
    In w (allWords sz).
    rewrite allWords_eq; intros; apply allWordsUpto_universal.
    apply wordToNat_bound.
    auto.
  Qed.

  Lemma get_put_eq : forall a v sm,
    smem_get a (smem_put _ sm a v) = Some v.
    intros; apply get_put_eq'.
    apply allWords_universal.
  Qed.

  Lemma get_put_ne' : forall a a' v ls (sm : smem' ls),
    a <> a'
    -> smem_get' ls a (smem_put _ sm a' v) = smem_get' ls a sm.
    induction sm; simpl; intuition.
    destruct (H.addr_dec a' x); intuition idtac.
    destruct (H.addr_dec x a); intuition idtac.
    congruence.
    destruct (H.addr_dec x a); intuition idtac.
  Qed.

  Lemma get_put_ne : forall a a' v sm,
    a <> a'
    -> smem_get a (smem_put _ sm a' v) = smem_get a sm.
    intros; apply get_put_ne'; auto.
  Qed.

  Hint Rewrite smem_get_emp get_put_eq get_put_ne
    using solve [ assumption | W_neq ] : get.

  Lemma join_None' : forall a ls sm1 sm2,
    smem_get' ls a sm1 = None
    -> smem_get' ls a (join' ls sm1 sm2) = smem_get' ls a sm2.
    induction sm1; simpl; intuition.
    destruct (H.addr_dec x a); subst; auto.
  Qed.

  Lemma join_None : forall a sm1 sm2,
    smem_get a sm1 = None
    -> smem_get a (join sm1 sm2) = smem_get a sm2.
    intros; apply join_None'; auto.
  Qed.

  Lemma join_Some' : forall a v ls sm1 sm2,
    smem_get' ls a sm1 = Some v
    -> smem_get' ls a (join' ls sm1 sm2) = Some v.
    induction sm1; simpl; intuition.
    destruct (H.addr_dec x a); subst; auto.
  Qed.

  Lemma join_Some : forall a v sm1 sm2,
    smem_get a sm1 = Some v
    -> smem_get a (join sm1 sm2) = Some v.
    intros; apply join_Some'; auto.
  Qed.

  Lemma disjoint_get' : forall ls sm1 sm2,
    NoDup ls
    -> List.Forall (fun w => smem_get' ls w sm1 <> None -> smem_get' ls w sm2 <> None -> False) ls
    -> disjoint' ls sm1 sm2.
    induction sm1; simpl; intuition; rewrite (hlist_eta _ sm2) in *; simpl in *.
    inversion H; clear H; subst.
    inversion H0; clear H0; subst.
    destruct (H.addr_dec x x); try tauto.
    destruct b; auto.
    destruct (hlist_hd sm2); auto.
    intuition discriminate.
    inversion H; clear H; subst.
    inversion H0; clear H0; subst.
    apply IHsm1; intros; auto.
    eapply Forall_weaken'; eauto.
    simpl; intros.
    destruct (H.addr_dec x x0); subst; tauto.
  Qed.

  Lemma disjoint_get : forall sm1 sm2,
    (forall w, smem_get w sm1 <> None -> smem_get w sm2 <> None -> False)
    -> disjoint sm1 sm2.
    intros; apply disjoint_get'.
    apply BedrockHeap.NoDup_all_addr.
    apply Forall_forall; intros.
    eauto.
  Qed.

  Lemma disjoint_get_fwd' : forall ls sm1 sm2,
    disjoint' ls sm1 sm2
    -> NoDup ls
    -> List.Forall (fun w => smem_get' ls w sm1 <> None -> smem_get' ls w sm2 <> None -> False) ls.
    induction sm1; simpl; intuition; rewrite (hlist_eta _ sm2) in *; simpl in *;
      subst; constructor; simpl.
    destruct (H.addr_dec x x); tauto.
    inversion H0; clear H0; subst.
    eapply Forall_weaken'; try apply IHsm1.
    eauto.
    auto.
    simpl; intros.
    destruct (H.addr_dec x x0); subst; tauto.
    destruct (H.addr_dec x x); tauto.
    inversion H0; clear H0; subst.
    eapply Forall_weaken'; try apply IHsm1.
    eauto.
    auto.
    simpl; intros.
    destruct (H.addr_dec x x0); subst; tauto.
  Qed.

  Lemma disjoint_get_fwd : forall sm1 sm2,
    disjoint sm1 sm2
    -> (forall w, smem_get w sm1 <> None -> smem_get w sm2 <> None -> False).
    intros; eapply disjoint_get_fwd' in H; try apply BedrockHeap.NoDup_all_addr.
    assert (In w H.all_addr) by apply allWords_universal.
    generalize (proj1 (Forall_forall _ _) H _ H2); tauto.
  Qed.

  Lemma smem_eta : forall ls (sm sm' : smem' ls),
    NoDup ls
    -> List.Forall (fun w => smem_get' ls w sm = smem_get' ls w sm') ls
    -> sm = sm'.
    induction sm; simpl; intuition.
    rewrite hlist_nil; auto.
    inversion H0; clear H0; subst.
    inversion H; clear H; subst.
    destruct (H.addr_dec x x); intuition idtac; subst.
    rewrite (hlist_eta _ sm'); f_equal.
    apply IHsm; auto.
    eapply Forall_weaken'; eauto.
    simpl; intros.
    destruct (H.addr_dec x x0); subst; tauto.
  Qed.

  Lemma split_put_clear : forall sm sm1 sm2 a v,
    split sm sm1 sm2
    -> smem_get a sm2 = Some v
    -> split sm (smem_put _ sm1 a v) (smem_clear _ sm2 a).
    unfold split; intuition subst.
    apply disjoint_get; intros.
    destruct (weq w a); subst.
    autorewrite with get in *; tauto.
    autorewrite with get in *.
    eapply disjoint_get_fwd in H1; eassumption.

    apply smem_eta; try apply BedrockHeap.NoDup_all_addr.
    apply Forall_forall; intros.
    destruct (weq x a); subst.
    rewrite join_None.
    erewrite join_Some.
    eauto.
    autorewrite with get; reflexivity.
    case_eq (smem_get a sm1); auto; intros.
    eapply disjoint_get_fwd in H1; try eassumption.
    tauto.
    instantiate (1 := a); congruence.
    congruence.

    case_eq (smem_get x sm1); intros.
    erewrite join_Some.
    erewrite join_Some.
    2: autorewrite with get; eassumption.
    2: eassumption.
    reflexivity.

    rewrite join_None.
    rewrite join_None.
    autorewrite with get; reflexivity.
    autorewrite with get; assumption.
    assumption.
  Qed.

  Lemma recharacterize_array8 : forall specs stn sz base m,
    (forall n, (0 < n < sz)%nat
      -> base ^+ $(n) <> base)
    -> (forall n, (n < sz)%nat
      -> smem_get (base ^+ $(n)) m <> None)
    -> (forall p, smem_get p m <> None ->
      exists n, (n < sz)%nat /\ p = base ^+ $(n))
    -> exists bs, length bs = sz /\ interp specs (array8 bs base stn m).
    clear; induction sz; simpl; intuition.

    exists nil; simpl; propxFo.
    apply semp_eta.
    intros.
    specialize (H1 p).
    destruct (smem_get p m); auto.
    destruct H1.
    congruence.
    intuition.

    generalize (H0 0); replace (base ^+ $0) with base by words;
      case_eq (smem_get base m); intros; try solve [ elimtype False; eauto ].
    clear H3.
    edestruct IHsz.
    instantiate (1 := base ^+ $1).
    intros.
    replace (base ^+ $ (1) ^+ $ (n)) with (base ^+ natToW (S n)) in *
      by (rewrite natToW_S; unfold natToW; W_eq).
    intros.
    eapply H.
    instantiate (1 := n); auto.
    apply (f_equal (fun x => x ^- $1)) in H4.
    rewrite natToW_S in H4.
    unfold natToW in H4.
    replace (base ^+ ($1 ^+ $(n)) ^- $1) with (base ^+ $(n)) in H4 by W_eq.
    replace (base ^+ $1 ^- $1) with base in H4 by W_eq.
    auto.

    instantiate (1 := smem_clear _ m base).
    intros.
    replace (base ^+ $ (1) ^+ $ (n)) with (base ^+ natToW (S n)) in H4
      by (rewrite natToW_S; unfold natToW; W_eq).
    rewrite get_clear_ne in H4.
    apply H0 with (S n).
    auto.
    auto.
    intro.
    eapply H.
    2: eauto.
    auto.

    intros.
    destruct (weq p base); subst.
    rewrite get_clear_eq in H3; tauto.
    rewrite get_clear_ne in H3; auto.
    apply H1 in H3.
    propxFo; subst.
    destruct x.
    elimtype False; apply n.
    words.
    exists x; intuition.
    rewrite natToW_S.
    unfold natToW.
    unfold H.addr in *.
    W_eq.

    intuition subst; simpl; exists (b :: x); propxFo.
    exists (smem_put _ smem_emp base b).
    exists (smem_clear _ m base).
    descend.
    apply split_put_clear.
    apply split_a_semp_a.
    auto.
    apply get_put_eq.
    rewrite get_put_ne; auto.
    autorewrite with get; auto.
  Qed.

  Lemma disjoint_eta' : forall ls, NoDup ls
    -> forall m1 m2,
      (forall p v1 v2, In p ls
        -> smem_get' ls p m1 = Some v1
        -> smem_get' ls p m2 = Some v2
        -> False)
      -> disjoint' ls m1 m2.
    induction 1; simpl; intuition auto 1.
    specialize (H1 x); destruct (H.addr_dec x x); try tauto.
    destruct (hlist_hd m1); auto; destruct (hlist_hd m2); auto.
    elimtype False; eauto.

    apply IHNoDup; intros.
    specialize (H1 p).
    destruct (H.addr_dec x p); try congruence.
    eauto.
  Qed.

  Lemma disjoint_eta : forall m1 m2,
    (forall p v1 v2, smem_get p m1 = Some v1
      -> smem_get p m2 = Some v2
      -> False)
    -> disjoint m1 m2.
    intros; apply disjoint_eta'.
    apply H.NoDup_all_addr.
    eauto.
  Qed.

  Lemma get_graft : forall p0 v sz m m' p,
    smem_get p0 (smem_graft m m' p sz) = Some v
    -> smem_get p0 m = Some v \/ (exists n, p0 = p ^+ $(n)
      /\ (n < sz)%nat
      /\ smem_get p0 m' = Some v).
    clear; induction sz; simpl; intuition auto 1.
    case_eq (smem_get p m'); intros;
      match goal with
        | [ H : _ = _ |- _ ] => rewrite H in *; try congruence; eauto
      end.
    destruct (weq p0 p); subst.
    rewrite get_put_eq in *.
    right; exists 0; intuition.
    unfold H.addr in *; W_eq.
    rewrite get_put_ne in *; eauto.
    destruct (IHsz _ _ _ H) as [ | [ ? [ ] ] ]; subst; intuition eauto.
    right; exists (S x); intuition.
    unfold H.addr in *.
    change ($ (S x)) with (natToW (S x)).
    rewrite (natToW_S x).
    unfold natToW in *; words.
  Qed.

  Lemma disjoint_not_both' : forall p v ls m1 m2,
    disjoint' ls m1 m2
    -> smem_get' ls p m2 = Some v
    -> smem_get' ls p m1 = None.
    clear; induction ls; simpl; intuition.

    destruct (H.addr_dec a p); eauto.

    destruct (H.addr_dec a p); eauto; congruence.
  Qed.

  Lemma disjoint_not_both : forall m1 m2 p v,
    disjoint m1 m2
    -> smem_get p m2 = Some v
    -> smem_get p m1 = None.
    intros; eapply disjoint_not_both'; eauto.
  Qed.

  Lemma smem_canon' : forall ls, NoDup ls
    -> forall m1 m2,
      (forall p, In p ls -> smem_get' ls p m1 = smem_get' ls p m2)
      -> m1 = m2.
    clear; induction 1; simpl; intuition.
    rewrite (hlist_nil_only _ m1); rewrite (hlist_nil_only _ m2); auto.
    rewrite (hlist_eta _ m1); rewrite (hlist_eta _ m2).
    f_equal.
    specialize (H1 x); destruct (H.addr_dec x x); tauto.
    apply IHNoDup; intros.
    specialize (H1 p).
    destruct (H.addr_dec x p).
    congruence.
    auto.
  Qed.

  Lemma smem_canon : forall m1 m2,
    (forall p, smem_get p m1 = smem_get p m2)
    -> m1 = m2.
    intros; apply smem_canon'.
    apply H.NoDup_all_addr.
    auto.
  Qed.

  Fixpoint smem_minus' ls : smem' ls -> smem' ls -> smem' ls :=
    match ls with
      | nil => fun sm _ => sm
      | a :: ls' => fun sm sm' =>
        HCons match hlist_hd sm' with
                | Some _ => None
                | _ => hlist_hd sm
              end (smem_minus' _ (hlist_tl sm) (hlist_tl sm'))
    end.

  Definition smem_minus (sm sm' : smem) := smem_minus' _ sm sm'.

  Lemma disjoint_minus' : forall ls, NoDup ls
    -> forall m m',
      (forall p v, In p ls
        -> smem_get' ls p m' = Some v -> smem_get' ls p m = Some v)
      -> disjoint' ls (smem_minus' _ m m') m'.
    clear; induction 1; simpl; intuition.
    specialize (H1 x).
    destruct (H.addr_dec x x); try tauto.
    destruct (hlist_hd m'); eauto.
    apply IHNoDup; intros.
    specialize (H1 p); destruct (H.addr_dec x p); try congruence.
    eauto.
  Qed.

  Lemma disjoint_minus : forall m m',
    (forall p v, smem_get p m' = Some v -> smem_get p m = Some v)
    -> disjoint (smem_minus' _ m m') m'.
    intros; apply disjoint_minus'; auto.
    apply H.NoDup_all_addr.
  Qed.

  Lemma join_minus' : forall ls, NoDup ls
    -> forall m m',
      (forall p v, In p ls
        -> smem_get' ls p m' = Some v -> smem_get' ls p m = Some v)
      -> m = join' ls (smem_minus' _ m m') m'.
    clear; induction 1; simpl; intuition.
    rewrite (hlist_nil_only _ m); auto.
    rewrite (hlist_eta _ m); simpl; f_equal.
    specialize (H1 x); destruct (H.addr_dec x x); try tauto.
    destruct (hlist_hd m'); eauto.
    destruct (hlist_hd m); auto.

    apply IHNoDup; intros.
    specialize (H1 p); destruct (H.addr_dec x p); subst.
    tauto.
    eauto.
  Qed.

  Lemma join_minus : forall m m',
    (forall p v, smem_get p m' = Some v -> smem_get p m = Some v)
    -> m = join (smem_minus' _ m m') m'.
    intros; apply join_minus'; auto.
    apply H.NoDup_all_addr.
  Qed.

  Lemma split_minus : forall m m',
    (forall p v, smem_get p m' = Some v -> smem_get p m = Some v)
    -> split m (smem_minus m m') m'.
    unfold split; intuition subst; auto using disjoint_minus, join_minus.
  Qed.

  Lemma no_overlap' : forall p v1 v2 ls m1 m2,
    disjoint' ls m1 m2
    -> In p ls
    -> smem_get' ls p m1 = Some v1
    -> smem_get' ls p m2 = Some v2
    -> False.
    induction ls; simpl; intuition subst.
    destruct (H.addr_dec p p); try tauto; congruence.
    destruct (H.addr_dec p p); try tauto; congruence.
    destruct (H.addr_dec a p); eauto; congruence.
    destruct (H.addr_dec a p); eauto; congruence.
  Qed.

  Lemma no_overlap : forall m1 m2 p v1 v2,
    disjoint m1 m2
    -> smem_get p m1 = Some v1
    -> smem_get p m2 = Some v2
    -> False.
    intros; eapply no_overlap'; eauto.
    apply allWords_universal.
  Qed.

  Lemma not_zero : forall sz n,
    (0 < n < pow2 sz)%nat
    -> natToWord sz n <> wzero sz.
    intros; intro.
    apply (f_equal (@wordToNat _)) in H0.
    rewrite wordToNat_natToWord_idempotent in H0.
    subst.
    rewrite roundTrip_0 in H.
    omega.
    pre_nomega.
    rewrite Npow2_nat.
    auto.
  Qed.

  Lemma tickle_bytes : forall specs p sz P stn st st',
    interp specs (![ p =?>8 sz * P] (stn, st))
    -> onlyChange p sz (Mem st) (Mem st')
    -> interp specs (![ p =?>8 sz * P] (stn, st')).
    clear; unfold buffer; rewrite sepFormula_eq.
    intros.
    apply simplify_fwd in H; simpl in *.
    repeat match goal with
             | [ H : Logic.ex _ |- _ ] => destruct H
             | [ H : _ /\ _ |- _ ] => destruct H
           end.
    apply simplify_bwd in H3.
    hnf in H5; subst.
    apply split_comm in H1; apply split_semp in H1; try reflexivity; subst.

    edestruct recharacterize_array8.

    instantiate (1 := p).
    instantiate (1 := length x1).
    intros.
    apply word_neq.
    replace (p ^+ $(n) ^- p) with (natToW n).
    apply not_zero.
    eapply array8_bound in H3.
    generalize dependent 32.
    intros.
    omega.
    unfold H.addr, natToW in *; W_eq.

    instantiate (1 := smem_minus (memoryIn (Mem st')) x0).
    intros.
    eapply characterize_array8_bwd in H3; eauto.

    Lemma get_minus_out' : forall p ls m1 m2,
      smem_get' ls p m2 = None
      -> smem_get' ls p (smem_minus' _ m1 m2) = smem_get' ls p m1.
      clear; induction ls; simpl; intuition.
      destruct (H.addr_dec a p); intuition.
      rewrite H; auto.
    Qed.

    Lemma get_minus_out : forall p m1 m2,
      smem_get p m2 = None
      -> smem_get p (smem_minus m1 m2) = smem_get p m1.
      intros; apply get_minus_out'; auto.
    Qed.

    Lemma get_minus_in' : forall p ls m1 m2,
      smem_get' ls p m2 <> None
      -> smem_get' ls p (smem_minus' _ m1 m2) = None.
      clear; induction ls; simpl; intuition.
      destruct (H.addr_dec a p); intuition.
      destruct (hlist_hd m2); tauto.
    Qed.

    Lemma get_minus_in : forall p m1 m2,
      smem_get p m2 <> None
      -> smem_get p (smem_minus m1 m2) = None.
      intros; apply get_minus_in'; auto.
    Qed.

    rewrite get_minus_out.
    case_eq (smem_get (p ^+ $(n)) x2); intros; try congruence.
    eapply unsplit_smem_get in H4; eauto.
    repeat rewrite get_memoryIn in *.
    destruct H0.
    specialize (SameMapped (p ^+ $(n))).
    intuition.

    case_eq (smem_get (p ^+ $ (n)) x2); intros; try congruence.
    case_eq (smem_get (p ^+ $ (n)) x0); intros; try congruence.
    destruct H.
    elimtype False; eapply no_overlap; eauto.

    intros.
    destruct H0.
    eapply characterize_array8_fwd; eauto.
    case_eq (smem_get p0 x0); intros.
    rewrite get_minus_in in H1; congruence.
    rewrite get_minus_out in H1 by congruence.
    assert (smem_get p0 (memoryIn (Mem st)) <> None).
    repeat rewrite get_memoryIn in *.
    specialize (SameMapped p0); intuition.
    eapply must_be; eauto; apply split_comm; auto.

    intuition.
    propxFo.
    descend.
    apply split_minus; intros.
    assert (smem_get p0 (memoryIn (Mem st)) = Some v)
      by (eapply split_smem_get; eauto).
    repeat rewrite get_memoryIn in *.
    destruct H0.
    rewrite Elsewhere; auto.
    intros.
    destruct (weq p0 (p ^+ $(n))); subst; auto.
    eapply characterize_array8_bwd in H3; eauto.
    case_eq (smem_get (p ^+ $(n)) x2); intros; try congruence.
    destruct H; intro; eauto using no_overlap.

    apply split_comm; apply split_a_semp_a.

    eauto.
    eauto.
    reflexivity.
    auto.
  Qed.

  Ltac eqer := repeat (match goal with
                         | [ H : _ = _ |- _ ] => rewrite H in *
                         | [ H : Some _ = Some _ |- _ ] =>
                           injection H; clear H; intros
                         | [ H : Logic.ex _ |- _ ] => destruct H; try clear H
                         | [ H : _ /\ _ |- _ ] => destruct H; try clear H
                       end; subst).

  Lemma onlyChange_refl : forall p len m,
    onlyChange p len m m.
    constructor; intuition.
  Qed.

  Hint Immediate onlyChange_refl.

  Ltac prove_ReadWord :=
    eapply prove_ReadWord; hnf; intros; cbv beta in *;
      try rewrite evalInstrs_slot in *;
        match goal with
          | [ st : (W * state)%type |- _ ] => destruct st; simpl in *
          | [ st : state' |- _ ] => destruct st; simpl in *
        end;
        generalize dependent (specs m stn); intros;
          repeat match goal with
                   | [ H : interp _ _ |- _ ] => generalize dependent H
                   | [ H : context[evalInstrs] |- _ ] => generalize dependent H
                 end; clear; intros; evaluate auto_ext; auto.

  Lemma progress : forall st, goodState st
    -> exists st', sys_step stn prog st st'.
    unfold goodState; post;
      match goal with
        | [ x : label |- _ ] => destruct x
      end.

    match goal with
      | [ H : _ |- _ ] => specialize (impSys' _ _ H); intro Hi; hnf in Hi;
        unfold labelSys' in Hi; simpl in Hi; intuition subst;
          match goal with
            | [ H : (_, _) = (_, _) |- _ ] =>
              injection H; clear H; intros; subst
          end; eauto; post
    end;
    match goal with
      | [ H : interp ?specs (![locals ?a ?b ?c ?d * ?Q * ?R] ?X) |- _ ] =>
        let H' := fresh in
          assert (H' : interp specs (![locals a b c d * (Q * R)] X))
            by (generalize H; clear; intros; step auto_ext);
            clear H; rename H' into H;
              specialize (locals_mapped _ _ _ _ _ _ _ _ H);
                intro Hm; simpl in Hm
    end;
    try match goal with
          | [ H : interp ?specs (![?P * (?p =?>8 ?sz * ?Q)] ?X) |- _ ] =>
            let H' := fresh in
              assert (H' : interp specs (![p =?>8 sz * (P * Q)] X))
                by (generalize H; clear; intros; step auto_ext);
                clear H; rename H' into H;
                  specialize (bytes_mapped _ _ _ _ _ _ H);
                    intro Hb; simpl in Hb
        end;
    match goal with
      | [ H : specs _ _ _ = Some _ |- _ ] =>
        apply specs_hit in H; post; eauto
    end;
    try match goal with
          | [ st : state' |- Logic.ex _ ] =>
            solve [ exists (st#Rp, snd st); eauto
              | exists (st#Rp, snd st);
                match goal with
                  | [ _ : context["read"] |- _ ] => eapply Read
                  | _ => eapply Write
                end; eauto;
                match goal with
                  | [ H : interp _ _ |- ReadWord ?stn (Mem (snd ?st)) _ = Some _ ] =>
                    generalize H; clear; intros; prove_ReadWord
                end ]
        end.

    match goal with
      | [ H : _, H' : interp _ _ |- _ ] =>
        specialize (BlocksOk ok H); intro Hb; hnf in Hb;
          apply Hb in H'; [ | eapply specsOk; eauto ];
            clear Hb; post;
              specialize (agree _ _ _ H); destruct agree as [ ? [ ] ]
    end;
    eqer;
    match goal with
      | [ H : specs _ _ _ = Some _ |- _ ] =>
        apply specs_hit in H; post; eauto
    end;
    descend; apply Normal; unfold step;
      match goal with
        | [ H : _ = _ |- _ ] => rewrite H; eauto
      end.
  Qed.

  Lemma goOnIn : forall P Q R,
    Q * (P * R) ===> P * Q * R.
    clear; sepLemma.
  Qed.

  Lemma preservation : forall st, goodState st
    -> forall st', sys_step stn prog st st'
      -> goodState st'.
    unfold goodState; destruct 2; post;
      try match goal with
            | [ x : label, H : _ |- _ ] =>
              solve [ destruct x; specialize (impSys' _ _ H);
                intro Hi; hnf in Hi; unfold labelSys' in Hi; simpl in Hi;
                  intuition subst;
                    match goal with
                      | [ H : _ |- _ ] => apply omitImp in H;
                        match goal with
                          | [ H' : prog _ = None |- _ ] =>
                            unfold step in *; rewrite H' in *; discriminate
                        end
                    end ]

            | [ H : LabelMap.MapsTo _ _ (Blocks _), H' : interp _ _ |- _ ] =>
              solve [ specialize (BlocksOk ok H); intro Hb; hnf in Hb;
                apply Hb in H'; [ | eapply specsOk; eauto ];
                  clear Hb; post;
                    specialize (agree _ _ _ H); destruct agree as [ ? [ ] ];
                      unfold step in *; eqer;
                        apply specs_hit in H4; destruct H4; intuition idtac;
                          try match goal with
                                | [ H : Logic.ex _ |- _ ] => destruct H
                              end; eauto 10 ]

            | [ H1 : _, H2 : _ |- _ ] =>
              solve [ apply (inj _ _ _ H1) in H2; subst;
                specialize (omitImp _ _ H1);
                  match goal with
                    | [ H : _ |- _ ] => apply agree in H; post; congruence
                  end ]
          end;
      match goal with
        | [ x : label, H5 : LabelMap.MapsTo _ _ (Imports _) |- _ ] =>
          destruct x; specialize (impSys' _ _ H5);
            intro Hi; hnf in Hi; unfold labelSys' in Hi; simpl in Hi;
              intuition subst;
                match goal with
                  | [ H : (_, _) = (_, _) |- _ ] =>
                    injection H; clear H; intros; subst
                end; eauto; post;
                try match goal with
                      | [ H1 : _, H2 : _ |- _ ] =>
                        solve [ apply (inj _ _ _ H1) in H2;
                          cbv beta in H2; congruence ]
                    end; post;
                match goal with
                  | [ H : _ = _ |- _ ] => apply specs_hit in H; destruct H; intuition idtac
                end;
                match goal with
                  | [ st' : state |- _ ] => destruct st'; simpl in *; subst
                end; descend; eauto;
                match goal with
                  | [ H : forall x : ST.settings * state, _ |- _ ] =>
                    apply (Imply_sound (H _)); propxFo; descend;
                      try (apply ILTacCommon.ignore_regs; eassumption)
                end
      end;
      match goal with
        | [ H : interp (specs _ ?stn) (![?P] (_, snd ?st))%PropX |- _ ] =>
          match P with
            | context[locals _ ?V _ _] =>
              eapply ILTacCommon.interp_interp_himp in H; [ | apply comeOnOut ];
                eapply ILTacCommon.interp_interp_himp; [ | apply goOnIn ];
                  eapply tickle_bytes; eauto;
                    assert (ReadWord stn (IL.Mem (snd st)) (st#Sp ^+ $8)
                      = Some (sel V "buffer")) by prove_ReadWord;
                    assert (ReadWord stn (IL.Mem (snd st)) (st#Sp ^+ $12)
                      = Some (sel V "size")) by prove_ReadWord;
                    cbv beta in *; simpl; congruence
          end
      end.
  Qed.

  Lemma safety' : forall st, goodState st
    -> forall st', sys_reachable stn prog st st'
      -> goodState st'.
    induction 2; simpl; eauto using preservation.
  Qed.

  Theorem safety : forall st mn g pre, LabelMap.MapsTo (mn, Global g) pre (Exports m)
    -> Labels stn (mn, Global g) = Some (fst st)
    -> interp (specs0 m stn) (pre (stn, snd st))
    -> sys_safe stn prog st.
    unfold sys_safe; intros.
    eapply safety' in H2.
    auto using progress.
    hnf; descend; eauto.
    apply (ExportsSound ok) in H; eauto.
  Qed.
End OpSem.