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

(** Correctness proof for code linearization *)

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

Module NodesetFacts := FSetFacts.Facts(Nodeset).

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

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

Section LINEARIZATION.

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

Hypothesis TRANSF: match_prog prog tprog.

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

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

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

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

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

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

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

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

(** * Correctness of reachability analysis *)

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

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

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

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

(** * Properties of node enumeration *)

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

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

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

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

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

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

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

(** * Properties related to labels *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(** Correctness of [add_branch]. *)

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

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

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

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

(** * Correctness of linearization *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

End LINEARIZATION.


From SegmentQueue.lib.blocking_pool
     Require Export outer_storage_interfaces.
From iris.program_logic Require Import atomic.
From iris.heap_lang Require Export proofmode notation lang.
Open Scope nat.

Section impl.

Definition tryInsertStack: val :=
  rec: "loop" "top" "x" :=
    let: "t" := !"top" in
    let: "node" := ref (SOME "x", "t") in
    match: "t" with
      SOME "tn" => let: "topNode" := !"tn" in
                  let: "element" := Fst "topNode" in
                  let: "next" := Snd "topNode" in
                  match: "element" with
                    SOME "value" => if: CAS "top" "t" (SOME "node")
                                    then #true
                                    else "loop" "top" "x"
                  | NONE => if: CAS "top" "t" "next"
                            then #false
                            else "loop" "top" "x"
                  end
    | NONE => if: CAS "top" "t" (SOME "node")
              then #true
              else "loop" "top" "x"
    end.

Definition tryRetrieveStack: val :=
  rec: "loop" "top" :=
    let: "t" := !"top" in
    let: "node" := ref (NONE, "t") in
    match: "t" with
      SOME "tn" => let: "topNode" := !"tn" in
                  let: "element" := Fst "topNode" in
                  let: "next" := Snd "topNode" in
                  match: "element" with
                    SOME "value" => if: CAS "top" "t" "next"
                                   then SOME "value"
                                   else "loop" "top"
                  | NONE => if: CAS "top" "t" (SOME "node")
                           then NONE
                           else "loop" "top"
                  end
    | NONE => if: CAS "top" "t" (SOME "node")
             then NONE
             else "loop" "top"
    end.

Definition newStack: val :=
  λ: <>, ref NONE.

Definition stackOuterStorageImpl :=
  {|
   tryInsert := tryInsertStack;
   tryRetrieve := tryRetrieveStack;
   newStorage := newStack;
  |}.

End impl.

From iris.algebra Require Import cmra auth list agree csum numbers gmap excl.
From iris.base_logic Require Import lib.invariants.
From iris.bi.lib Require Import fractional.
From SegmentQueue.lib.blocking_pool Require Export outer_storage_spec.

Section proof.

Context `{heapG Σ}.

Notation stack_element_algebra :=
  (agreeR (prodO (optionO valO) (optionO locO))).

Inductive nonEmpty t :=
  NonEmpty: t -> list t -> nonEmpty t.

Definition hdNonEmpty {t} (xs: nonEmpty t) :=
  match xs with NonEmpty _ x _ => x end.

Definition tlNonEmpty {t} (xs: nonEmpty t) :=
  match xs with NonEmpty _ _ xs => xs end.

Definition nonEmptyToList {t} (xs: nonEmpty t) :=
  match xs with NonEmpty _ x xs => x :: xs end.

Definition lengthNonEmpty {A : Type} (xs: nonEmpty A): positive :=
  Pos.of_nat (S (length (tlNonEmpty xs))).

Definition mapNonEmpty {A B : Type} (f: A -> B) (xs: nonEmpty A): nonEmpty B :=
  match xs with
    NonEmpty _ x xs => NonEmpty _ (f x) (f <$> xs)
  end.

Definition consNonEmpty {A : Type} (x : A) (xs : nonEmpty A): nonEmpty A :=
  match xs with NonEmpty _ y ys => NonEmpty _ x (y::ys) end.

Inductive stackState :=
| StackEmpty : stackState
| StackWithValues : nonEmpty (loc * val) -> stackState
| StackWithFailures : nonEmpty loc -> stackState.

Canonical Structure stackStateO := leibnizO stackState.

Notation algebra := (authUR (prodUR (gmapUR locO stack_element_algebra)
                                    (optionUR (exclR stackStateO))
                    )).

Instance algebra_discrete: ∀ (x: algebra), Discrete x.
Proof. apply _. Qed.

Class iStackG Σ := IStackG { iStack_inG :> inG Σ algebra }.
Definition iStackΣ : gFunctors := #[GFunctor algebra].
Instance subG_iStackΣ : subG iStackΣ Σ → iStackG Σ.
Proof. solve_inG. Qed.
Context `{iStackG Σ}.

Notation iProp := (iProp Σ).

Variable (N: namespace).

Definition has_contents γ (nodeℓ: loc) (value: option val) (tail: option loc)
  : iProp := own γ (◯ ({[ nodeℓ := to_agree (value, tail) ]}, None)).

Theorem has_contents_agrees γ ℓ value value' tail tail':
  has_contents γ ℓ value tail -∗ has_contents γ ℓ value' tail' -∗
               ⌜value = value' ∧ tail = tail'⌝.
Proof.
  iIntros "H◯1 H◯2". iDestruct (own_valid_2 with "H◯1 H◯2") as %HValid.
  iPureIntro. move: HValid. rewrite -auth_frag_op -pair_op singleton_op.
  rewrite auth_frag_valid pair_valid singleton_valid. case=> HPf _.
  apply agree_op_invL' in HPf. by case: HPf=> -> ->.
Qed.

Definition stack_state_ownership γ (state: stackState): iProp :=
  own γ (◯ (ε, Excl' state)).

Definition stack_as_outer_storage (state: stackState): outerStorageState :=
  match state with
  | StackEmpty => OuterStorageState 0 ∅
  | StackWithFailures p => OuterStorageState (length (nonEmptyToList p)) ∅
  | StackWithValues val =>
    OuterStorageState 0 (list_to_set_disj (snd <$> nonEmptyToList val))
  end.

Definition outer_storage_state γ (state: outerStorageState): iProp :=
  ∃ s, ⌜stack_as_outer_storage s = state⌝ ∧ stack_state_ownership γ s.

Fixpoint list_contains γ (values: list (loc * val))
  : iProp :=
  match values with
    nil => True
  | cons (ℓ, v) values' =>
    has_contents γ ℓ (Some v) (hd_error (fst <$> values'))
                 ∗ list_contains γ values'
  end.

Instance list_contains_persistent γ values :
  Persistent (list_contains γ values).
Proof. elim: values. apply _. move=> [? ?]. apply _. Qed.

Instance list_contains_timeless γ values :
  Timeless (list_contains γ values).
Proof. elim: values. apply _. move=> [? ?]. apply _. Qed.

Fixpoint list_failures γ (values: list loc) : iProp :=
  match values with
    nil => True
  | cons ℓ values' =>
    has_contents γ ℓ None (hd_error values') ∗ list_failures γ values'
  end.

Instance list_failures_persistent γ values :
  Persistent (list_failures γ values).
Proof. elim: values; apply _. Qed.

Instance list_failures_timeless γ values :
  Timeless (list_failures γ values).
Proof. elim: values; apply _. Qed.

Definition stack_top_value' (state: stackState): option loc :=
  match state with
  | StackEmpty => None
  | StackWithValues ct => Some (fst (hdNonEmpty ct))
  | StackWithFailures ct => Some (hdNonEmpty ct)
  end.

Definition list_state γ (state: stackState): iProp :=
  match state with
  | StackEmpty => True
  | StackWithValues ct => list_contains γ (nonEmptyToList ct)
  | StackWithFailures ct => list_failures γ (nonEmptyToList ct)
  end.

Instance list_state_timeless γ state: Timeless (list_state γ state).
Proof. by case: state; apply _. Qed.

Instance list_state_persistent γ state: Persistent (list_state γ state).
Proof. by case: state; apply _. Qed.

Definition heap_to_ra (heap: gmap loc (option val * option loc)):
  gmapUR locO stack_element_algebra :=
  to_agree <$> heap.

Definition option_to_value (v: option val): val :=
  match v with
    None => NONEV
  | Some v => SOMEV v
  end.

Theorem option_to_value_inj:
  FinFun.Injective option_to_value.
Proof.
  intros a b. rewrite /option_to_value.
  case: a; case: b=> //=.
  move=> a b. case. by intros ->.
Qed.

Definition loc_to_value (v: option loc): val :=
  option_to_value ((fun x => LitV (LitLoc x)) <$> v).

Theorem loc_to_value_inj:
  FinFun.Injective loc_to_value.
Proof.
  intros a b HInj. apply option_to_value_inj in HInj. move: HInj.
  case: a; case: b=> //=. move=> a b. case. by intros ->.
Qed.

Definition stack_top_value (state: stackState): val :=
  loc_to_value (stack_top_value' state).

Definition heap_value (ℓ: loc) (c: option val * option loc): iProp :=
  ℓ ↦ (option_to_value (fst c), loc_to_value (snd c)).

Definition heap_values (heap: gmap loc (option val * option loc)): iProp :=
  [∗ map] ℓ ↦ c ∈ heap, heap_value ℓ c.

Definition stack_invariant γ topℓ: iProp :=
  ∃ heap (state: stackState),
    own γ (● (heap_to_ra heap, Excl' state))
        ∗ heap_values heap
        ∗ topℓ ↦ stack_top_value state ∗ list_state γ state.

Definition is_stack γ v: iProp :=
  ∃ (topℓ: loc), ⌜v = #topℓ⌝ ∧ inv N (stack_invariant γ topℓ).

Global Instance is_stack_persistent γ v: Persistent (is_stack γ v).
Proof. apply _. Qed.

Lemma stack_top_value_inj γ a b:
  ⌜stack_top_value a = stack_top_value b⌝ -∗
    list_state γ a -∗ list_state γ b -∗
    ⌜a = b⌝.
Proof.
  iIntros (HTopValue) "H1 H2".
  apply loc_to_value_inj in HTopValue. move: HTopValue.
  rewrite /stack_top_value'.
  case: a; case: b=> //=; move=> a' b'; case.
  all: case: a'=> x xs; case: b'=> y ys=> /=.
  - case: y; case: x=> /=. move=> a1 a2 b1 b2 Heq. subst.
    iInduction (xs) as [|x xs] "IH" forall (a1 a2 b2 ys).
    * iDestruct "H1" as "[H1h H1t]". iDestruct "H2" as "[H2h H2t]".
      iDestruct (has_contents_agrees with "H1h H2h") as %[H1 H2].
      move: H1 H2=> /=. case: ys=> /=; last done.
      by case=> ->.
    * iDestruct "H1" as "[H1h H1t]". iDestruct "H2" as "[H2h H2t]".
      iDestruct (has_contents_agrees with "H1h H2h") as %[H1 H2].
      move: H1 H2=> /=. case: ys=> /=; first done. move=> y ys.
      case=> HEq; subst. case: y; case: x=> a b c d. case=> HEq; subst.
      simpl.
      iDestruct ("IH" with "H1t H2t") as %HOk. move: HOk. case=> ? ?.
      by subst.
  - case: y=> /= a1 a2 HEq. subst.
    iDestruct "H1" as "[H1h H1t]". iDestruct "H2" as "[H2h H2t]".
    iDestruct (has_contents_agrees with "H1h H2h") as %[H1 H2].
    done.
  - case: x=> /= a1 a2 HEq. subst.
    iDestruct "H1" as "[H1h H1t]". iDestruct "H2" as "[H2h H2t]".
    iDestruct (has_contents_agrees with "H1h H2h") as %[H1 H2].
    done.
  - move=> HEq. subst.
    iInduction (xs) as [|x' xs] "IH" forall (x ys).
    * iDestruct "H1" as "[H1h H1t]". iDestruct "H2" as "[H2h H2t]".
      iDestruct (has_contents_agrees with "H1h H2h") as %[H1 H2].
      move: H1 H2=> /=. case: ys=> //=.
    * iDestruct "H1" as "[H1h H1t]". iDestruct "H2" as "[H2h H2t]".
      iDestruct (has_contents_agrees with "H1h H2h") as %[H1 H2].
      move: H1 H2=> /=. case: ys=> /=; first done. move=> y ys _.
      case=> HEq; subst.
      iDestruct ("IH" with "H1t H2t") as %HOk. move: HOk. case=> ?.
      by subst.
Qed.

Theorem update_stack_state state γ topℓ storageState state':
  list_state γ state -∗
  list_state γ state' -∗
  stack_invariant γ topℓ -∗
  outer_storage_state γ storageState ==∗
  (⌜storageState = stack_as_outer_storage state⌝ ∧
    topℓ ↦ stack_top_value state ∗
        (topℓ ↦ stack_top_value state' -∗ stack_invariant γ topℓ)
        ∗ outer_storage_state γ (stack_as_outer_storage state') ∨
   ∃ state'', ⌜state'' ≠ state⌝ ∧ list_state γ state'' ∗
        topℓ ↦ stack_top_value state'' ∗
        (topℓ ↦ stack_top_value state'' -∗ stack_invariant γ topℓ)
        ∗ outer_storage_state γ storageState).
Proof.
  iIntros "#HList #HList' HInv H◯".
  iDestruct "HInv" as (heap currentState) "(H● & HHeap & Htopℓ & #HList'')".
  iDestruct "H◯" as (currentState' <-) "H◯".
  destruct (decide (stack_top_value currentState = stack_top_value state))
    as [eq|neq].
  - iDestruct (stack_top_value_inj with "[%] [#] [#]") as %HEq; try done.
    subst.
    iLeft. iFrame "Htopℓ".
    iDestruct (own_valid_2 with "H● H◯")
      as %[[_ HValid%Excl_included]%prod_included _]%auth_both_valid.
    apply leibniz_equiv in HValid. subst.
    iSplitR; first done.
    iMod (own_update_2 with "H● H◯") as "[H● H◯]".
    2: {
      iModIntro. iSplitR "H◯".
      - iIntros "Htopℓ". iExists heap, _. by iFrame.
      - iExists state'. by iFrame.
    }
    apply auth_update, prod_local_update_2.
    apply option_local_update.
    by apply exclusive_local_update.
  - iRight. iExists currentState. iFrame "Htopℓ HList''".
    iSplitR.
    { iPureIntro. intros heq. subst. done. }
    iSplitR "H◯"; last by iExists _; iFrame.
    iModIntro. iIntros "Htopℓ". iExists _, _. by iFrame.
Qed.

Theorem register_heap_value (v: option val) (ℓ': option loc) γ ℓ heap state:
  ℓ ↦ (option_to_value v,
       option_to_value ((fun x => LitV (LitLoc x)) <$> ℓ'))
    -∗ own γ (● (heap_to_ra heap, state))
    -∗ heap_values heap
    ==∗
    ∃ heap', own γ (● (heap_to_ra heap', state)) ∗ heap_values heap' ∗
    has_contents γ ℓ v ℓ'.
Proof.
  iIntros "Hℓ H● HHeap". rewrite /heap_values /heap_value.
  iAssert (⌜heap !! ℓ = None⌝)%I as %HNone.
  {
    destruct (heap !! ℓ) eqn:E; last done. iExFalso.
    iDestruct (big_sepM_lookup with "HHeap") as "HContra"; first done.
    by iDestruct (mapsto_valid_2 with "Hℓ HContra") as %[].
  }
  remember (<[ℓ := (v, ℓ')]> heap) as heap'.
  iAssert ([∗ map] ℓ ↦ c ∈ heap', heap_value ℓ c)%I
    with "[Hℓ HHeap]" as "HHeap'".
  { subst. rewrite big_sepM_insert; last done. iFrame. }
  iMod (own_update with "H●") as "[H● H◯]".
  2: { iFrame "H◯". iExists heap'. by iFrame. }
  subst. rewrite /heap_to_ra -map_fmap_singleton fmap_insert.
  rewrite map_fmap_singleton.
  apply auth_update_alloc, prod_local_update_1.
  apply alloc_singleton_local_update.
  by rewrite lookup_fmap HNone.
  done.
Qed.

Theorem hasContents_load γ ℓ topℓ (x: option val) (y: option loc):
  {{{ inv N (stack_invariant γ topℓ) ∗ has_contents γ ℓ x y }}}
    ! #ℓ
  {{{ RET (option_to_value x, loc_to_value y); True }}}.
Proof.
  iIntros (Φ) "[#HInv #H◯] HΦ". iInv N as ">HOpen".
  iDestruct "HOpen" as (heap state) "(H● & HHeap & HRest)".
  rewrite /heap_values.
  iDestruct (own_valid_2 with "H● H◯")
    as %[[HValid%singleton_included_l _]%prod_included
                                        HAuthValid]%auth_both_valid.
  simpl in *. destruct HValid as (e & HLookup & HInc).
  move: HInc. rewrite Some_included. move=> HAgree.
  move: HAuthValid. case=> /= heapValid _.
  assert (heap_to_ra heap !! ℓ ≡ Some (to_agree (x, y))) as HLookup'.
  {
    case: HAgree.
    - move=> HAg; move: HLookup. by rewrite -HAg.
    - destruct (to_agree_uninj e) as [HH HH1].
      {
        eapply lookup_valid_Some. 2: apply HLookup. done.
      }
      rewrite HLookup. rewrite -HH1. clear. case: HH=> x' y'.
      rewrite to_agree_included. case=> /= -> -> //.
  }
  clear HLookup HAgree.
  rewrite lookup_fmap in HLookup'.
  destruct (decide (heap !! ℓ = Some (x, y))) as [eq|neq].
  2: {
    exfalso. destruct (heap !! ℓ) as [[a b]|] eqn:Z.
    2: rewrite Z in HLookup'; inversion HLookup'.
    rewrite Z in HLookup'. simpl in HLookup'.
    apply Some_equiv_inj in HLookup'.
    apply to_agree_inj in HLookup'. case: HLookup'. simpl.
    move=> A B. move: neq.
    apply leibniz_equiv in A. apply leibniz_equiv in B. by subst.
  }
  iDestruct (big_sepM_lookup_acc with "HHeap") as "[HEl HRestore]";
    first done.
  wp_load.
  iSpecialize ("HRestore" with "HEl"). iModIntro.
  iSpecialize ("HΦ" with "[$]"). iFrame.
  iExists _, _. iFrame.
Qed.

Theorem tryInsertStack_spec γ stack (value : val):
  is_stack γ stack -∗
  <<< ∀ state, ▷ outer_storage_state γ state >>>
      tryInsert stackOuterStorageImpl stack value @ ⊤∖↑N
        <<< ∃ (b: bool),
                if b then
                  outer_storage_state γ (insertionAddsValue state value)
                else match insertionRemovesFailure state with
                       None => False
                     | Some state' => outer_storage_state γ state'
                     end, RET #b >>>.
Proof.
  iIntros "#HIsStack" (Φ) "AU". iDestruct "HIsStack" as (topℓ ->) "HInv".
  wp_lam. wp_pures. iLöb as "IH". wp_bind (!#topℓ)%E.
  iInv N as ">HOpen" "HClose".
  iDestruct "HOpen" as (heap1 state1) "(H● & HHeap & Htopℓ & #HList)".
  wp_load.
  iMod ("HClose" with "[H● HHeap Htopℓ]") as "_".
  { iExists _, _. by iFrame. }
  iModIntro. wp_pures. wp_alloc node as "HNode". iApply fupd_wp.
  iInv N as ">HOpen" "HClose".
  iDestruct "HOpen" as (heap2 state2) "(H● & HHeap & Htopℓ & HList')".
  iMod (register_heap_value (Some value) with "HNode H● HHeap")
    as (?) "(H● & HHeap & #HNode)".
  iMod ("HClose" with "[Htopℓ HList' H● HHeap]") as "_".
  by iExists _, _; iFrame.
  iModIntro. wp_pures.
  destruct state1 as [|[[loc stored] values]|[failure failures]].
  - wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as ">HOpen" "HClose".
    iMod "AU" as (outerState) "[>outerState HAuClose]".
    iAssert (list_state γ (StackWithValues (NonEmpty _ (node, value) [])))
      with "[#]" as "HList'".
    by simpl; iFrame "HNode".
    iMod (update_stack_state with "HList HList' HOpen outerState")
      as "[(% & Htopℓ & HRestore & outerState)|H]".
    * subst. wp_cmpxchg_suc.
      iDestruct "HAuClose" as "[_ HAuClose]".
      iMod ("HAuClose" with "[outerState]") as "HΦ".
      2: {
        iModIntro.
        iMod ("HClose" with "[Htopℓ HRestore]") as "_".
        by iSpecialize ("HRestore" with "Htopℓ").
        iModIntro. by wp_pures.
      }
      simpl. iFrame.
    * iDestruct "H"
        as (state'') "(% & #HList'' & Htopℓ & HRestore & outerStorage)".
      iAssert (⌜stack_top_value StackEmpty = stack_top_value state''⌝ -∗ False)%I
        with "[#]" as %HNe.
      {
        iIntros (HTop).
        by iDestruct (stack_top_value_inj with "[%] [] []") as %HContra.
      }
      wp_cmpxchg_fail.
      iDestruct "HAuClose" as "[HAuClose _]".
      iMod ("HAuClose" with "outerStorage") as "AU".
      iModIntro.
      iMod ("HClose" with "[Htopℓ HRestore]") as "_".
      by iSpecialize ("HRestore" with "Htopℓ").
      iModIntro. wp_pures. wp_lam. wp_pures.
      by iApply "IH".
  - wp_pures. wp_apply hasContents_load. simpl.
    { iFrame "HInv". iDestruct "HList" as "[$ _]". }
    iIntros "_".
    wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as ">HOpen" "HClose".
    iMod "AU" as (outerState) "[>outerState HAuClose]".
    iAssert (list_state γ (StackWithValues (NonEmpty _ (node, value)
            ((loc, stored)::values))))
      with "[#]" as "HList'".
    by simpl; iFrame "HNode".
    iMod (update_stack_state with "HList HList' HOpen outerState")
      as "[(% & Htopℓ & HRestore & outerState)|H]".
    * simpl. subst. wp_cmpxchg_suc.
      iDestruct "HAuClose" as "[_ HAuClose]".
      iMod ("HAuClose" with "[outerState]") as "HΦ".
      2: {
        iModIntro.
        iMod ("HClose" with "[Htopℓ HRestore]") as "_".
        by iSpecialize ("HRestore" with "Htopℓ").
        iModIntro. by wp_pures.
      }
      iFrame.
    * iDestruct "H"
        as (state'') "(% & #HList'' & Htopℓ & HRestore & outerStorage)".
      iAssert (⌜stack_top_value _ = stack_top_value state''⌝ -∗ False)%I
        with "[#]" as %HNe.
      {
        iIntros (HTop).
        iDestruct (stack_top_value_inj with "[%] [] []") as %HContra.
        apply HTop. iApply "HList". iApply "HList''". done.
      }
      wp_cmpxchg_fail.
      iDestruct "HAuClose" as "[HAuClose _]".
      iMod ("HAuClose" with "outerStorage") as "AU".
      iModIntro.
      iMod ("HClose" with "[Htopℓ HRestore]") as "_".
      by iSpecialize ("HRestore" with "Htopℓ").
      iModIntro. wp_pures. wp_lam. wp_pures.
      by iApply "IH".
  - wp_pures. wp_apply hasContents_load.
    { simpl. iFrame "HInv". iDestruct "HList" as "[$ _]". }
    iIntros "_".
    wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as ">HOpen" "HClose".
    iMod "AU" as (outerState) "[>outerState HAuClose]".
    destruct failures as [|failure' failures].
    + iAssert (list_state γ StackEmpty) with "[$]" as "HList'".
      iMod (update_stack_state with "HList HList' HOpen outerState")
        as "[(% & Htopℓ & HRestore & outerState)|H]".
      * subst. wp_cmpxchg_suc.
        iDestruct "HAuClose" as "[_ HAuClose]".
        iMod ("HAuClose" with "[outerState]") as "HΦ".
        2: {
          iModIntro.
          iMod ("HClose" with "[Htopℓ HRestore]") as "_".
          by iSpecialize ("HRestore" with "Htopℓ").
          iModIntro. by wp_pures.
        }
        iFrame.
      * iDestruct "H"
          as (state'') "(% & #HList'' & Htopℓ & HRestore & outerStorage)".
        iAssert (⌜stack_top_value _ = stack_top_value state''⌝ -∗ False)%I
          with "[#]" as %HNe.
        {
          iIntros (HTop).
          iDestruct (stack_top_value_inj with "[%] [] []") as %HContra.
          apply HTop. iApply "HList". iApply "HList''". done.
        }
        wp_cmpxchg_fail.
        iDestruct "HAuClose" as "[HAuClose _]".
        iMod ("HAuClose" with "outerStorage") as "AU".
        iModIntro.
        iMod ("HClose" with "[Htopℓ HRestore]") as "_".
        by iSpecialize ("HRestore" with "Htopℓ").
        iModIntro. wp_pures. wp_lam. wp_pures.
        by iApply "IH".
    + iAssert (list_state γ (StackWithFailures (NonEmpty _ failure' failures)))
        with "[#]" as "HList'".
      { simpl. iDestruct "HList" as "[_ $]". }
      iMod (update_stack_state with "HList HList' HOpen outerState")
        as "[(% & Htopℓ & HRestore & outerState)|H]".
      * subst. wp_cmpxchg_suc.
        iDestruct "HAuClose" as "[_ HAuClose]".
        iMod ("HAuClose" with "[outerState]") as "HΦ".
        2: {
          iModIntro.
          iMod ("HClose" with "[Htopℓ HRestore]") as "_".
          by iSpecialize ("HRestore" with "Htopℓ").
          iModIntro. by wp_pures.
        }
        iFrame.
      * iDestruct "H"
          as (state'') "(% & #HList'' & Htopℓ & HRestore & outerStorage)".
        iAssert (⌜stack_top_value _ = stack_top_value state''⌝ -∗ False)%I
          with "[#]" as %HNe.
        {
          iIntros (HTop).
          iDestruct (stack_top_value_inj with "[%] [] []") as %HContra.
          apply HTop. iApply "HList". iApply "HList''". done.
        }
        wp_cmpxchg_fail.
        iDestruct "HAuClose" as "[HAuClose _]".
        iMod ("HAuClose" with "outerStorage") as "AU".
        iModIntro.
        iMod ("HClose" with "[Htopℓ HRestore]") as "_".
        by iSpecialize ("HRestore" with "Htopℓ").
        iModIntro. wp_pures. wp_lam. wp_pures.
        by iApply "IH".
Qed.

Section XX.
Context `{Countable A}.
Implicit Types x y : A.
Implicit Types X Y : gmultiset A.
Lemma gmultiset_difference_disj_union X Y : Y = (X ⊎ Y) ∖ X.
Proof.
  apply gmultiset_eq. move=> x.
  rewrite multiplicity_difference multiplicity_disj_union. lia.
Qed.
End XX.

Theorem tryRetrieveStack_spec γ stack:
  is_stack γ stack -∗
  <<< ∀ state, ▷ outer_storage_state γ state >>>
      tryRetrieve stackOuterStorageImpl stack @ ⊤∖↑N
  <<< ∃ (v : option val),
          match v with
            | Some v' => match retrievalRemovesValue state v' with
                          | None => False
                          | Some state' => outer_storage_state γ state'
                        end
            | None => outer_storage_state γ (retrievalAddsFailure state)
          end, RET option_to_value v >>>.
Proof.
  iIntros "#HIsStack" (Φ) "AU". iDestruct "HIsStack" as (topℓ ->) "HInv".
  wp_lam. wp_pures. iLöb as "IH". wp_bind (!#topℓ)%E.
  iInv N as ">HOpen" "HClose".
  iDestruct "HOpen" as (heap1 state1) "(H● & HHeap & Htopℓ & #HList)".
  wp_load.
  iMod ("HClose" with "[H● HHeap Htopℓ]") as "_".
  { iExists _, _. by iFrame. }
  iModIntro. wp_pures. wp_alloc node as "HNode". iApply fupd_wp.
  iInv N as ">HOpen" "HClose".
  iDestruct "HOpen" as (heap2 state2) "(H● & HHeap & Htopℓ & HList')".
  iMod (register_heap_value None with "HNode H● HHeap")
    as (?) "(H● & HHeap & #HNode)".
  iMod ("HClose" with "[Htopℓ HList' H● HHeap]") as "_".
  by iExists _, _; iFrame.
  iModIntro. wp_pures.
  destruct state1 as [|[[loc stored] values]|[failure failures]].
  - wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as ">HOpen" "HClose".
    iMod "AU" as (outerState) "[>outerState HAuClose]".
    iAssert (list_state γ (StackWithFailures (NonEmpty _ node [])))
      with "[#]" as "HList'".
    by simpl; iFrame "HNode".
    iMod (update_stack_state with "HList HList' HOpen outerState")
      as "[(% & Htopℓ & HRestore & outerState)|H]".
    * subst. wp_cmpxchg_suc.
      iDestruct "HAuClose" as "[_ HAuClose]".
      iMod ("HAuClose" $! None with "[outerState]") as "HΦ".
      2: {
        iModIntro.
        iMod ("HClose" with "[Htopℓ HRestore]") as "_".
        by iSpecialize ("HRestore" with "Htopℓ").
        iModIntro. by wp_pures.
      }
      iFrame.
    * iDestruct "H"
        as (state'') "(% & #HList'' & Htopℓ & HRestore & outerStorage)".
      iAssert (⌜stack_top_value StackEmpty = stack_top_value state''⌝ -∗ False)%I
        with "[#]" as %HNe.
      {
        iIntros (HTop).
        by iDestruct (stack_top_value_inj with "[%] [] []") as %HContra.
      }
      wp_cmpxchg_fail.
      iDestruct "HAuClose" as "[HAuClose _]".
      iMod ("HAuClose" with "outerStorage") as "AU".
      iModIntro.
      iMod ("HClose" with "[Htopℓ HRestore]") as "_".
      by iSpecialize ("HRestore" with "Htopℓ").
      iModIntro. wp_pures. wp_lam. wp_pures.
      by iApply "IH".
  - wp_pures. wp_apply hasContents_load.
    { simpl. iFrame "HInv". iDestruct "HList" as "[$ _]". }
    iIntros "_".
    wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as ">HOpen" "HClose".
    iMod "AU" as (outerState) "[>outerState HAuClose]".
    destruct values as [|value' values].
    + iAssert (list_state γ StackEmpty) with "[$]" as "HList'".
      iMod (update_stack_state with "HList HList' HOpen outerState")
        as "[(% & Htopℓ & HRestore & outerState)|H]".
      * subst. wp_cmpxchg_suc.
        iDestruct "HAuClose" as "[_ HAuClose]".
        iMod ("HAuClose" $! (Some stored) with "[outerState]") as "HΦ".
        2: {
          iModIntro.
          iMod ("HClose" with "[Htopℓ HRestore]") as "_".
          by iSpecialize ("HRestore" with "Htopℓ").
          iModIntro. by wp_pures.
        }
        rewrite /retrievalRemovesValue. simpl.
        rewrite gmultiset_disj_union_right_id.
        rewrite multiplicity_singleton.
        rewrite gmultiset_difference_diag.
        iFrame.
      * iDestruct "H"
          as (state'') "(% & #HList'' & Htopℓ & HRestore & outerStorage)".
        iAssert (⌜stack_top_value _ = stack_top_value state''⌝ -∗ False)%I
          with "[#]" as %HNe.
        {
          iIntros (HTop).
          iDestruct (stack_top_value_inj with "[%] [] []") as %HContra.
          apply HTop. iApply "HList". iApply "HList''". done.
        }
        wp_cmpxchg_fail.
        iDestruct "HAuClose" as "[HAuClose _]".
        iMod ("HAuClose" with "outerStorage") as "AU".
        iModIntro.
        iMod ("HClose" with "[Htopℓ HRestore]") as "_".
        by iSpecialize ("HRestore" with "Htopℓ").
        iModIntro. wp_pures. wp_lam. wp_pures.
        by iApply "IH".
    + iAssert (list_state γ (StackWithValues (NonEmpty _ value' values)))
        with "[#]" as "HList'".
      { simpl. iDestruct "HList" as "[_ $]". }
      iMod (update_stack_state with "HList HList' HOpen outerState")
        as "[(% & Htopℓ & HRestore & outerState)|H]".
      * subst. wp_cmpxchg_suc.
        iDestruct "HAuClose" as "[_ HAuClose]".
        iMod ("HAuClose" $! (Some stored) with "[outerState]") as "HΦ".
        2: {
          iModIntro.
          iMod ("HClose" with "[Htopℓ HRestore]") as "_".
          by iSpecialize ("HRestore" with "Htopℓ").
          iModIntro. by wp_pures.
        }
        iFrame.
        rewrite /retrievalRemovesValue. simpl.
        rewrite multiplicity_disj_union multiplicity_singleton /=.
        rewrite -gmultiset_difference_disj_union. iFrame.
      * iDestruct "H"
          as (state'') "(% & #HList'' & Htopℓ & HRestore & outerStorage)".
        iAssert (⌜stack_top_value _ = stack_top_value state''⌝ -∗ False)%I
          with "[#]" as %HNe.
        {
          iIntros (HTop).
          iDestruct (stack_top_value_inj with "[%] [] []") as %HContra.
          apply HTop. iApply "HList". iApply "HList''". done.
        }
        wp_cmpxchg_fail.
        iDestruct "HAuClose" as "[HAuClose _]".
        iMod ("HAuClose" with "outerStorage") as "AU".
        iModIntro.
        iMod ("HClose" with "[Htopℓ HRestore]") as "_".
        by iSpecialize ("HRestore" with "Htopℓ").
        iModIntro. wp_pures. wp_lam. wp_pures.
        by iApply "IH".
  - wp_pures. wp_apply hasContents_load. simpl.
    { iFrame "HInv". iDestruct "HList" as "[$ _]". }
    iIntros "_".
    wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as ">HOpen" "HClose".
    iMod "AU" as (outerState) "[>outerState HAuClose]".
    iAssert (list_state γ (StackWithFailures (NonEmpty _ node
            (failure::failures))))
      with "[#]" as "HList'".
    by simpl; iFrame "HNode".
    iMod (update_stack_state with "HList HList' HOpen outerState")
      as "[(% & Htopℓ & HRestore & outerState)|H]".
    * simpl. subst. wp_cmpxchg_suc.
      iDestruct "HAuClose" as "[_ HAuClose]".
      iMod ("HAuClose" $! None with "[outerState]") as "HΦ".
      2: {
        iModIntro.
        iMod ("HClose" with "[Htopℓ HRestore]") as "_".
        by iSpecialize ("HRestore" with "Htopℓ").
        iModIntro. by wp_pures.
      }
      iFrame.
    * iDestruct "H"
        as (state'') "(% & #HList'' & Htopℓ & HRestore & outerStorage)".
      iAssert (⌜stack_top_value _ = stack_top_value state''⌝ -∗ False)%I
        with "[#]" as %HNe.
      {
        iIntros (HTop).
        iDestruct (stack_top_value_inj with "[%] [] []") as %HContra.
        apply HTop. iApply "HList". iApply "HList''". done.
      }
      wp_cmpxchg_fail.
      iDestruct "HAuClose" as "[HAuClose _]".
      iMod ("HAuClose" with "outerStorage") as "AU".
      iModIntro.
      iMod ("HClose" with "[Htopℓ HRestore]") as "_".
      by iSpecialize ("HRestore" with "Htopℓ").
      iModIntro. wp_pures. wp_lam. wp_pures.
      by iApply "IH".
Qed.

Theorem newStack_spec:
  {{{ True }}}
    newStorage stackOuterStorageImpl #()
  {{{ γ v, RET v; is_stack γ v ∗
                  outer_storage_state γ (OuterStorageState 0 ∅) }}}.
Proof.
  iIntros (Φ) "_ HΦ". wp_lam. rewrite -wp_fupd.
  wp_alloc ℓ as "Hℓ".
  iMod (own_alloc (● (ε, Excl' StackEmpty) ⋅ ◯ (ε, Excl' StackEmpty)))
    as (γ) "[H● H◯]".
  by apply auth_both_valid.
  iMod (inv_alloc N _ (stack_invariant γ ℓ) with "[Hℓ H●]") as "HInv".
  { iExists ∅, StackEmpty. rewrite /heap_to_ra fmap_empty. iFrame.
    rewrite /heap_values. by iApply big_sepM_empty.
  }
  iApply "HΦ". iSplitL "HInv".
  - iExists _. by iFrame.
  - iExists _. by iFrame.
Qed.

End proof.

Canonical Structure stack_outerStorage `{!heapG Σ} `{!iStackG Σ}:
  outerStorageSpec Σ stackOuterStorageImpl :=
  {|
    is_outer_storage := is_stack;
    outer_storage_contents := outer_storage_state;
    tryInsert_spec := tryInsertStack_spec;
    tryRetrieve_spec := tryRetrieveStack_spec;
    newStorage_spec := newStack_spec;
  |}.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import
        Coq.Strings.String
        Coq.Arith.Mult
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.SumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Common.DecideableEnsembles
        Fiat.Common.IterateBoundedIndex
        Fiat.Common.Tactics.CacheStringConstant
        Fiat.Computation
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.Narcissus.BinLib.Core
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Automation.Solver
        Fiat.Narcissus.Formats.WordOpt
        Fiat.Narcissus.Formats.NatOpt
        Fiat.Narcissus.Formats.StringOpt
        Fiat.Narcissus.Formats.EnumOpt
        Fiat.Narcissus.Formats.FixListOpt
        Fiat.Narcissus.Formats.SumTypeOpt
        Fiat.Narcissus.Formats.DomainNameOpt
        Fiat.Narcissus.Examples.DNS.DNSPacket.

Require Import
        Bedrock.Word.

Section DnsPacket.

  Open Scope Tuple_scope.

  Definition association_list K V := list (K * V).

  Fixpoint association_list_find_first {K V}
           {K_eq : Query_eq K}
           (l : association_list K V)
           (k : K) : option V :=
    match l with
    | (k', v) :: l' => if A_eq_dec k k' then Some v else association_list_find_first l' k
    | _ => None
    end.

  Fixpoint association_list_find_all {K V}
           {K_eq : Query_eq K}
           (l : association_list K V)
           (k : K) : list V :=
    match l with
    | (k', v) :: l' => if A_eq_dec k k' then v :: association_list_find_all l' k
                       else association_list_find_all l' k
    | _ => nil
    end.

  Fixpoint association_list_add {K V}
           {K_eq : DecideableEnsembles.Query_eq K}
           (l : association_list K V)
           (k : K) (v : V) : list (K * V)  :=
    (k, v) :: l.

  Instance dns_list_cache : Cache :=
    {| CacheFormat := option (word 17) * association_list string pointerT;
       CacheDecode := option (word 17) * association_list pointerT string;
       Equiv ce cd := fst ce = fst cd
                      /\ (snd ce) = (map (fun ps => match ps with (p, s) => (s, p) end) (snd cd))
                      /\ NoDup (map fst (snd cd))
    |}%type.

  Definition list_CacheFormat_empty : CacheFormat := (Some (wzero _), nil).
  Definition list_CacheDecode_empty : CacheDecode := (Some (wzero _), nil).

  Lemma list_cache_empty_Equiv : Equiv list_CacheFormat_empty list_CacheDecode_empty.
  Proof.
    simpl; intuition; simpl; econstructor.
  Qed.

  Local Opaque pow2.
  Arguments natToWord : simpl never.
  Arguments wordToNat : simpl never.

  (* pointerT2Nat (Nat2pointerT (NPeano.div (wordToNat w) 8)) *)

  Instance cacheAddNat : CacheAdd _ nat :=
    {| addE ce n := (Ifopt (fst ce) as m Then
                                         let n' := (wordToNat m) + n in
                     if Compare_dec.lt_dec n' (pow2 17)
                     then Some (natToWord _ n')
                     else None
                            Else None, snd ce);
       addD cd n := (Ifopt (fst cd) as m Then
                                         let n' := (wordToNat m) + n in
                     if Compare_dec.lt_dec n' (pow2 17)
                     then Some (natToWord _ n')
                     else None
                            Else None, snd cd) |}.
  Proof.
    simpl; intuition eauto; destruct a; destruct a0;
      simpl in *; eauto; try congruence.
    injections.
    find_if_inside; eauto.
  Defined.

  Instance Query_eq_string : Query_eq string :=
    {| A_eq_dec := string_dec |}.

  Instance : Query_eq pointerT :=
    {| A_eq_dec := pointerT_eq_dec |}.

  Instance cachePeekDNPointer : CachePeek _ (option pointerT) :=
    {| peekE ce := Ifopt (fst ce) as m Then Some (Nat2pointerT (wordToNat (wtl (wtl (wtl m))))) Else None;
       peekD cd := Ifopt (fst cd) as m Then Some
                                       (Nat2pointerT (wordToNat (wtl (wtl (wtl m)))))
                                       Else None |}.
  Proof.
    abstract (simpl; intros; intuition; rewrite H0; auto).
  Defined.

  Lemma cacheGetDNPointer_pf
    : forall (ce : CacheFormat) (cd : CacheDecode)
             (p : string) (q : pointerT),
      Equiv ce cd ->
      (association_list_find_first (snd cd) q = Some p <-> List.In q (association_list_find_all (snd ce) p)).
  Proof.
    intros [? ?] [? ?] ? ?; simpl; intuition eauto; subst.
    - subst; induction a0; simpl in *; try congruence.
      destruct a; simpl in *; find_if_inside; subst.
      + inversion H2; subst; intros.
        find_if_inside; subst; simpl; eauto.
      + inversion H2; subst; intros.
        find_if_inside; subst; simpl; eauto; congruence.
    - subst; induction a0; simpl in *; intuition.
      destruct a; simpl in *; find_if_inside.
      + inversion H2; subst; intros.
        find_if_inside; subst; simpl; eauto; try congruence.
        apply IHa0 in H1; eauto.
        exfalso; apply H3; revert H1; clear.
        induction a0; simpl; intros; try congruence.
        destruct a; find_if_inside; injections; auto.
      + inversion H2; subst; intros.
        find_if_inside; subst; simpl; eauto; try congruence.
        simpl in H1; intuition eauto; subst.
        congruence.
  Qed.

  Instance cacheGetDNPointer : CacheGet dns_list_cache string pointerT :=
    {| getE ce p := @association_list_find_all string _ _ (snd ce) p;
       getD ce p := association_list_find_first (snd ce) p;
       get_correct := cacheGetDNPointer_pf |}.

  Lemma cacheAddDNPointer_pf
    : forall (ce : CacheFormat) (cd : CacheDecode) (t : string * pointerT),
   Equiv ce cd ->
   add_ptr_OK t ce cd ->
   Equiv (fst ce, association_list_add (snd ce) (fst t) (snd t))
     (fst cd, association_list_add (snd cd) (snd t) (fst t)).
  Proof.
    simpl; intuition eauto; simpl in *; subst; eauto.
    unfold add_ptr_OK in *.
    destruct t; simpl in *; simpl; econstructor; eauto.
    clear H3; induction b0; simpl.
    - intuition.
    - simpl in H0; destruct a; find_if_inside;
        try discriminate.
      intuition.
  Qed.

  Instance cacheAddDNPointer
    : CacheAdd_Guarded _ add_ptr_OK :=
    {| addE_G ce sp := (fst ce, association_list_add (snd ce) (fst sp) (snd sp));
       addD_G cd sp := (fst cd, association_list_add (snd cd) (snd sp) (fst sp));
       add_correct_G := cacheAddDNPointer_pf
    |}.

  Lemma IndependentCaches :
    forall env p (b : nat),
      getD (addD env b) p = getD env p.
  Proof.
    simpl; intros; eauto.
  Qed.

  Lemma IndependentCaches' :
    forall env p (b : nat),
      getE (addE env b) p = getE env p.
  Proof.
    simpl; intros; eauto.
  Qed.

  Lemma IndependentCaches''' :
    forall env b,
      peekE (addE_G env b) = peekE env.
  Proof.
    simpl; intros; eauto.
  Qed.

  Lemma getDistinct :
    forall env l p p',
      p <> p'
      -> getD (addD_G env (l, p)) p' = getD env p'.
  Proof.
    simpl; intros; eauto.
    find_if_inside; try congruence.
  Qed.

  Lemma getDistinct' :
    forall env l p p' l',
      List.In p (getE (addE_G env (l', p')) l)
      -> p = p' \/ List.In p (getE env l).
  Proof.
    simpl in *; intros; intuition eauto.
    find_if_inside; simpl in *; intuition eauto.
  Qed.

  Arguments NPeano.div : simpl never.

  Lemma mult_pow2 :
    forall m n,
      pow2 m * pow2 n = pow2 (m + n).
  Proof.
    Local Transparent pow2.
    induction m; simpl; intros.
    - omega.
    - rewrite <- IHm.
      rewrite <- !plus_n_O.
      rewrite Mult.mult_plus_distr_r; omega.
  Qed.

  Corollary mult_pow2_8 : forall n,
      8 * (pow2 n) = pow2 (3 + n).
  Proof.
    intros; rewrite <- mult_pow2.
    reflexivity.
  Qed.

  Local Opaque pow2.

  Lemma pow2_div
    : forall m n,
      lt (m + n * 8) (pow2 17)
      -> lt (NPeano.div m 8) (pow2 14).
  Proof.
    intros.
    eapply (NPeano.Nat.mul_lt_mono_pos_l 8); try omega.
    rewrite mult_pow2_8.
    eapply le_lt_trans.
    apply NPeano.Nat.mul_div_le; try omega.
    simpl.
    omega.
  Qed.

  Lemma addPeekNone :
    forall env n,
      peekD env = None
      -> peekD (addD env n) = None.
  Proof.
    simpl; intros.
    destruct (fst env); simpl in *; congruence.
  Qed.

  Lemma wtl_div
    : forall n (w : word (S (S (S n)))),
      wordToNat (wtl (wtl (wtl w))) = NPeano.div (wordToNat w) 8.
  Proof.
    intros.
    pose proof (shatter_word_S w); destruct_ex; subst.
    pose proof (shatter_word_S x0); destruct_ex; subst.
    pose proof (shatter_word_S x2); destruct_ex; subst.
    simpl wtl.
    rewrite <- (NPeano.Nat.div_div _ 2 4) by omega.
    rewrite <- (NPeano.Nat.div_div _ 2 2) by omega.
    rewrite <- !NPeano.Nat.div2_div.
    rewrite !div2_WS.
    reflexivity.
  Qed.

  Lemma mult_lt_compat_l'
    : forall (m n p : nat),
      lt 0 p
      -> lt (p * n)  (p * m)
      -> lt n m.
  Proof.
    induction m; simpl; intros; try omega.
    rewrite (mult_comm p 0) in H0; simpl in *; try omega.
    destruct p; try (exfalso; auto with arith; omega).
    inversion H0.
    rewrite (mult_comm p (S m)) in H0.
    simpl in H0.
    destruct n; try omega.
    rewrite (mult_comm p (S n)) in H0; simpl in H0.
    apply plus_lt_reg_l in H0.
    rewrite <- NPeano.Nat.succ_lt_mono.
    eapply (IHm n p); try eassumption; try omega.
    rewrite mult_comm.
    rewrite (mult_comm p m); auto.
  Qed.

  Lemma mult_lt_compat_l''
    : forall (p m k n : nat),
      lt 0 p
      -> lt n m
      -> lt k p
      -> lt ((p * n) + k) (p * m).
  Proof.
    induction p; intros; try omega.
    simpl.
    inversion H; subst; simpl.
    inversion H1; subst; omega.
    destruct k; simpl.
    - rewrite <- plus_n_O.
      eapply (mult_lt_compat_l n m (S p)); auto.
    - assert (lt (p * n + k) (p * m)) by
          (apply IHp; try omega).
      omega.
  Qed.

  Lemma addPeekNone' :
    forall env n m,
      peekD env = Some m
      -> ~ lt (n + (pointerT2Nat m)) (pow2 14)
      -> peekD (addD env (n * 8)) = None.
  Proof.
    simpl; intros; subst.
    destruct (fst env); simpl in *; try discriminate.
    injections.
    find_if_inside; try reflexivity.
    unfold If_Opt_Then_Else.
    rewrite !wtl_div in *.
    exfalso; apply H0.
    rewrite pointerT2Nat_Nat2pointerT in *;
      try (eapply pow2_div; eassumption).
    eapply (mult_lt_compat_l' _ _ 8); try omega.
    destruct n; try omega.
    exfalso; apply H0.
    simpl.
    eapply (mult_lt_compat_l' _ _ 8); try omega.
    - eapply le_lt_trans.
      apply NPeano.Nat.mul_div_le; omega.
      simpl in l.
      rewrite mult_pow2_8; simpl; omega.
    - rewrite mult_plus_distr_l.
      assert (8 <> 0) by omega.
      pose proof (NPeano.Nat.mul_div_le (wordToNat w) 8 H).
      apply le_lt_trans with (8 * S n + (wordToNat w)).
      omega.
      rewrite mult_pow2_8; simpl; omega.
  Qed.

  Lemma addPeekSome :
    forall env n m,
      peekD env = Some m
      -> lt (n + (pointerT2Nat m)) (pow2 14)
      -> exists p',
          peekD (addD env (n * 8)) = Some p'
          /\ pointerT2Nat p' = n + (pointerT2Nat m).
  Proof.
    simpl; intros; subst.
    destruct (fst env); simpl in *; try discriminate.
    injections.
    find_if_inside.
    - rewrite !wtl_div in *.
      rewrite pointerT2Nat_Nat2pointerT in *;
        try (eapply pow2_div; eassumption).
      unfold If_Opt_Then_Else.
      eexists; split; try reflexivity.
      rewrite wtl_div.
      rewrite wordToNat_natToWord_idempotent.
      rewrite pointerT2Nat_Nat2pointerT in *; try omega.
      rewrite NPeano.Nat.div_add; try omega.
      rewrite NPeano.Nat.div_add; try omega.
      apply Nomega.Nlt_in.
      rewrite Nnat.Nat2N.id, Npow2_nat; auto.
    - exfalso; apply n0.
      rewrite !wtl_div in *.
      rewrite pointerT2Nat_Nat2pointerT in *.
      rewrite (NPeano.div_mod (wordToNat w) 8); try omega.
      pose proof (mult_pow2_8 14) as H'; simpl plus in H'; rewrite <- H'.
      replace (8 * NPeano.div (wordToNat w) 8 + NPeano.modulo (wordToNat w) 8 + n * 8)
      with (8 * (NPeano.div (wordToNat w) 8 + n) + NPeano.modulo (wordToNat w) 8)
        by omega.
      eapply mult_lt_compat_l''; try omega.
      apply NPeano.Nat.mod_upper_bound; omega.
      eapply (mult_lt_compat_l' _ _ 8); try omega.
      eapply le_lt_trans.
      apply NPeano.Nat.mul_div_le; omega.
      rewrite mult_pow2_8; simpl.
      apply wordToNat_bound.
  Qed.

  Lemma addZeroPeek :
    forall xenv,
      peekD xenv = peekD (addD xenv 0).
  Proof.
    simpl; intros.
    destruct (fst xenv); simpl; eauto.
    find_if_inside; unfold If_Opt_Then_Else.
    rewrite <- plus_n_O, natToWord_wordToNat; auto.
    exfalso; apply n.
    rewrite <- plus_n_O.
    apply wordToNat_bound.
  Qed.

  Local Opaque wordToNat.
  Local Opaque natToWord.
v
  Lemma boundPeekSome :
    forall env n m m',
      peekD env = Some m
      -> peekD (addD env (n * 8)) = Some m'
      -> lt (n + (pointerT2Nat m)) (pow2 14).
  Proof.
    simpl; intros; subst.
    destruct (fst env); simpl in *; try discriminate.
    injections.
    find_if_inside; unfold If_Opt_Then_Else in *; try congruence.
    injections.
    rewrite !wtl_div in *.
    rewrite pointerT2Nat_Nat2pointerT in *;
      try (eapply pow2_div; eassumption).
    eapply (mult_lt_compat_l' _ _ 8); try omega.
    - rewrite mult_plus_distr_l.
      assert (8 <> 0) by omega.
      pose proof (NPeano.Nat.mul_div_le (wordToNat w) 8 H).
      apply le_lt_trans with (8 * n + (wordToNat w)).
      omega.
      rewrite mult_pow2_8.
      simpl plus at -1.
      omega.
  Qed.

  Lemma addPeekESome :
    forall env n m,
      peekE env = Some m
      -> lt (n + (pointerT2Nat m)) (pow2 14)%nat
      -> exists p',
          peekE (addE env (n * 8)) = Some p'
          /\ pointerT2Nat p' = n + (pointerT2Nat m).
  Proof.
        simpl; intros; subst.
    destruct (fst env); simpl in *; try discriminate.
    injections.
    find_if_inside.
    - rewrite !wtl_div in *.
      rewrite pointerT2Nat_Nat2pointerT in *;
        try (eapply pow2_div; eassumption).
      unfold If_Opt_Then_Else.
      eexists; split; try reflexivity.
      rewrite wtl_div.
      rewrite wordToNat_natToWord_idempotent.
      rewrite pointerT2Nat_Nat2pointerT in *; try omega.
      rewrite NPeano.Nat.div_add; try omega.
      rewrite NPeano.Nat.div_add; try omega.
      apply Nomega.Nlt_in.
      rewrite Nnat.Nat2N.id, Npow2_nat; auto.
    - exfalso; apply n0.
      rewrite !wtl_div in *.
      rewrite pointerT2Nat_Nat2pointerT in *.
      rewrite (NPeano.div_mod (wordToNat w) 8); try omega.
      pose proof (mult_pow2_8 14) as H'; simpl plus in H'; rewrite <- H'.
      replace (8 * NPeano.div (wordToNat w) 8 + NPeano.modulo (wordToNat w) 8 + n * 8)
      with (8 * (NPeano.div (wordToNat w) 8 + n) + NPeano.modulo (wordToNat w) 8)
        by omega.
      eapply mult_lt_compat_l''; try omega.
      apply NPeano.Nat.mod_upper_bound; omega.
      eapply (mult_lt_compat_l' _ _ 8); try omega.
      eapply le_lt_trans.
      apply NPeano.Nat.mul_div_le; omega.
      rewrite mult_pow2_8; simpl.
      apply wordToNat_bound.
  Qed.

  Lemma boundPeekESome :
    forall env n m m',
      peekE env = Some m
      -> peekE (addE env (n * 8)) = Some m'
      -> lt (n + (pointerT2Nat m)) (pow2 14).
  Proof.
    simpl; intros; subst.
    destruct (fst env); simpl in *; try discriminate.
    injections.
    find_if_inside; unfold If_Opt_Then_Else in *; try congruence.
    injections.
    rewrite !wtl_div in *.
    rewrite pointerT2Nat_Nat2pointerT in *;
      try (eapply pow2_div; eassumption).
    eapply (mult_lt_compat_l' _ _ 8); try omega.
    - rewrite mult_plus_distr_l.
      assert (8 <> 0) by omega.
      pose proof (NPeano.Nat.mul_div_le (wordToNat w) 8 H).
      apply le_lt_trans with (8 * n + (wordToNat w)).
      omega.
      rewrite mult_pow2_8.
      simpl plus at -1.
      omega.
  Qed.

  Lemma addPeekENone :
      forall env n,
        peekE env = None
        -> peekE (addE env n) = None.
  Proof.
    simpl; intros.
    destruct (fst env); simpl in *; congruence.
  Qed.

  Lemma addPeekENone' :
    forall env n m,
      peekE env = Some m
      -> ~ lt (n + (pointerT2Nat m)) (pow2 14)%nat
      -> peekE (addE env (n * 8)) = None.
  Proof.
    simpl; intros; subst.
    destruct (fst env); simpl in *; try discriminate.
    injections.
    find_if_inside; try reflexivity.
    unfold If_Opt_Then_Else.
    rewrite !wtl_div in *.
    exfalso; apply H0.
    rewrite pointerT2Nat_Nat2pointerT in *;
      try (eapply pow2_div; eassumption).
    eapply (mult_lt_compat_l' _ _ 8); try omega.
    destruct n; try omega.
    exfalso; apply H0.
    simpl.
    eapply (mult_lt_compat_l' _ _ 8); try omega.
    - eapply le_lt_trans.
      apply NPeano.Nat.mul_div_le; omega.
      simpl in l.
      rewrite mult_pow2_8; simpl; omega.
    - rewrite mult_plus_distr_l.
      assert (8 <> 0) by omega.
      pose proof (NPeano.Nat.mul_div_le (wordToNat w) 8 H).
      apply le_lt_trans with (8 * S n + (wordToNat w)).
      omega.
      rewrite mult_pow2_8; simpl; omega.
  Qed.

  Lemma addZeroPeekE :
    forall xenv,
      peekE xenv = peekE (addE xenv 0).
  Proof.
    simpl; intros.
    destruct (fst xenv); simpl; eauto.
    find_if_inside; unfold If_Opt_Then_Else.
    rewrite <- plus_n_O, natToWord_wordToNat; auto.
    exfalso; apply n.
    rewrite <- plus_n_O.
    apply wordToNat_bound.
  Qed.

  Import Vectors.Vector.VectorNotations.

  Definition GoodCache (env : CacheDecode) :=
    forall domain p,
      getD env p = Some domain
      -> ValidDomainName domain
         /\ (String.length domain > 0)%nat
         /\ (getD env p = Some domain
             -> forall p' : pointerT, peekD env = Some p' -> lt (pointerT2Nat p) (pointerT2Nat p')).

  Lemma cacheIndependent_add
    : forall (b : nat) (cd : CacheDecode),
      GoodCache cd -> GoodCache (addD cd b).
  Proof.
    unfold GoodCache; intros.
    rewrite IndependentCaches in *;
      eapply H in H0; intuition eauto.
    simpl in *.
    destruct (fst cd); simpl in *; try discriminate.
    find_if_inside; simpl in *; try discriminate.
    injections.
    pose proof (H4 _ (eq_refl _)).
    eapply lt_le_trans; eauto.
    rewrite !pointerT2Nat_Nat2pointerT in *;
      rewrite !wtl_div in *.
    rewrite wordToNat_natToWord_idempotent.
    apply NPeano.Nat.div_le_mono; omega.
    apply Nomega.Nlt_in.
    rewrite Nnat.Nat2N.id, Npow2_nat; auto.
    eapply (mult_lt_compat_l' _ _ 8); try omega.
    + eapply le_lt_trans.
      apply NPeano.Nat.mul_div_le; omega.
      rewrite wordToNat_natToWord_idempotent.
      rewrite mult_pow2_8; simpl; omega.
      apply Nomega.Nlt_in.
      rewrite Nnat.Nat2N.id, Npow2_nat; auto.
    + eapply (mult_lt_compat_l' _ _ 8); try omega.
      eapply le_lt_trans.
      apply NPeano.Nat.mul_div_le; omega.
      rewrite mult_pow2_8; simpl; omega.
    + eapply (mult_lt_compat_l' _ _ 8); try omega.
      eapply le_lt_trans.
      apply NPeano.Nat.mul_div_le; omega.
      rewrite mult_pow2_8; simpl; omega.
    + eapply (mult_lt_compat_l' _ _ 8); try omega.
      eapply le_lt_trans.
      apply NPeano.Nat.mul_div_le; omega.
      rewrite mult_pow2_8; simpl; omega.
  Qed.

  Lemma cacheIndependent_add_2
    : forall cd p (b : nat) domain,
      GoodCache cd
      -> getD (addD cd b) p = Some domain
      -> forall pre label post : string,
          domain = (pre ++ label ++ post)%string ->
          ValidLabel label -> (String.length label <= 63)%nat.
  Proof.
    unfold GoodCache; intros.
    rewrite IndependentCaches in *; eapply H; eauto.
  Qed.

  Lemma cacheIndependent_add_3
    : forall cd p (b : nat) domain,
      GoodCache cd
      -> getD (addD cd b) p = Some domain
      -> ValidDomainName domain.
  Proof.
    unfold GoodCache; intros.
    rewrite IndependentCaches in *; eapply H; eauto.
  Qed.

  Lemma cacheIndependent_add_4
    : forall cd p (b : nat) domain,
      GoodCache cd
      -> getD (addD cd b) p = Some domain
      -> gt (String.length domain) 0.
  Proof.
    unfold GoodCache; intros.
    rewrite IndependentCaches in *; eapply H; eauto.
  Qed.

  Lemma cacheIndependent_add_5
    : forall cd p domain,
      GoodCache cd
      -> getD cd p = Some domain
      -> ValidDomainName domain.
  Proof.
    unfold GoodCache; intros.
    eapply H; eauto.
  Qed.

  Lemma cacheIndependent_add_6
    : forall cd p domain,
      GoodCache cd
      -> getD cd p = Some domain
      -> gt (String.length domain) 0.
  Proof.
    unfold GoodCache; intros.
    eapply H; eauto.
  Qed.

  Lemma cacheIndependent_add_7
    : forall cd p domain,
      GoodCache cd
      -> getD cd p = Some domain
      -> forall pre label post : string,
          domain = (pre ++ label ++ post)%string ->
          ValidLabel label -> (String.length label <= 63)%nat.
  Proof.
    unfold GoodCache; intros.
    eapply H; eauto.
  Qed.

  Lemma ptr_eq_dec :
    forall (p p' : pointerT),
      {p = p'} + {p <> p'}.
  Proof.
    decide equality.
    apply weq.
    destruct a; destruct s; simpl in *.
    destruct (weq x x0); subst.
    left; apply ptr_eq; reflexivity.
    right; unfold not; intros; apply n.
    congruence.
  Qed.

  Lemma cacheIndependent_add_8
    : forall cd p p0 domain domain',
      GoodCache cd
      -> ValidDomainName domain' /\ (String.length domain' > 0)%nat
      -> getD (addD_G cd (domain', p0)) p = Some domain
      -> forall pre label post : string,
          domain = (pre ++ label ++ post)%string ->
          ValidLabel label -> (String.length label <= 63)%nat.
  Proof.
    unfold GoodCache; simpl; intros.
    destruct (pointerT_eq_dec p p0); subst.
    - injections; intuition.
      eapply H1; eauto.
    - eapply H; eauto.
  Qed.

  Lemma cacheIndependent_add_9
    : forall cd p p0 domain domain',
      GoodCache cd
      -> ValidDomainName domain' /\ (String.length domain' > 0)%nat
      -> getD (addD_G cd (domain', p0)) p = Some domain
      -> ValidDomainName domain.
  Proof.
    unfold GoodCache; simpl; intros.
    destruct (pointerT_eq_dec p p0); subst.
    - injections; intuition.
    - eapply H; eauto.
  Qed.

  Lemma cacheIndependent_add_10
    : forall cd p p0 domain domain',
      GoodCache cd
      -> ValidDomainName domain' /\ (String.length domain' > 0)%nat
      -> getD (addD_G cd (domain', p0)) p = Some domain
      -> gt (String.length domain) 0.
  Proof.
    unfold GoodCache; simpl; intros.
    destruct (pointerT_eq_dec p p0); subst.
    - injections; intuition.
    - eapply H; eauto.
  Qed.

  Lemma cacheIndependent_add_11
    : forall (b : nat)
             (cd : CacheDecode)
             (domain : string)
             (p : pointerT),
      GoodCache cd
      -> getD (addD cd b) p = Some domain ->
      forall p' : pointerT, peekD (addD cd b) = Some p' -> lt (pointerT2Nat p) (pointerT2Nat p').
  Proof.
    intros.
    eapply (cacheIndependent_add b) in H.
    eapply H; eauto.
  Qed.

  Lemma cacheIndependent_add_12
      : forall (p : pointerT) (cd : CacheDecode) (domain : string),
        GoodCache cd ->
        getD cd p = Some domain
        -> forall p' : pointerT,
            peekD cd = Some p'
            -> lt (pointerT2Nat p) (pointerT2Nat p').
    Proof.
      unfold GoodCache; simpl; intros; intuition eauto.
      eapply H; eauto.
    Qed.

    Lemma cacheIndependent_add_13
      : forall  (env : CacheDecode)
                (p : pointerT)
                (domain : string)
                (H : GoodCache env)
                (H0 : ValidDomainName domain /\ (String.length domain > 0)%nat)
                (H1 : getD env p = None)
                (H2 : forall p' : pointerT, peekD env = Some p' -> lt (pointerT2Nat p) (pointerT2Nat p'))
                (domain0 : string)
                (p0 : pointerT)
                (H3 : getD (addD_G env (domain, p)) p0 = Some domain0)
                (p' : pointerT),
        peekD (addD_G env (domain, p)) = Some p'
        -> lt (pointerT2Nat p0) (pointerT2Nat p').
    Proof.
      simpl; intros.
      destruct (fst env) eqn: ?; simpl in *; try discriminate.
      find_if_inside; subst.
      - injections.
        apply (H2 _ (eq_refl _)).
      - injections.
        pose proof (H2 _ (eq_refl _)).
        unfold GoodCache in *; intuition.
        eapply H; simpl.
        eassumption.
        eassumption.
        rewrite Heqo; simpl; reflexivity.
    Qed.

    Ltac solve_GoodCache_inv foo :=
    lazymatch goal with
      |- cache_inv_Property ?Z _ =>
      unify Z GoodCache;
      unfold cache_inv_Property; repeat split;
      eauto using cacheIndependent_add, cacheIndependent_add_2, cacheIndependent_add_4, cacheIndependent_add_6, cacheIndependent_add_7, cacheIndependent_add_8, cacheIndependent_add_10, cacheIndependent_add_11, cacheIndependent_add_12, cacheIndependent_add_13;
      try match goal with
            H : _ = _ |- _ =>
            try solve [ eapply cacheIndependent_add_3 in H; intuition eauto ];
            try solve [ eapply cacheIndependent_add_9 in H; intuition eauto ];
            try solve [ eapply cacheIndependent_add_5 in H; intuition eauto ]
          end;
      try solve [instantiate (1 := fun _ => True); exact I]
    end.

  Definition monoid : Monoid ByteString := ByteStringQueueMonoid.

  Opaque pow2. (* Don't want to be evaluating this. *)

  Lemma validDomainName_proj1_OK
    : forall domain,
      ValidDomainName domain
      -> decides true
                 (forall pre label post : string,
                     domain = (pre ++ label ++ post)%string ->
                     ValidLabel label -> (String.length label <= 63)%nat).
  Proof.
    simpl; intros; eapply H; eauto.
  Qed.

  Lemma validDomainName_proj2_OK
    : forall domain,
      ValidDomainName domain
      ->
      decides true
              (forall pre post : string,
                  domain = (pre ++ "." ++ post)%string ->
                  post <> ""%string /\
                  pre <> ""%string /\
                  ~ (exists s' : string, post = String "." s') /\
                  ~ (exists s' : string, pre = (s' ++ ".")%string)).
  Proof.
    simpl; intros; apply H; eauto.
  Qed.

  Hint Resolve validDomainName_proj1_OK : decide_data_invariant_db.
  Hint Resolve validDomainName_proj2_OK : decide_data_invariant_db.
  Hint Resolve FixedList_predicate_rest_True : data_inv_hints.

  Definition resourceRecord_OK (rr : resourceRecord) :=
    ith
      (icons (B := fun T => T -> Prop) (fun a : DomainName => ValidDomainName a)
      (icons (B := fun T => T -> Prop) (fun _ : Memory.W => True)
             (icons (B := fun T => T -> Prop) (fun a : DomainName => ValidDomainName a)
                           (icons (B := fun T => T -> Prop) (fun a : SOA_RDATA =>
                                                               (True /\ ValidDomainName a!"contact_email") /\ ValidDomainName a!"sourcehost")
                                  (icons (B := fun T => T -> Prop) (fun a : WKS_RDATA => True /\ (lt (|a!"Bit-Map" |)  (pow2 16)))
                                         (icons (B := fun T => T -> Prop) (fun a : DomainName => ValidDomainName a)
                                                (icons (B := fun T => T -> Prop) (fun a : HINFO_RDATA =>
                                                                                (True /\ True /\ (lt (String.length a!"OS") (pow2 8))) /\
                                                                                True /\ (lt (String.length a!"CPU") (pow2 8)))
                                                       (icons (B := fun T => T -> Prop) (fun a : MINFO_RDATA =>
                                                                                (True /\ ValidDomainName a!"eMailBx") /\
                                                                                ValidDomainName a!"rMailBx")
                                                              (icons (B := fun T => T -> Prop) (fun a : MX_RDATA => True /\ ValidDomainName a!"Exchange")
                                                                     (icons (B := fun T => T -> Prop) (fun a : string =>
                                                                                True /\ True /\ (lt (String.length a) (pow2 8))) inil))))))))))
      (SumType_index
         (DomainName
            :: (Memory.W : Type)
            :: DomainName
            :: SOA_RDATA
            :: WKS_RDATA
            :: DomainName :: HINFO_RDATA :: MINFO_RDATA :: MX_RDATA :: [string : Type])
         rr!sRDATA)
      (SumType_proj
         (DomainName
            :: (Memory.W : Type)
            :: DomainName
            :: SOA_RDATA
            :: WKS_RDATA
            :: DomainName :: HINFO_RDATA :: MINFO_RDATA :: MX_RDATA :: [string : Type])
         rr!sRDATA)
    /\ ValidDomainName rr!sNAME.

  Lemma resourceRecordOK_1
    : forall data : resourceRecord,
      resourceRecord_OK data -> (fun domain : string => ValidDomainName domain) data!sNAME.
  Proof.
    unfold resourceRecord_OK; intuition eauto.
  Qed.
  Hint Resolve resourceRecordOK_1 : data_inv_hints.

  Lemma resourceRecordOK_3
    : forall rr : resourceRecord,
      resourceRecord_OK rr ->
      ith
        (icons (B := fun T => T -> Prop) (fun a : DomainName => ValidDomainName a)
               (icons (B := fun T => T -> Prop) (fun _ : Memory.W => True)
                      (icons (B := fun T => T -> Prop) (fun a : DomainName => ValidDomainName a)
                             (icons (B := fun T => T -> Prop) (fun a : SOA_RDATA =>
                                                                 (True /\ ValidDomainName a!"contact_email") /\ ValidDomainName a!"sourcehost")
                                    (icons (B := fun T => T -> Prop) (fun a : WKS_RDATA => True /\ (lt (|a!"Bit-Map" |)  (pow2 16)))
                                           (icons (B := fun T => T -> Prop) (fun a : DomainName => ValidDomainName a)
                                                  (icons (B := fun T => T -> Prop) (fun a : HINFO_RDATA =>
                                                                                (True /\ True /\ (lt (String.length a!"OS") (pow2 8))) /\
                                                                                True /\ (lt (String.length a!"CPU") (pow2 8)))
                                                         (icons (B := fun T => T -> Prop) (fun a : MINFO_RDATA =>
                                                                                (True /\ ValidDomainName a!"eMailBx") /\
                                                                                ValidDomainName a!"rMailBx")
                                                                (icons (B := fun T => T -> Prop) (fun a : MX_RDATA => True /\ ValidDomainName a!"Exchange")
                                                                       (icons (B := fun T => T -> Prop) (fun a : string =>
                                                                                True /\ True /\ (lt (String.length a) (pow2 8))) inil))))))))))
        (SumType_index ResourceRecordTypeTypes rr!sRDATA)
        (SumType_proj ResourceRecordTypeTypes rr!sRDATA).
    intros ? H; apply H.
  Qed.
  Hint Resolve resourceRecordOK_3 : data_inv_hints.

  Lemma length_app_3 {A}
    : forall n1 n2 n3 (l1 l2 l3 : list A),
      length l1 = n1
      -> length l2 = n2
      -> length l3 = n3
      -> length (l1 ++ l2 ++ l3) = n1 + n2 + n3.
  Proof.
    intros; rewrite !app_length; subst; omega.
  Qed.
  Hint Resolve length_app_3 : data_inv_hints .

  Definition DNS_Packet_OK (data : packet) :=
    lt (|data!"answers" |) (pow2 16)
    /\ lt (|data!"authority" |) (pow2 16)
    /\ lt (|data!"additional" |) (pow2 16)
    /\ ValidDomainName (data!"question")!"qname"
    /\ forall (rr : resourceRecord),
        In rr (data!"answers" ++ data!"additional" ++ data!"authority")
        -> resourceRecord_OK rr.

  Ltac decompose_parsed_data :=
    repeat match goal with
           | H : (?x ++ ?y ++ ?z)%list = _ |- _ =>
             eapply firstn_skipn_self in H; try eassumption;
             destruct H as [? [? ?] ]
           | H : WS _ WO = _ |- _ =>
             apply (f_equal (@whd 0)) in H;
             simpl in H; rewrite H in *; clear H
           | H : length _ = _ |- _ => clear H
           end;
    subst.

  Lemma decides_resourceRecord_OK
    : forall l n m o,
      length l = n + m + o
      -> (forall x : resourceRecord, In x l -> resourceRecord_OK x)
      -> decides true
                 (forall rr : resourceRecord,
                     In rr
                        (firstn n l ++
                                firstn m (skipn n l) ++ firstn o (skipn (n + m) l)) ->
                     resourceRecord_OK rr).
  Proof.
    simpl; intros.
    rewrite firstn_skipn_self' in H1; eauto.
  Qed.

  Hint Resolve decides_resourceRecord_OK : decide_data_invariant_db .

  (* Resource Record <character-string>s are a byte, *)
  (* followed by that many characters. *)
  Definition format_characterString_Spec (s : string) :=
    format_nat 8 (String.length s)
                    ThenC format_string s
                    DoneC.

  Definition format_question_Spec (q : question) :=
    format_DomainName q!"qname"
                           ThenC format_enum QType_Ws q!"qtype"
                           ThenC format_enum QClass_Ws q!"qclass"
                           DoneC.

  Definition format_TXT_Spec (s : string) :=
    format_unused_word 16 (* Unusued RDLENGTH Field *)
                            ThenC format_characterString_Spec s
                            DoneC.

  Definition format_SOA_RDATA_Spec (soa : SOA_RDATA) :=
    format_unused_word 16 (* Unusued RDLENGTH Field *)
                            ThenC format_DomainName soa!"sourcehost"
                            ThenC format_DomainName soa!"contact_email"
                            ThenC format_word soa!"serial"
                            ThenC format_word soa!"refresh"
                            ThenC format_word soa!"retry"
                            ThenC format_word soa!"expire"
                            ThenC format_word soa!"minTTL"
                            DoneC.

  Definition format_WKS_RDATA_Spec (wks : WKS_RDATA) :=
    format_nat 16 (length (wks!"Bit-Map"))
                    ThenC format_word wks!"Address"
                    ThenC format_word wks!"Protocol"
                    ThenC (format_list format_word wks!"Bit-Map")
                    DoneC.

  Definition format_HINFO_RDATA_Spec (hinfo : HINFO_RDATA) :=
    format_unused_word 16 (* Unusued RDLENGTH Field *)
                            ThenC format_characterString_Spec hinfo!"CPU"
                            ThenC format_characterString_Spec hinfo!"OS"
                            DoneC.

  Definition format_MX_RDATA_Spec (mx : MX_RDATA) :=
    format_unused_word 16 (* Unusued RDLENGTH Field *)
                            ThenC format_word mx!"Preference"
                            ThenC format_DomainName mx!"Exchange"
                            DoneC.

  Definition format_MINFO_RDATA_Spec (minfo : MINFO_RDATA) :=
    format_unused_word 16 (* Unusued RDLENGTH Field *)
                            ThenC format_DomainName minfo!"rMailBx"
                            ThenC format_DomainName minfo!"eMailBx"
                            DoneC.

  Definition format_A_Spec (a : Memory.W) :=
    format_unused_word 16 (* Unused RDLENGTH Field *)
                            ThenC format_word a
                            DoneC.

  Definition format_NS_Spec (domain : DomainName) :=
    format_unused_word 16 (* Unused RDLENGTH Field *)
                            ThenC format_DomainName domain
                            DoneC.

  Definition format_CNAME_Spec (domain : DomainName) :=
    format_unused_word 16 (* Unused RDLENGTH Field *)
                            ThenC format_DomainName domain
                            DoneC.

  Definition format_PTR_Spec (domain : DomainName) :=
    format_unused_word 16 (* Unused RDLENGTH Field *)
                            ThenC format_DomainName domain
                            DoneC.

  Definition format_rdata_Spec :=
    format_SumType ResourceRecordTypeTypes
                        (icons (format_CNAME_Spec)  (* CNAME; canonical name for an alias 	[RFC1035] *)
                        (icons format_A_Spec (* A; host address 	[RFC1035] *)
                        (icons (format_NS_Spec) (* NS; authoritative name server 	[RFC1035] *)
                        (icons format_SOA_RDATA_Spec  (* SOA rks the start of a zone of authority 	[RFC1035] *)
                        (icons format_WKS_RDATA_Spec (* WKS  well known service description 	[RFC1035] *)
                        (icons (format_PTR_Spec) (* PTR domain name pointer 	[RFC1035] *)
                        (icons format_HINFO_RDATA_Spec (* HINFO host information 	[RFC1035] *)
                        (icons (format_MINFO_RDATA_Spec) (* MINFO mailbox or mail list information 	[RFC1035] *)
                        (icons format_MX_RDATA_Spec  (* MX  mail exchange 	[RFC1035] *)
                        (icons format_TXT_Spec inil)))))))))). (*TXT text strings 	[RFC1035] *)

  Definition format_resource_Spec(r : resourceRecord) :=
    format_DomainName r!sNAME
                           ThenC format_enum RRecordType_Ws (RDataTypeToRRecordType r!sRDATA)
                           ThenC format_enum RRecordClass_Ws r!sCLASS
                           ThenC format_word r!sTTL
                           ThenC format_rdata_Spec r!sRDATA
                           DoneC.

  Definition format_packet_Spec (p : packet) :=
    format_word p!"id"
                     ThenC format_word (WS p!"QR" WO)
                     ThenC format_enum Opcode_Ws p!"Opcode"
                     ThenC format_word (WS p!"AA" WO)
                     ThenC format_word (WS p!"TC" WO)
                     ThenC format_word (WS p!"RD" WO)
                     ThenC format_word (WS p!"RA" WO)
                     ThenC format_word (WS false (WS false (WS false WO))) (* 3 bits reserved for future use *)
                     ThenC format_enum RCODE_Ws p!"RCODE"
                     ThenC format_nat 16 1 (* length of question field *)
                     ThenC format_nat 16 (|p!"answers"|)
                     ThenC format_nat 16 (|p!"authority"|)
                     ThenC format_nat 16 (|p!"additional"|)
                     ThenC format_question_Spec p!"question"
                     ThenC (format_list format_resource_Spec (p!"answers" ++ p!"additional" ++ p!"authority"))
                     DoneC.

  Ltac decode_DNS_rules g :=
    (* Processes the goal by either: *)
    lazymatch goal with
    | |- appcontext[CorrectDecoder _ _ _ _ format_DomainName _ _ ] =>
      eapply (DomainName_decode_correct
                IndependentCaches IndependentCaches' IndependentCaches'''
                getDistinct getDistinct' addPeekSome
                boundPeekSome addPeekNone addPeekNone'
                addZeroPeek addPeekESome boundPeekESome
                addPeekENone addPeekENone' addZeroPeekE)
    | |- appcontext [CorrectDecoder _ _ _ _ (format_list format_resource_Spec) _ _] =>
      intros; apply FixList_decode_correct with (A_predicate := resourceRecord_OK)
    end.

  Definition packet_decoder
    : CorrectDecoderFor DNS_Packet_OK format_packet_Spec.
  Proof.
    synthesize_decoder_ext monoid
                           decode_DNS_rules
                           decompose_parsed_data
                           solve_GoodCache_inv.
  Defined.

  Definition packetDecoderImpl := Eval simpl in (projT1 packet_decoder).

End DnsPacket.

Print packetDecoderImpl.