(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Register allocation by external oracle and a posteriori validation. *)

Require Import FSets.
Require FSetAVLplus.
Require Import Coqlib.
Require Import Ordered.
Require Import Errors.
Require Import Maps.
Require Import Lattice.
Require Import AST.
Require Import Integers.
Require Import Memdata.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import Kildall.
Require Import Locations.
Require Import Conventions.
Require Import RTLtyping.
Require Import LTL.

(** The validation algorithm used here is described in
  "Validating register allocation and spilling",
  by Silvain Rideau and Xavier Leroy,
  in Compiler Construction (CC 2010), LNCS 6011, Springer, 2010. *)

(** * Structural checks *)

(** As a first pass, we check the LTL code returned by the external oracle
  against the original RTL code for structural conformance.
  Each RTL instruction was transformed into a LTL basic block whose
  shape must agree with the RTL instruction.  For example, if the RTL
  instruction is [Istore(Mint32, addr, args, src, s)], the LTL basic block
  must be of the following shape:
- zero, one or several "move" instructions
- a store instruction [Lstore(Mint32, addr, args', src')]
- a [Lbranch s] instruction.

  The [block_shape] type below describes all possible cases of structural
  maching between an RTL instruction and an LTL basic block.
*)

Definition moves := list (loc * loc)%type.

Inductive block_shape: Type :=
  | BSnop (mv: moves) (s: node)
  | BSmove (src: reg) (dst: reg) (mv: moves) (s: node)
  | BSmakelong (src1 src2: reg) (dst: reg) (mv: moves) (s: node)
  | BSlowlong (src: reg) (dst: reg) (mv: moves) (s: node)
  | BShighlong (src: reg) (dst: reg) (mv: moves) (s: node)
  | BSop (op: operation) (args: list reg) (res: reg)
         (mv1: moves) (args': list mreg) (res': mreg)
         (mv2: moves) (s: node)
  | BSopdead (op: operation) (args: list reg) (res: reg)
         (mv: moves) (s: node)
  | BSload (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg)
         (mv1: moves) (args': list mreg) (dst': mreg)
         (mv2: moves) (s: node)
  | BSloaddead (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg)
         (mv: moves) (s: node)
  | BSload2 (addr1 addr2: addressing) (args: list reg) (dst: reg)
         (mv1: moves) (args1': list mreg) (dst1': mreg)
         (mv2: moves) (args2': list mreg) (dst2': mreg)
         (mv3: moves) (s: node)
  | BSload2_1 (addr: addressing) (args: list reg) (dst: reg)
         (mv1: moves) (args': list mreg) (dst': mreg)
         (mv2: moves) (s: node)
  | BSload2_2 (addr addr': addressing) (args: list reg) (dst: reg)
         (mv1: moves) (args': list mreg) (dst': mreg)
         (mv2: moves) (s: node)
  | BSstore (chunk: memory_chunk) (addr: addressing) (args: list reg) (src: reg)
         (mv1: moves) (args': list mreg) (src': mreg)
         (s: node)
  | BSstore2 (addr1 addr2: addressing) (args: list reg) (src: reg)
         (mv1: moves) (args1': list mreg) (src1': mreg)
         (mv2: moves) (args2': list mreg) (src2': mreg)
         (s: node)
  | BScall (sg: signature) (ros: reg + ident) (args: list reg) (res: reg)
         (mv1: moves) (ros': mreg + ident) (mv2: moves) (s: node)
  | BStailcall (sg: signature) (ros: reg + ident) (args: list reg)
         (mv1: moves) (ros': mreg + ident)
  | BSbuiltin (ef: external_function) (args: list reg) (res: reg)
         (mv1: moves) (args': list mreg) (res': list mreg)
         (mv2: moves) (s: node)
  | BSannot (text: ident) (targs: list annot_arg) (args: list reg) (res: reg)
         (mv: moves) (args': list loc) (s: node)
  | BScond (cond: condition) (args: list reg)
         (mv: moves) (args': list mreg) (s1 s2: node)
  | BSjumptable (arg: reg)
         (mv: moves) (arg': mreg) (tbl: list node)
  | BSreturn (arg: option reg)
         (mv: moves).

(** Extract the move instructions at the beginning of block [b].
  Return the list of moves and the suffix of [b] after the moves. *)

Fixpoint extract_moves (accu: moves) (b: bblock) {struct b} : moves * bblock :=
  match b with
  | Lgetstack sl ofs ty dst :: b' =>
      extract_moves ((S sl ofs ty, R dst) :: accu) b'
  | Lsetstack src sl ofs ty :: b' =>
      extract_moves ((R src, S sl ofs ty) :: accu) b'
  | Lop op args res :: b' =>
      match is_move_operation op args with
      | Some arg => extract_moves ((R arg, R res) :: accu) b'
      | None => (List.rev accu, b)
      end
  | _ =>
      (List.rev accu, b)
  end.

Definition check_succ (s: node) (b: LTL.bblock) : bool :=
  match b with
  | Lbranch s' :: _ => peq s s'
  | _ => false
  end.

Notation "'do' X <- A ; B" := (match A with Some X => B | None => None end)
         (at level 200, X ident, A at level 100, B at level 200)
         : option_monad_scope.

Notation "'assertion' A ; B" := (if A then B else None)
         (at level 200, A at level 100, B at level 200)
         : option_monad_scope.

Local Open Scope option_monad_scope.

(** Classify operations into moves, 64-bit integer operations, and other
  arithmetic/logical operations. *)

Inductive operation_kind: operation -> list reg -> Type :=
  | operation_Omove: forall arg, operation_kind Omove (arg :: nil)
  | operation_Omakelong: forall arg1 arg2, operation_kind Omakelong (arg1 :: arg2 :: nil)
  | operation_Olowlong: forall arg, operation_kind Olowlong (arg :: nil)
  | operation_Ohighlong: forall arg, operation_kind Ohighlong (arg :: nil)
  | operation_other: forall op args, operation_kind op args.

Definition classify_operation (op: operation) (args: list reg) : operation_kind op args :=
  match op, args with
  | Omove, arg::nil => operation_Omove arg
  | Omakelong, arg1::arg2::nil => operation_Omakelong arg1 arg2
  | Olowlong, arg::nil => operation_Olowlong arg
  | Ohighlong, arg::nil => operation_Ohighlong arg
  | op, args => operation_other op args
  end.

(** Check RTL instruction [i] against LTL basic block [b].
  On success, return [Some] with a [block_shape] describing the correspondence.
  On error, return [None]. *)

Definition pair_instr_block
               (i: RTL.instruction) (b: LTL.bblock) : option block_shape :=
  match i with
  | Inop s =>
      let (mv, b1) := extract_moves nil b in
      assertion (check_succ s b1); Some(BSnop mv s)
  | Iop op args res s =>
      match classify_operation op args with
      | operation_Omove arg =>
          let (mv, b1) := extract_moves nil b in
          assertion (check_succ s b1); Some(BSmove arg res mv s)
      | operation_Omakelong arg1 arg2 =>
          let (mv, b1) := extract_moves nil b in
          assertion (check_succ s b1); Some(BSmakelong arg1 arg2 res mv s)
      | operation_Olowlong arg =>
          let (mv, b1) := extract_moves nil b in
          assertion (check_succ s b1); Some(BSlowlong arg res mv s)
      | operation_Ohighlong arg =>
          let (mv, b1) := extract_moves nil b in
          assertion (check_succ s b1); Some(BShighlong arg res mv s)
      | operation_other _ _ =>
          let (mv1, b1) := extract_moves nil b in
          match b1 with
          | Lop op' args' res' :: b2 =>
              let (mv2, b3) := extract_moves nil b2 in
              assertion (eq_operation op op');
              assertion (check_succ s b3);
              Some(BSop op args res mv1 args' res' mv2 s)
          | _ =>
              assertion (check_succ s b1);
              Some(BSopdead op args res mv1 s)
          end
      end
  | Iload chunk addr args dst s =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lload chunk' addr' args' dst' :: b2 =>
          if chunk_eq chunk Mint64 then
            assertion (chunk_eq chunk' Mint32);
            let (mv2, b3) := extract_moves nil b2 in
            match b3 with
            | Lload chunk'' addr'' args'' dst'' :: b4 =>
                let (mv3, b5) := extract_moves nil b4 in
                assertion (chunk_eq chunk'' Mint32);
                assertion (eq_addressing addr addr');
                assertion (option_eq eq_addressing (offset_addressing addr (Int.repr 4)) (Some addr''));
                assertion (check_succ s b5);
                Some(BSload2 addr addr'' args dst mv1 args' dst' mv2 args'' dst'' mv3 s)
            | _ =>
                assertion (check_succ s b3);
                if (eq_addressing addr addr') then
                  Some(BSload2_1 addr args dst mv1 args' dst' mv2 s)
                else
                 (assertion (option_eq eq_addressing (offset_addressing addr (Int.repr 4)) (Some addr'));
                  Some(BSload2_2 addr addr' args dst mv1 args' dst' mv2 s))
            end
          else (
            let (mv2, b3) := extract_moves nil b2 in
            assertion (chunk_eq chunk chunk');
            assertion (eq_addressing addr addr');
            assertion (check_succ s b3);
            Some(BSload chunk addr args dst mv1 args' dst' mv2 s))
      | _ =>
          assertion (check_succ s b1);
          Some(BSloaddead chunk addr args dst mv1 s)
      end
  | Istore chunk addr args src s =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lstore chunk' addr' args' src' :: b2 =>
          if chunk_eq chunk Mint64 then
            let (mv2, b3) := extract_moves nil b2 in
            match b3 with
            | Lstore chunk'' addr'' args'' src'' :: b4 =>
                assertion (chunk_eq chunk' Mint32);
                assertion (chunk_eq chunk'' Mint32);
                assertion (eq_addressing addr addr');
                assertion (option_eq eq_addressing (offset_addressing addr (Int.repr 4)) (Some addr''));
                assertion (check_succ s b4);
                Some(BSstore2 addr addr'' args src mv1 args' src' mv2 args'' src'' s)
            | _ => None
            end
          else (
            assertion (chunk_eq chunk chunk');
            assertion (eq_addressing addr addr');
            assertion (check_succ s b2);
            Some(BSstore chunk addr args src mv1 args' src' s))
      | _ => None
      end
  | Icall sg ros args res s =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lcall sg' ros' :: b2 =>
          let (mv2, b3) := extract_moves nil b2 in
          assertion (signature_eq sg sg');
          assertion (check_succ s b3);
          Some(BScall sg ros args res mv1 ros' mv2 s)
      | _ => None
      end
  | Itailcall sg ros args =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Ltailcall sg' ros' :: b2 =>
          assertion (signature_eq sg sg');
          Some(BStailcall sg ros args mv1 ros')
      | _ => None
      end
  | Ibuiltin ef args res s =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lbuiltin ef' args' res' :: b2 =>
          let (mv2, b3) := extract_moves nil b2 in
          assertion (external_function_eq ef ef');
          assertion (check_succ s b3);
          Some(BSbuiltin ef args res mv1 args' res' mv2 s)
      | Lannot ef' args' :: b2 =>
          assertion (external_function_eq ef ef');
          assertion (check_succ s b2);
          match ef with
          | EF_annot txt typ => Some(BSannot txt typ args res mv1 args' s)
          | _ => None
          end
      | _ => None
      end
  | Icond cond args s1 s2 =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lcond cond' args' s1' s2' :: b2 =>
          assertion (eq_condition cond cond');
          assertion (peq s1 s1');
          assertion (peq s2 s2');
          Some(BScond cond args mv1 args' s1 s2)
      | _ => None
      end
  | Ijumptable arg tbl =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Ljumptable arg' tbl' :: b2 =>
          assertion (list_eq_dec peq tbl tbl');
          Some(BSjumptable arg mv1 arg' tbl)
      | _ => None
      end
  | Ireturn arg =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lreturn :: b2 => Some(BSreturn arg mv1)
      | _ => None
      end
  end.

(** Check all instructions of the RTL function [f1] against the corresponding
  basic blocks of LTL function [f2].  Return a map from CFG nodes to
  [block_shape] info. *)

Definition pair_codes (f1: RTL.function) (f2: LTL.function) : PTree.t block_shape :=
  PTree.combine
    (fun opti optb => do i <- opti; do b <- optb; pair_instr_block i b)
    (RTL.fn_code f1) (LTL.fn_code f2).

(** Check the entry point code of the LTL function [f2].  It must be
  a sequence of moves that branches to the same node as the entry point
  of RTL function [f1]. *)

Definition pair_entrypoints (f1: RTL.function) (f2: LTL.function) : option moves :=
  do b <- (LTL.fn_code f2)!(LTL.fn_entrypoint f2);
  let (mv, b1) := extract_moves nil b in
  assertion (check_succ (RTL.fn_entrypoint f1) b1);
  Some mv.

(** * Representing sets of equations between RTL registers and LTL locations. *)

(** The Rideau-Leroy validation algorithm manipulates sets of equations of
  the form [pseudoreg = location [kind]], meaning:
- if [kind = Full], the value of [location] in the generated LTL code is
  the same as (or more defined than) the value of [pseudoreg] in the original
  RTL code;
- if [kind = Low], the value of [location] in the generated LTL code is
  the same as (or more defined than) the low 32 bits of the 64-bit
  integer value of [pseudoreg] in the original RTL code;
- if [kind = High], the value of [location] in the generated LTL code is
  the same as (or more defined than) the high 32 bits of the 64-bit
  integer value of [pseudoreg] in the original RTL code.
*)

Inductive equation_kind : Type := Full | Low | High.

Record equation := Eq {
  ekind: equation_kind;
  ereg: reg;
  eloc: loc
}.

(** We use AVL finite sets to represent sets of equations.  Therefore, we need
  total orders over equations and their components. *)

Module IndexedEqKind <: INDEXED_TYPE.
  Definition t := equation_kind.
  Definition index (x: t) :=
    match x with Full => 1%positive | Low => 2%positive | High => 3%positive end.
  Lemma index_inj: forall x y, index x = index y -> x = y.
  Proof. destruct x; destruct y; simpl; congruence. Qed.
  Definition eq (x y: t) : {x=y} + {x<>y}.
  Proof. decide equality. Defined.
End IndexedEqKind.

Module OrderedEqKind := OrderedIndexed(IndexedEqKind).

(** This is an order over equations that is lexicgraphic on [ereg], then
  [eloc], then [ekind]. *)

Module OrderedEquation <: OrderedType.
  Definition t := equation.
  Definition eq (x y: t) := x = y.
  Definition lt (x y: t) :=
    Plt (ereg x) (ereg y) \/ (ereg x = ereg y /\
    (OrderedLoc.lt (eloc x) (eloc y) \/ (eloc x = eloc y /\
    OrderedEqKind.lt (ekind x) (ekind y)))).
  Lemma eq_refl : forall x : t, eq x x.
  Proof (@refl_equal t).
  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
  Proof (@sym_equal t).
  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Proof (@trans_equal t).
  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    unfold lt; intros.
    destruct H.
    destruct H0. left; eapply Plt_trans; eauto.
    destruct H0. rewrite <- H0. auto.
    destruct H. rewrite H.
    destruct H0. auto.
    destruct H0. right; split; auto.
    intuition.
    left; eapply OrderedLoc.lt_trans; eauto.
    left; congruence.
    left; congruence.
    right; split. congruence. eapply OrderedEqKind.lt_trans; eauto.
  Qed.
  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    unfold lt, eq; intros; red; intros. subst y. intuition.
    eelim Plt_strict; eauto.
    eelim OrderedLoc.lt_not_eq; eauto. red; auto.
    eelim OrderedEqKind.lt_not_eq; eauto. red; auto.
  Qed.
  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    intros.
    destruct (OrderedPositive.compare (ereg x) (ereg y)).
  - apply LT. red; auto.
  - destruct (OrderedLoc.compare (eloc x) (eloc y)).
    + apply LT. red; auto.
    + destruct (OrderedEqKind.compare (ekind x) (ekind y)).
      * apply LT. red; auto.
      * apply EQ. red in e; red in e0; red in e1; red.
        destruct x; destruct y; simpl in *; congruence.
      * apply GT. red; auto.
   + apply GT. red; auto.
  - apply GT. red; auto.
  Defined.
  Definition eq_dec (x y: t) : {x = y} + {x <> y}.
  Proof.
    intros. decide equality.
    apply Loc.eq.
    apply peq.
    apply IndexedEqKind.eq.
  Defined.
End OrderedEquation.

(** This is an alternate order over equations that is lexicgraphic on
  [eloc], then [ereg], then [ekind]. *)

Module OrderedEquation' <: OrderedType.
  Definition t := equation.
  Definition eq (x y: t) := x = y.
  Definition lt (x y: t) :=
    OrderedLoc.lt (eloc x) (eloc y) \/ (eloc x = eloc y /\
    (Plt (ereg x) (ereg y) \/ (ereg x = ereg y /\
    OrderedEqKind.lt (ekind x) (ekind y)))).
  Lemma eq_refl : forall x : t, eq x x.
  Proof (@refl_equal t).
  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
  Proof (@sym_equal t).
  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Proof (@trans_equal t).
  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    unfold lt; intros.
    destruct H.
    destruct H0. left; eapply OrderedLoc.lt_trans; eauto.
    destruct H0. rewrite <- H0. auto.
    destruct H. rewrite H.
    destruct H0. auto.
    destruct H0. right; split; auto.
    intuition.
    left; eapply Plt_trans; eauto.
    left; congruence.
    left; congruence.
    right; split. congruence. eapply OrderedEqKind.lt_trans; eauto.
  Qed.
  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    unfold lt, eq; intros; red; intros. subst y. intuition.
    eelim OrderedLoc.lt_not_eq; eauto. red; auto.
    eelim Plt_strict; eauto.
    eelim OrderedEqKind.lt_not_eq; eauto. red; auto.
  Qed.
  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    intros.
    destruct (OrderedLoc.compare (eloc x) (eloc y)).
  - apply LT. red; auto.
  - destruct (OrderedPositive.compare (ereg x) (ereg y)).
    + apply LT. red; auto.
    + destruct (OrderedEqKind.compare (ekind x) (ekind y)).
      * apply LT. red; auto.
      * apply EQ. red in e; red in e0; red in e1; red.
        destruct x; destruct y; simpl in *; congruence.
      * apply GT. red; auto.
   + apply GT. red; auto.
  - apply GT. red; auto.
  Defined.
  Definition eq_dec: forall (x y: t), {x = y} + {x <> y} := OrderedEquation.eq_dec.
End OrderedEquation'.

Module EqSet := FSetAVLplus.Make(OrderedEquation).
Module EqSet2 := FSetAVLplus.Make(OrderedEquation').

(** We use a redundant representation for sets of equations, comprising
  two AVL finite sets, containing the same elements, but ordered along
  the two orders defined above.  Playing on properties of lexicographic
  orders, this redundant representation enables us to quickly find
  all equations involving a given RTL pseudoregister, or all equations
  involving a given LTL location or overlapping location. *)

Record eqs := mkeqs {
  eqs1 :> EqSet.t;
  eqs2 : EqSet2.t;
  eqs_same: forall q, EqSet2.In q eqs2 <-> EqSet.In q eqs1
}.

(** * Operations on sets of equations *)

(** The empty set of equations. *)

Program Definition empty_eqs := mkeqs EqSet.empty EqSet2.empty _.
Next Obligation.
  split; intros. eelim EqSet2.empty_1; eauto. eelim EqSet.empty_1; eauto.
Qed.

(** Adding or removing an equation from a set. *)

Program Definition add_equation (q: equation) (e: eqs) :=
  mkeqs (EqSet.add q (eqs1 e)) (EqSet2.add q (eqs2 e)) _.
Next Obligation.
  split; intros.
  destruct (OrderedEquation'.eq_dec q q0).
  apply EqSet.add_1; auto.
  apply EqSet.add_2. apply (eqs_same e). apply EqSet2.add_3 with q; auto.
  destruct (OrderedEquation.eq_dec q q0).
  apply EqSet2.add_1; auto.
  apply EqSet2.add_2. apply (eqs_same e). apply EqSet.add_3 with q; auto.
Qed.

Program Definition remove_equation (q: equation) (e: eqs) :=
  mkeqs (EqSet.remove q (eqs1 e)) (EqSet2.remove q (eqs2 e)) _.
Next Obligation.
  split; intros.
  destruct (OrderedEquation'.eq_dec q q0).
  eelim EqSet2.remove_1; eauto.
  apply EqSet.remove_2; auto. apply (eqs_same e). apply EqSet2.remove_3 with q; auto.
  destruct (OrderedEquation.eq_dec q q0).
  eelim EqSet.remove_1; eauto.
  apply EqSet2.remove_2; auto. apply (eqs_same e). apply EqSet.remove_3 with q; auto.
Qed.

(** [reg_unconstrained r e] is true if [e] contains no equations involving
  the RTL pseudoregister [r].  In other words, all equations [r' = l [kind]]
  in [e] are such that [r' <> r]. *)

Definition select_reg_l (r: reg) (q: equation) := Pos.leb r (ereg q).
Definition select_reg_h (r: reg) (q: equation) := Pos.leb (ereg q) r.

Definition reg_unconstrained (r: reg) (e: eqs) : bool :=
  negb (EqSet.mem_between (select_reg_l r) (select_reg_h r) (eqs1 e)).

(** [loc_unconstrained l e] is true if [e] contains no equations involving
  the LTL location [l] or a location that partially overlaps with [l].
  In other words, all equations [r = l' [kind]] in [e] are such that
  [Loc.diff l' l]. *)

Definition select_loc_l (l: loc) :=
  let lb := OrderedLoc.diff_low_bound l in
  fun (q: equation) => match OrderedLoc.compare (eloc q) lb with LT _ => false | _ => true end.
Definition select_loc_h (l: loc) :=
  let lh := OrderedLoc.diff_high_bound l in
  fun (q: equation) => match OrderedLoc.compare (eloc q) lh with GT _ => false | _ => true end.

Definition loc_unconstrained (l: loc) (e: eqs) : bool :=
  negb (EqSet2.mem_between (select_loc_l l) (select_loc_h l) (eqs2 e)).

Definition reg_loc_unconstrained (r: reg) (l: loc) (e: eqs) : bool :=
  reg_unconstrained r e && loc_unconstrained l e.

(** [subst_reg r1 r2 e] simulates the effect of assigning [r2] to [r1] on [e].
  All equations of the form [r1 = l [kind]] are replaced by [r2 = l [kind]].
*)

Definition subst_reg (r1 r2: reg) (e: eqs) : eqs :=
  EqSet.fold
    (fun q e => add_equation (Eq (ekind q) r2 (eloc q)) (remove_equation q e))
    (EqSet.elements_between (select_reg_l r1) (select_reg_h r1) (eqs1 e))
    e.

(** [subst_reg_kind r1 k1 r2 k2 e] simulates the effect of assigning
  the [k2] part of [r2] to the [k1] part of [r1] on [e].
  All equations of the form [r1 = l [k1]] are replaced by [r2 = l [k2]].
*)

Definition subst_reg_kind (r1: reg) (k1: equation_kind) (r2: reg) (k2: equation_kind) (e: eqs) : eqs :=
  EqSet.fold
    (fun q e =>
      if IndexedEqKind.eq (ekind q) k1
      then add_equation (Eq k2 r2 (eloc q)) (remove_equation q e)
      else e)
    (EqSet.elements_between (select_reg_l r1) (select_reg_h r1) (eqs1 e))
    e.

(** [subst_loc l1 l2 e] simulates the effect of assigning [l2] to [l1] on [e].
  All equations of the form [r = l1 [kind]] are replaced by [r = l2 [kind]].
  Return [None] if [e] contains an equation of the form [r = l] with [l]
  partially overlapping [l1].
*)

Definition subst_loc (l1 l2: loc) (e: eqs) : option eqs :=
  EqSet2.fold
    (fun q opte =>
      match opte with
      | None => None
      | Some e =>
          if Loc.eq l1 (eloc q) then
            Some (add_equation (Eq (ekind q) (ereg q) l2) (remove_equation q e))
          else
            None
      end)
     (EqSet2.elements_between (select_loc_l l1) (select_loc_h l1) (eqs2 e))
     (Some e).

(** [loc_type_compat env l e] checks that for all equations [r = l] in [e],
  the type [env r] of [r] is compatible with the type of [l]. *)

Definition sel_type (k: equation_kind) (ty: typ) : typ :=
  match k with
  | Full => ty
  | Low | High => Tint
  end.

Definition loc_type_compat (env: regenv) (l: loc) (e: eqs) : bool :=
  EqSet2.for_all_between
    (fun q => subtype (sel_type (ekind q) (env (ereg q))) (Loc.type l))
    (select_loc_l l) (select_loc_h l) (eqs2 e).

(** [add_equations [r1...rN] [m1...mN] e] adds to [e] the [N] equations
    [ri = R mi [Full]].  Return [None] if the two lists have different lengths.
*)

Fixpoint add_equations (rl: list reg) (ml: list mreg) (e: eqs) : option eqs :=
  match rl, ml with
  | nil, nil => Some e
  | r1 :: rl, m1 :: ml => add_equations rl ml (add_equation (Eq Full r1 (R m1)) e)
  | _, _ => None
  end.

(** [add_equations_args] is similar but additionally handles the splitting
  of pseudoregisters of type [Tlong] in two locations containing the
  two 32-bit halves of the 64-bit integer. *)

Function add_equations_args (rl: list reg) (tyl: list typ) (ll: list loc) (e: eqs) : option eqs :=
  match rl, tyl, ll with
  | nil, nil, nil => Some e
  | r1 :: rl, Tlong :: tyl, l1 :: l2 :: ll =>
      add_equations_args rl tyl ll (add_equation (Eq Low r1 l2) (add_equation (Eq High r1 l1) e))
  | r1 :: rl, (Tint|Tfloat|Tsingle) :: tyl, l1 :: ll =>
      add_equations_args rl tyl ll (add_equation (Eq Full r1 l1) e)
  | _, _, _ => None
  end.

(** [add_equations_res] is similar but is specialized to the case where
  there is only one pseudo-register. *)

Function add_equations_res (r: reg) (oty: option typ) (ll: list loc) (e: eqs) : option eqs :=
  match oty with
  | Some Tlong =>
      match ll with
      | l1 :: l2 :: nil => Some (add_equation (Eq Low r l2) (add_equation (Eq High r l1) e))
      | _ => None
      end
  | _ =>
      match ll with
      | l1 :: nil => Some (add_equation (Eq Full r l1) e)
      | _ => None
      end
  end.

(** [remove_equations_res] is similar to [add_equations_res] but removes
  equations instead of adding them. *)

Function remove_equations_res (r: reg) (oty: option typ) (ll: list loc) (e: eqs) : option eqs :=
  match oty with
  | Some Tlong =>
      match ll with
      | l1 :: l2 :: nil =>
          if Loc.diff_dec l2 l1
          then Some (remove_equation (Eq Low r l2) (remove_equation (Eq High r l1) e))
          else None
      | _ => None
      end
  | _ =>
      match ll with
      | l1 :: nil => Some (remove_equation (Eq Full r l1) e)
      | _ => None
      end
  end.

(** [add_equations_ros] adds an equation, if needed, between an optional
  pseudoregister and an optional machine register.  It is used for the
  function argument of the [Icall] and [Itailcall] instructions. *)

Definition add_equation_ros (ros: reg + ident) (ros': mreg + ident) (e: eqs) : option eqs :=
  match ros, ros' with
  | inl r, inl mr => Some(add_equation (Eq Full r (R mr)) e)
  | inr id, inr id' => assertion (ident_eq id id'); Some e
  | _, _ => None
  end.

(** [can_undef ml] returns true if all machine registers in [ml] are
  unconstrained and can harmlessly be undefined. *)

Fixpoint can_undef (ml: list mreg) (e: eqs) : bool :=
  match ml with
  | nil => true
  | m1 :: ml => loc_unconstrained (R m1) e && can_undef ml e
  end.

Fixpoint can_undef_except (l: loc) (ml: list mreg) (e: eqs) : bool :=
  match ml with
  | nil => true
  | m1 :: ml =>
      (Loc.eq l (R m1) || loc_unconstrained (R m1) e) && can_undef_except l ml e
  end.

(** [no_caller_saves e] returns [e] if all caller-save locations are
  unconstrained in [e].  In other words, [e] contains no equations
  involving a caller-save register or [Outgoing] stack slot. *)

Definition no_caller_saves (e: eqs) : bool :=
  EqSet.for_all
   (fun eq =>
     match eloc eq with
       | R r =>
           zle 0 (index_int_callee_save r) || zle 0 (index_float_callee_save r)
       | S Outgoing _ _ => false
       | S _ _ _ => true
       end)
    e.

(** [compat_left r l e] returns true if all equations in [e] that involve
    [r] are of the form [r = l [Full]]. *)

Definition compat_left (r: reg) (l: loc) (e: eqs) : bool :=
  EqSet.for_all_between
    (fun q =>
        match ekind q with
        | Full => Loc.eq l (eloc q)
        | _ => false
        end)
    (select_reg_l r) (select_reg_h r)
    (eqs1 e).

(** [compat_left2 r l1 l2 e] returns true if all equations in [e] that involve
    [r] are of the form [r = l1 [High]] or [r = l2 [Low]]. *)

Definition compat_left2 (r: reg) (l1 l2: loc) (e: eqs) : bool :=
  EqSet.for_all_between
    (fun q =>
        match ekind q with
        | High => Loc.eq l1 (eloc q)
        | Low => Loc.eq l2 (eloc q)
        | _ => false
        end)
    (select_reg_l r) (select_reg_h r)
    (eqs1 e).

(** [ros_compatible_tailcall ros] returns true if [ros] is a function
  name or a caller-save register.  This is used to check [Itailcall]
  instructions. *)

Definition ros_compatible_tailcall (ros: mreg + ident) : bool :=
  match ros with
  | inl r => In_dec mreg_eq r destroyed_at_call
  | inr id => true
  end.

(** * The validator *)

Definition destroyed_by_move (src dst: loc) :=
  match src, dst with
  | S sl ofs ty, _ => destroyed_by_getstack sl
  | _, S sl ofs ty => destroyed_by_setstack ty
  | _, _ => destroyed_by_op Omove
  end.

Definition well_typed_move (env: regenv) (dst: loc) (e: eqs) : bool :=
  match dst with
  | R r => true
  | S sl ofs ty => loc_type_compat env dst e
  end.

(** Simulate the effect of a sequence of moves [mv] on a set of
  equations [e].  The set [e] is the equations that must hold
  after the sequence of moves.  Return the set of equations that
  must hold before the sequence of moves.  Return [None] if the
  set of equations [e] cannot hold after the sequence of moves. *)

Fixpoint track_moves (env: regenv) (mv: moves) (e: eqs) : option eqs :=
  match mv with
  | nil => Some e
  | (src, dst) :: mv =>
      do e1 <- track_moves env mv e;
      assertion (can_undef_except dst (destroyed_by_move src dst)) e1;
      assertion (well_typed_move env dst e1);
      subst_loc dst src e1
  end.

(** [transfer_use_def args res args' res' undefs e] returns the set
  of equations that must hold "before" in order for the equations [e]
  to hold "after" the execution of RTL and LTL code of the following form:
<<
                RTL                            LTL
         use pseudoregs args            use machine registers args'
         define pseudoreg res           undefine machine registers undef
                                        define machine register res'
>>
  As usual, [None] is returned if the equations [e] cannot hold after
  this execution.
*)

Definition transfer_use_def (args: list reg) (res: reg) (args': list mreg) (res': mreg)
                            (undefs: list mreg) (e: eqs) : option eqs :=
  let e1 := remove_equation (Eq Full res (R res')) e in
  assertion (reg_loc_unconstrained res (R res') e1);
  assertion (can_undef undefs e1);
  add_equations args args' e1.

Definition kind_first_word := if big_endian then High else Low.
Definition kind_second_word := if big_endian then Low else High.

(** The core transfer function.  It takes a set [e] of equations that must
  hold "after" and a block shape [shape] representing a matching pair
  of an RTL instruction and an LTL basic block.  It returns the set of
  equations that must hold "before" these instructions, or [None] if
  impossible. *)

Definition transfer_aux (f: RTL.function) (env: regenv) (shape: block_shape) (e: eqs) : option eqs :=
  match shape with
  | BSnop mv s =>
      track_moves env mv e
  | BSmove src dst mv s =>
      track_moves env mv (subst_reg dst src e)
  | BSmakelong src1 src2 dst mv s =>
      let e1 := subst_reg_kind dst High src1 Full e in
      let e2 := subst_reg_kind dst Low src2 Full e1 in
      assertion (reg_unconstrained dst e2);
      track_moves env mv e2
  | BSlowlong src dst mv s =>
      let e1 := subst_reg_kind dst Full src Low e in
      assertion (reg_unconstrained dst e1);
      track_moves env mv e1
  | BShighlong src dst mv s =>
      let e1 := subst_reg_kind dst Full src High e in
      assertion (reg_unconstrained dst e1);
      track_moves env mv e1
  | BSop op args res mv1 args' res' mv2 s =>
      do e1 <- track_moves env mv2 e;
      do e2 <- transfer_use_def args res args' res' (destroyed_by_op op) e1;
      track_moves env mv1 e2
  | BSopdead op args res mv s =>
      assertion (reg_unconstrained res e);
      track_moves env mv e
  | BSload chunk addr args dst mv1 args' dst' mv2 s =>
      do e1 <- track_moves env mv2 e;
      do e2 <- transfer_use_def args dst args' dst' (destroyed_by_load chunk addr) e1;
      track_moves env mv1 e2
  | BSload2 addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s =>
      do e1 <- track_moves env mv3 e;
      let e2 := remove_equation (Eq kind_second_word dst (R dst2')) e1 in
      assertion (loc_unconstrained (R dst2') e2);
      assertion (can_undef (destroyed_by_load Mint32 addr') e2);
      do e3 <- add_equations args args2' e2;
      do e4 <- track_moves env mv2 e3;
      let e5 := remove_equation (Eq kind_first_word dst (R dst1')) e4 in
      assertion (loc_unconstrained (R dst1') e5);
      assertion (can_undef (destroyed_by_load Mint32 addr) e5);
      assertion (reg_unconstrained dst e5);
      do e6 <- add_equations args args1' e5;
      track_moves env mv1 e6
  | BSload2_1 addr args dst mv1 args' dst' mv2 s =>
      do e1 <- track_moves env mv2 e;
      let e2 := remove_equation (Eq kind_first_word dst (R dst')) e1 in
      assertion (reg_loc_unconstrained dst (R dst') e2);
      assertion (can_undef (destroyed_by_load Mint32 addr) e2);
      do e3 <- add_equations args args' e2;
      track_moves env mv1 e3
  | BSload2_2 addr addr' args dst mv1 args' dst' mv2 s =>
      do e1 <- track_moves env mv2 e;
      let e2 := remove_equation (Eq kind_second_word dst (R dst')) e1 in
      assertion (reg_loc_unconstrained dst (R dst') e2);
      assertion (can_undef (destroyed_by_load Mint32 addr') e2);
      do e3 <- add_equations args args' e2;
      track_moves env mv1 e3
  | BSloaddead chunk addr args dst mv s =>
      assertion (reg_unconstrained dst e);
      track_moves env mv e
  | BSstore chunk addr args src mv args' src' s =>
      assertion (can_undef (destroyed_by_store chunk addr) e);
      do e1 <- add_equations (src :: args) (src' :: args') e;
      track_moves env mv e1
  | BSstore2 addr addr' args src mv1 args1' src1' mv2 args2' src2' s =>
      assertion (can_undef (destroyed_by_store Mint32 addr') e);
      do e1 <- add_equations args args2'
                  (add_equation (Eq kind_second_word src (R src2')) e);
      do e2 <- track_moves env mv2 e1;
      assertion (can_undef (destroyed_by_store Mint32 addr) e2);
      do e3 <- add_equations args args1'
                  (add_equation (Eq kind_first_word src (R src1')) e2);
      track_moves env mv1 e3
  | BScall sg ros args res mv1 ros' mv2 s =>
      let args' := loc_arguments sg in
      let res' := map R (loc_result sg) in
      do e1 <- track_moves env mv2 e;
      do e2 <- remove_equations_res res (sig_res sg) res' e1;
      assertion (forallb (fun l => reg_loc_unconstrained res l e2) res');
      assertion (no_caller_saves e2);
      do e3 <- add_equation_ros ros ros' e2;
      do e4 <- add_equations_args args (sig_args sg) args' e3;
      track_moves env mv1 e4
  | BStailcall sg ros args mv1 ros' =>
      let args' := loc_arguments sg in
      assertion (tailcall_is_possible sg);
      assertion (opt_typ_eq sg.(sig_res) f.(RTL.fn_sig).(sig_res));
      assertion (ros_compatible_tailcall ros');
      do e1 <- add_equation_ros ros ros' empty_eqs;
      do e2 <- add_equations_args args (sig_args sg) args' e1;
      track_moves env mv1 e2
  | BSbuiltin ef args res mv1 args' res' mv2 s =>
      do e1 <- track_moves env mv2 e;
      let args' := map R args' in
      let res' := map R res' in
      do e2 <- remove_equations_res res (sig_res (ef_sig ef)) res' e1;
      assertion (reg_unconstrained res e2);
      assertion (forallb (fun l => loc_unconstrained l e2) res');
      assertion (can_undef (destroyed_by_builtin ef) e2);
      do e3 <- add_equations_args args (sig_args (ef_sig ef)) args' e2;
      track_moves env mv1 e3
  | BSannot txt typ args res mv1 args' s =>
      do e1 <- add_equations_args args (annot_args_typ typ) args' e;
      track_moves env mv1 e1
  | BScond cond args mv args' s1 s2 =>
      assertion (can_undef (destroyed_by_cond cond) e);
      do e1 <- add_equations args args' e;
      track_moves env mv e1
  | BSjumptable arg mv arg' tbl =>
      assertion (can_undef destroyed_by_jumptable e);
      track_moves env mv (add_equation (Eq Full arg (R arg')) e)
  | BSreturn None mv =>
      track_moves env mv empty_eqs
  | BSreturn (Some arg) mv =>
      let arg' := map R (loc_result (RTL.fn_sig f)) in
      do e1 <- add_equations_res arg (sig_res (RTL.fn_sig f)) arg' empty_eqs;
      track_moves env mv e1
  end.

(** The main transfer function for the dataflow analysis.  Like [transfer_aux],
  it infers the equations that must hold "before" as a function of the
  equations that must hold "after".  It also handles error propagation
  and reporting. *)

Definition transfer (f: RTL.function) (env: regenv) (shapes: PTree.t block_shape)
                    (pc: node) (after: res eqs) : res eqs :=
  match after with
  | Error _ => after
  | OK e =>
      match shapes!pc with
      | None => Error(MSG "At PC " :: POS pc :: MSG ": unmatched block" :: nil)
      | Some shape =>
          match transfer_aux f env shape e with
          | None => Error(MSG "At PC " :: POS pc :: MSG ": invalid register allocation" :: nil)
          | Some e' => OK e'
          end
      end
  end.

(** The semilattice for dataflow analysis.  Operates on analysis results
  of type [res eqs], that is, either a set of equations or an error
  message.  Errors correspond to [Top].  Sets of equations are ordered
  by inclusion. *)

Module LEq <: SEMILATTICE.

  Definition t := res eqs.

  Definition eq (x y: t) :=
    match x, y with
    | OK a, OK b => EqSet.Equal a b
    | Error _, Error _ => True
    | _, _ => False
    end.

  Lemma eq_refl: forall x, eq x x.
  Proof.
    intros; destruct x; simpl; auto. red; tauto.
  Qed.

  Lemma eq_sym: forall x y, eq x y -> eq y x.
  Proof.
    unfold eq; intros; destruct x; destruct y; auto.
    red in H; red; intros. rewrite H; tauto.
  Qed.

  Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
  Proof.
    unfold eq; intros. destruct x; destruct y; try contradiction; destruct z; auto.
    red in H; red in H0; red; intros. rewrite H. auto.
  Qed.

  Definition beq (x y: t) :=
    match x, y with
    | OK a, OK b => EqSet.equal a b
    | Error _, Error _ => true
    | _, _ => false
    end.

  Lemma beq_correct: forall x y, beq x y = true -> eq x y.
  Proof.
    unfold beq, eq; intros. destruct x; destruct y.
    apply EqSet.equal_2. auto.
    discriminate.
    discriminate.
    auto.
  Qed.

  Definition ge (x y: t) :=
    match x, y with
    | OK a, OK b => EqSet.Subset b a
    | Error _, _ => True
    | _, Error _ => False
    end.

  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    unfold eq, ge, EqSet.Equal, EqSet.Subset; intros.
    destruct x; destruct y; auto. intros; rewrite H; auto.
  Qed.
  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    unfold ge, EqSet.Subset; intros.
    destruct x; auto; destruct y; try contradiction.
    destruct z; eauto.
  Qed.

  Definition bot: t := OK empty_eqs.

  Lemma ge_bot: forall x, ge x bot.
  Proof.
    unfold ge, bot, EqSet.Subset; simpl; intros.
    destruct x; auto. intros. elim (EqSet.empty_1 H).
  Qed.

  Program Definition lub (x y: t) : t :=
    match x, y return _ with
    | OK a, OK b =>
        OK (mkeqs (EqSet.union (eqs1 a) (eqs1 b))
                  (EqSet2.union (eqs2 a) (eqs2 b)) _)
    | OK _, Error _ => y
    | Error _, _ => x
    end.
  Next Obligation.
    split; intros.
    apply EqSet2.union_1 in H. destruct H; rewrite eqs_same in H.
    apply EqSet.union_2; auto. apply EqSet.union_3; auto.
    apply EqSet.union_1 in H. destruct H; rewrite <- eqs_same in H.
    apply EqSet2.union_2; auto. apply EqSet2.union_3; auto.
  Qed.

  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof.
    unfold lub, ge, EqSet.Subset; intros.
    destruct x; destruct y; auto.
    intros; apply EqSet.union_2; auto.
  Qed.

  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof.
    unfold lub, ge, EqSet.Subset; intros.
    destruct x; destruct y; auto.
    intros; apply EqSet.union_3; auto.
  Qed.

End LEq.

(** The backward dataflow solver is an instantiation of Kildall's algorithm. *)

Module DS := Backward_Dataflow_Solver(LEq)(NodeSetBackward).

(** The control-flow graph that the solver operates on is the CFG of
  block shapes built by the structural check phase.  Here is its notion
  of successors. *)

Definition successors_block_shape (bsh: block_shape) : list node :=
  match bsh with
  | BSnop mv s => s :: nil
  | BSmove src dst mv s => s :: nil
  | BSmakelong src1 src2 dst mv s => s :: nil
  | BSlowlong src dst mv s => s :: nil
  | BShighlong src dst mv s => s :: nil
  | BSop op args res mv1 args' res' mv2 s => s :: nil
  | BSopdead op args res mv s => s :: nil
  | BSload chunk addr args dst mv1 args' dst' mv2 s => s :: nil
  | BSload2 addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s => s :: nil
  | BSload2_1 addr args dst mv1 args' dst' mv2 s => s :: nil
  | BSload2_2 addr addr' args dst mv1 args' dst' mv2 s => s :: nil
  | BSloaddead chunk addr args dst mv s => s :: nil
  | BSstore chunk addr args src mv1 args' src' s => s :: nil
  | BSstore2 addr addr' args src mv1 args1' src1' mv2 args2' src2' s => s :: nil
  | BScall sg ros args res mv1 ros' mv2 s => s :: nil
  | BStailcall sg ros args mv1 ros' => nil
  | BSbuiltin ef args res mv1 args' res' mv2 s => s :: nil
  | BSannot txt typ args res mv1 args' s => s :: nil
  | BScond cond args mv args' s1 s2 => s1 :: s2 :: nil
  | BSjumptable arg mv arg' tbl => tbl
  | BSreturn optarg mv => nil
  end.

Definition analyze (f: RTL.function) (env: regenv) (bsh: PTree.t block_shape) :=
  DS.fixpoint bsh successors_block_shape (transfer f env bsh) nil.

(** * Validating and translating functions and programs *)

(** Checking equations at function entry point.  The RTL function receives
  its arguments in the list [rparams] of pseudoregisters.  The LTL function
  receives them in the list [lparams] of locations dictated by the
  calling conventions, with arguments of type [Tlong] being split in
  two 32-bit halves.  We check that the equations [e] that must hold
  at the beginning of the functions are compatible with these calling
  conventions, in the sense that all equations involving a pseudoreg
  [r] from [rparams] is of the form [r = l [Full]] or [r = l [Low]]
  or [r = l [High]], where [l] is the corresponding element of [lparams].

  Note that [e] can contain additional equations [r' = l [kind]]
  involving pseudoregs [r'] not in [rparams]: these equations are
  automatically satisfied since the initial value of [r'] is [Vundef]. *)

Function compat_entry (rparams: list reg) (tys: list typ) (lparams: list loc) (e: eqs)
                      {struct rparams} : bool :=
  match rparams, tys, lparams with
  | nil, nil, nil => true
  | r1 :: rl, Tlong :: tyl, l1 :: l2 :: ll =>
      compat_left2 r1 l1 l2 e && compat_entry rl tyl ll e
  | r1 :: rl, (Tint|Tfloat|Tsingle) :: tyl, l1 :: ll =>
      compat_left r1 l1 e && compat_entry rl tyl ll e
  | _, _, _ => false
  end.

(** Checking the satisfiability of equations inferred at function entry
  point.  We also check that the RTL and LTL functions agree in signature
  and stack size. *)

Definition check_entrypoints_aux (rtl: RTL.function) (ltl: LTL.function)
                                 (env: regenv) (e1: eqs) : option unit :=
  do mv <- pair_entrypoints rtl ltl;
  do e2 <- track_moves env mv e1;
  assertion (compat_entry (RTL.fn_params rtl)
                          (sig_args (RTL.fn_sig rtl))
                          (loc_parameters (RTL.fn_sig rtl)) e2);
  assertion (can_undef destroyed_at_function_entry e2);
  assertion (zeq (RTL.fn_stacksize rtl) (LTL.fn_stacksize ltl));
  assertion (signature_eq (RTL.fn_sig rtl) (LTL.fn_sig ltl));
  Some tt.

Local Close Scope option_monad_scope.
Local Open Scope error_monad_scope.

Definition check_entrypoints (rtl: RTL.function) (ltl: LTL.function)
                             (env: regenv) (bsh: PTree.t block_shape)
                             (a: PMap.t LEq.t): res unit :=
  do e1 <- transfer rtl env bsh (RTL.fn_entrypoint rtl) a!!(RTL.fn_entrypoint rtl);
  match check_entrypoints_aux rtl ltl env e1 with
  | None => Error (msg "invalid register allocation at entry point")
  | Some _ => OK tt
  end.

(** Putting it all together, this is the validation function for
  a source RTL function and an LTL function generated by the external
  register allocator. *)

Definition check_function (rtl: RTL.function) (ltl: LTL.function) (env: regenv) : res unit :=
  let bsh := pair_codes rtl ltl in
  match analyze rtl env bsh with
  | None => Error (msg "allocation analysis diverges")
  | Some a => check_entrypoints rtl ltl env bsh a
  end.

(** [regalloc] is the external register allocator.  It is written in OCaml
  in file [backend/Regalloc.ml]. *)

Parameter regalloc: RTL.function -> res LTL.function.

(** Register allocation followed by validation. *)

Definition transf_function (f: RTL.function) : res LTL.function :=
  match type_function f with
  | Error m => Error m
  | OK env =>
      match regalloc f with
      | Error m => Error m
      | OK tf => do x <- check_function f tf env; OK tf
      end
  end.

Definition transf_fundef (fd: RTL.fundef) : res LTL.fundef :=
  AST.transf_partial_fundef transf_function fd.

Definition transf_program (p: RTL.program) : res LTL.program :=
  transform_partial_program transf_fundef p.


Require Import Coq.Strings.String.
Require Import
        Fiat.Computation
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Formats.Base.FMapFormat
        Fiat.Narcissus.Formats.StringOpt
        Fiat.Narcissus.Formats.Delimiter
        Fiat.Narcissus.Formats.WithTerm.String
        Fiat.Narcissus.BinLib.AlignedByteString
        Fiat.Narcissus.BinLib.AlignedEncodeMonad
        Fiat.Narcissus.BinLib.AlignedDecodeMonad
        Fiat.Narcissus.BinLib.AlignedString.

Section String.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.

  Variable addD_addD_plus :
    forall (cd : CacheDecode) (n m : nat), addD (addD cd n) m = addD cd (n + m).

  Variable addE_addE_plus :
    forall (ce : CacheFormat) (n m : nat), addE (addE ce n) m = addE ce (n + m).
  Variable addE_0 :
    forall (ce : CacheFormat), addE ce 0 = ce.

  Open Scope AlignedDecodeM_scope.

  Definition AlignedDecodeStringWithTerm {m}
             (close : string)
    : AlignedDecodeM string m.
  Admitted.

  Lemma AlignedDecodeStringWithTermM {C : Type}
        (close : string)
    : forall (t : string -> DecodeM (C * _) ByteString)
             (t' : string -> forall {numBytes}, AlignedDecodeM C numBytes),
      (forall b, DecodeMEquivAlignedDecodeM (t b) (@t' b))
      -> DecodeMEquivAlignedDecodeM
           (fun v cd => `(s, bs, cd') <- decode_string_with_term close v cd;
                      t s bs cd')
           (fun numBytes => s <- AlignedDecodeStringWithTerm close;
                          t' s).
  Proof.
  Admitted.

End String.


Require Import Lia Framework ATCDLayer File FileDiskNoninterference.
Require Import LoggedDiskRefinement LogCache.RepImplications Not_Init.
Require Import ATCD_Simulation.

Opaque LogCache.recover.
Lemma ATCD_AOE_recover:
forall l_grs u,
abstract_oracles_exist_wrt
ATCD_Refinement
(fun s1 s2 => refines_reboot (snd (snd s1)) (snd (snd s2)) /\
fst s1 = fst s2 /\
fst (snd s1)  = fst (snd s2)) u
(Simulation.Definitions.compile ATC_Refinement File.recover)
(Simulation.Definitions.compile ATC_Refinement File.recover)
(ATCD_reboot_list l_grs).
Proof.
    unfold ATCD_reboot_list,
    abstract_oracles_exist_wrt;
    induction l_grs; simpl; intros.
    { (* base case *)
      repeat invert_exec; cleanup.
      (* eapply_fresh minimal_oracle_finished_same in H7. *)
      invert_exec'' H7.
      invert_exec'' H9.
      repeat invert_exec; cleanup.
      eapply lift2_invert_exec in H12; cleanup.
      eapply lift2_invert_exec in H4; cleanup.
      repeat cleanup_pairs; eauto.
      eexists [_]; simpl.
      intuition eauto.
      left; intuition eauto.
      do 2 eexists; intuition eauto.
      repeat (rewrite cons_app;
      repeat econstructor; eauto).
      eapply lift2_exec_step.
      eapply lift2_exec_step; eauto.
      right; do 7 eexists; intuition eauto.
      3: eapply lift2_exec_step;
      eapply lift2_exec_step; eauto.
      2: simpl; repeat econstructor; eauto.
      eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      simpl; eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      left; eexists; simpl in *; intuition eauto.
      destruct t; eauto.
      eapply LogCache.recover_finished; eauto.
    }
    { (* Inductive case *)
      repeat invert_exec; cleanup.
      (* eapply_fresh exec_crashed_minimal_oracle in H10; cleanup. *)
      invert_exec'' H10; repeat invert_exec; cleanup.
      {
        invert_exec'' H8; repeat invert_exec; cleanup.
        eapply lift2_invert_exec_crashed in H13; cleanup.
        eapply lift2_invert_exec_crashed in H4; cleanup.
        repeat cleanup_pairs; eauto.

        edestruct IHl_grs; only 2: eauto.
        simpl.
        unfold refines,
        refines_reboot in *;
        simpl in *; cleanup.
        eapply LogCache.recover_crashed in H5; eauto.
        simpl in *; cleanup.
        clear H2.
        eexists (_, (_, _)); repeat split.
        repeat split_ors.
        simpl; eapply cached_log_reboot_rep_to_reboot_rep in c; eauto.
        simpl; eapply cached_log_crash_rep_during_recovery_to_reboot_rep in c; eauto.
        simpl; eapply cached_log_crash_rep_after_commit_to_reboot_rep in c; eauto.
        apply select_total_mem_synced.

      eexists (_::_);
      simpl; intuition eauto.
      eapply recovery_oracles_refine_length in H0.
      rewrite H0; eauto.
      eauto.

      right; intuition eauto.
      eexists; intuition eauto.
      rewrite cons_app.
      econstructor.
      repeat econstructor.
      repeat eapply lift2_exec_step_crashed; eauto.
      right; do 7 eexists; intuition eauto.
      3: repeat eapply lift2_exec_step_crashed; eauto.
      2: simpl; repeat econstructor; eauto.
      eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      simpl; eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      right; eexists; simpl in *; intuition eauto.
      eapply LogCache.recover_crashed; eauto.

      simpl; eauto.
    }
    {
      (* eapply exec_crashed_minimum_oracle in H5; cleanup.
      rewrite <- app_assoc. *)
      invert_exec'' H7; repeat invert_exec; cleanup.
      edestruct IHl_grs; only 2: eauto.
      simpl; eexists (_, (_, _)); simpl; split.
      eapply refines_reboot_to_refines_reboot; eauto.
      intuition eauto.

      eexists (_::_);
      simpl; intuition eauto.
      eapply recovery_oracles_refine_length in H2.
      rewrite H2; eauto.
      eauto.

      right; intuition eauto.
      eexists; intuition eauto.
      repeat econstructor; eauto.
      repeat cleanup_pairs.
      repeat econstructor; eauto.

      left; do 2 eexists; intuition eauto.
      repeat cleanup_pairs.
      repeat econstructor; eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      simpl; eauto.
    }
  }
  Unshelve.
  all: exact ATCDLang.
  Qed.

  (*
  Lemma compile_lift2_comm:
  forall u T (p: LoggedDiskLang.(prog) T) o s ret,
  LayerImplementation.exec' u o s
  (RefinementLift.compile
      (HorizontalComposition AuthenticationOperation
        TransactionCacheOperation)
      (HorizontalComposition AuthenticationOperation
        (TransactionalDiskLayer.TDCore
            FSParameters.data_length)) ATCLang AD
      (HC_Core_Refinement ATCLang AD
        TDCoreRefinement) T
      (lift_L2 AuthenticationOperation p)) ret ->

      LayerImplementation.exec' u o s
      (lift_L2 AuthenticationOperation
        (TDRefinement.(Simulation.Definitions.compile) p)) ret.
  Proof.
    induction p; simpl; intros; eauto.
    invert_exec'' H0.
    eapply IHp in H7.
    eapply H in H10.
    econstructor; eauto.
    eapply IHp in H6.
    eapply ExecBindCrash; eauto.
  Qed.

  Lemma compile_lift2_comm_rev:
  forall u T (p: TD.(prog) T) o s ret,
  LayerImplementation.exec' u o s
      (lift_L2 AuthenticationOperation
        (TDRefinement.(Simulation.Definitions.compile) p)) ret ->

  LayerImplementation.exec' u o s
  (RefinementLift.compile
      (HorizontalComposition AuthenticationOperation
        TransactionCacheOperation)
      (HorizontalComposition AuthenticationOperation
        (TransactionalDiskLayer.TDCore
            FSParameters.data_length)) ATCLang AD
      (HC_Core_Refinement ATCLang AD
        TDCoreRefinement) T
      (lift_L2 AuthenticationOperation p)) ret.
  Proof.
    induction p; simpl; intros; eauto.
    invert_exec'' H0.
    eapply IHp in H7.
    eapply H in H10.
    econstructor; eauto.
    eapply IHp in H6.
    eapply ExecBindCrash; eauto.
  Qed.
*)

Fixpoint non_colliding_selector_rec {T}
u (R: state ATCDLang -> T -> Prop) l_selector (rec: prog ATCDLang unit) l_o s1 :=
  match l_selector with
  | nil => True
  | selector :: ls =>
    match l_o with
    | nil => True
    | o::lo =>
    forall s1',
    (exists s2, R s1 s2) ->
    exec ATCDLang u o s1 rec (Crashed s1') ->
    non_colliding_selector selector (snd (snd (snd s1'))) /\
    non_colliding_selector_rec u R ls rec lo
    (ATCD_reboot_f selector s1')
    end
  end.

Definition non_colliding_selector_list {T T'}
u (R: state ATCDLang -> T -> Prop)
(Rc: state ATCDLang -> T -> Prop)
l_selector
(p: prog ATCDLang T')
(rec: prog ATCDLang unit) l_o s1 :=
match l_selector with
  | nil => True
  | selector :: ls =>
    match l_o with
    | nil => True
    | o::lo =>
    forall s1',
    (exists s2, R s1 s2) ->
    exec ATCDLang u o s1 p (Crashed s1') ->
    non_colliding_selector selector (snd (snd (snd s1'))) /\
    non_colliding_selector_rec u Rc ls rec lo
    (ATCD_reboot_f selector s1')
    end
  end.

Lemma ATCD_AOE':
forall u T (p: ATCLang.(prog) T) l_grs l_o s1 s2,

(forall o s s' r,
(exists s1, ATCD_Refinement.(Simulation.Definitions.refines) s s1) ->
exec ATCDLang u o s
(ATCD_Refinement.(Simulation.Definitions.compile) p) (Finished s' r) ->
exists oa, forall grs,
oracle_refines _ _
  ATCDLang ATCLang
  ATCD_CoreRefinement T u s p grs o oa) ->

(forall o s s',
(exists s1, ATCD_Refinement.(Simulation.Definitions.refines) s s1) ->
exec ATCDLang u o s (ATCD_Refinement.(Simulation.Definitions.compile) p) (Crashed s') ->
non_colliding_selector
  (seln l_grs 0 (fun _ : addr => 0))
  (snd (snd (snd s'))) ->
exists oa,
oracle_refines _ _
  ATCDLang ATCLang
  ATCD_CoreRefinement T u s p
  (ATCD_reboot_f (seln l_grs 0 (fun _ => 0))) o oa) ->

(forall o s s',
(exists s1, ATCD_Refinement.(Simulation.Definitions.refines) s s1) ->
exec ATCDLang u o s
(ATCD_Refinement.(Simulation.Definitions.compile) p) (Crashed s') ->
non_colliding_selector
  (seln l_grs 0 (fun _ : addr => 0))
  (snd (snd (snd s'))) ->
exists s1',
ATCD_refines_reboot (seln l_grs 0 (fun _ => 0)) s' s1') ->

non_colliding_selector_list
u (ATCD_Refinement.(Simulation.Definitions.refines))
(ATCD_Refinement.(Simulation.Definitions.refines_reboot)) l_grs
(ATCD_Refinement.(Simulation.Definitions.compile) p)
(ATCD_Refinement.(Simulation.Definitions.compile)
 (ATC_Refinement.(Simulation.Definitions.compile) File.recover))
  l_o s1 ->

abstract_oracles_exist_wrt_explicit ATCD_Refinement
  (ATCD_Refinement.(Simulation.Definitions.refines)) u p
  (ATC_Refinement.(Simulation.Definitions.compile) File.recover)
  (ATCD_reboot_list l_grs) l_o s1 s2.
Proof.
    intros; destruct l_grs; simpl; eauto.
    {
      unfold abstract_oracles_exist_wrt_explicit, ATCD_reboot_list in *;
      simpl in *; intros.
      repeat invert_exec.
      simpl.
      edestruct H; eauto.

      eexists [_]; simpl; eauto.
      split; intuition eauto.
      left; do 2 eexists; intuition eauto.
    }
    {
      unfold abstract_oracles_exist_wrt_explicit, ATC_reboot_list in *;
      simpl in *; intros.
      repeat invert_exec.
      cleanup.
      edestruct H2; eauto.
      edestruct ATCD_AOE_recover; eauto.
      {
        unfold HC_refines in *;
        simpl in *; cleanup.
        edestruct H1; eauto.
      }

      edestruct H0; eauto.

      eexists (_ :: _).
      simpl.
      intuition eauto.
      eapply recovery_oracles_refine_length in H6; eauto.
      }
Qed.

Lemma ATCD_AOE:
forall T (p: ATCLang.(prog) T) l_selector u l_o s1 s2,
not_init p ->
non_colliding_selector_list
u (ATCD_Refinement.(Simulation.Definitions.refines))
(ATCD_Refinement.(Simulation.Definitions.refines_reboot)) l_selector
(ATCD_Refinement.(Simulation.Definitions.compile) p)
(ATCD_Refinement.(Simulation.Definitions.compile)
 (ATC_Refinement.(Simulation.Definitions.compile) File.recover))
  l_o s1 ->
abstract_oracles_exist_wrt_explicit ATCD_Refinement
(Simulation.Definitions.refines ATCD_Refinement) u p
(Simulation.Definitions.compile ATC_Refinement File.recover)
(ATCD_reboot_list l_selector) l_o s1 s2.
Proof.
intros; eapply ATCD_AOE'.
{
  intros.
  eapply ATCD_oracle_refines_finished; eauto.
}
{
  intros.
  eapply ATCD_oracle_refines_crashed; eauto.
}
{
  intros; edestruct ATCD_simulation_crash; eauto.
}
eauto.
Qed.


Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Structures.Monoid.

Set Implicit Arguments.
Set Strict Implicit.

Import MonadNotation.
Local Open Scope monad_scope.

Section except.
  Variable T : Type.

  Global Instance Monad_either : Monad (sum T) :=
  { ret  := fun _ v => inr v
  ; bind := fun _ _ c1 c2 => match c1 with
                               | inl v => inl v
                               | inr v => c2 v
                             end
  }.

  Global Instance Exception_either : MonadExc T (sum T) :=
  { raise := fun _ v => inl v
  ; catch := fun _ c h => match c with
                            | inl v => h v
                            | x => x
                          end
  }.

  Variable m : Type -> Type.

  Inductive eitherT A := mkEitherT { unEitherT : m (sum T A) }.

  Variable M : Monad m.

  Global Instance Monad_eitherT : Monad eitherT :=
  { ret := fun _ x => mkEitherT (ret (inr x))
  ; bind := fun _ _ c f => mkEitherT (
      xM <- unEitherT c ;;
      match xM with
      | inl x => ret (inl x)
      | inr x => unEitherT (f x)
      end
    )
  }.

  Global Instance Exception_eitherT : MonadExc T eitherT :=
  { raise := fun _ v => mkEitherT (ret (inl v))
  ; catch := fun _ c h => mkEitherT (
      xM <- unEitherT c ;;
      match xM with
        | inl x => unEitherT (h x)
        | inr x => ret (inr x)
      end
    )
  }.

  Global Instance MonadPlus_eitherT : MonadPlus eitherT :=
  { mplus _A _B mA mB := mkEitherT (
      x <- unEitherT mA ;;
      match x with
      | inl _ =>
          y <- unEitherT mB ;;
          match y with
          | inl t => ret (inl t)
          | inr b => ret (inr (inr b))
          end
      | inr a => ret (inr (inl a))
      end
    )
  }.

  Global Instance MonadT_eitherT : MonadT eitherT m :=
  { lift := fun _ c => mkEitherT (liftM ret c) }.

  Global Instance MonadState_eitherT {T} (MS : MonadState T m) : MonadState T eitherT :=
  { get := lift get
  ; put := fun v => lift (put v)
  }.

  Global Instance MonadReader_eitherT {T} (MR : MonadReader T m) : MonadReader T eitherT :=
  { ask := lift ask
  ; local := fun _ f cmd => mkEitherT (local f (unEitherT cmd))
  }.

  Global Instance MonadWriter_eitherT {T} (Mon : Monoid T) (MW : MonadWriter Mon m) : MonadWriter Mon eitherT :=
  { tell := fun x => lift (tell x)
  ; listen := fun _ c => mkEitherT (
    x <- listen (unEitherT c) ;;
    match x with
      | (inl l, _) => ret (inl l)
      | (inr a, t) => ret (inr (a, t))
    end)
  ; pass := fun _ c => mkEitherT (
    x <- unEitherT c ;;
    match x with
      | inl s => ret (inl s)
      | inr (a,f) => pass (ret (inr a, f))
    end)
  }.

  Global Instance MonadFix_eitherT (MF : MonadFix m) : MonadFix eitherT :=
  { mfix := fun _ _ r v =>
    mkEitherT (mfix (fun f x => unEitherT (r (fun x => mkEitherT (f x)) x)) v)
  }.

End except.

Arguments mkEitherT {T} {m} {A} (_).
Arguments unEitherT {T} {m} {A} (_).


Require Import Bedrock.Platform.AutoSep.

Set Implicit Arguments.

Section TopLevel.

  Variable vars : list string.

  Variable var : option string.

  Definition is_state sp vs : HProp :=
    locals vars vs 0 (sp ^+ $8).

  Definition new_pre : assert :=
    x ~> ExX, Ex vs,
    ![^[is_state x#Sp vs] * #0]x.

  Require Import Bedrock.Platform.Cito.Semantics.

  Definition runs_to x_pre x :=
    forall specs other vs,
      interp specs (![is_state x_pre#Sp vs * other ] x_pre) ->
      Regs x Sp = x_pre#Sp /\
      interp specs (![is_state (Regs x Sp) (upd_option vs var x_pre#Rv) * other ] (fst x_pre, x)).

  Definition post (pre : assert) :=
    st ~> Ex st_pre,
    pre (fst st, st_pre) /\
    [| runs_to (fst st, st_pre) (snd st) |].

  Definition imply (pre new_pre: assert) := forall specs x, interp specs (pre x) -> interp specs (new_pre x).

  Definition syn_req :=
    match var with
      | Some x => List.In x vars
      | None => True
    end.

  Definition verifCond pre := imply pre new_pre :: syn_req :: nil.

  Variable imports : LabelMap.t assert.

  Variable imports_global : importsGlobal imports.

  Variable modName : string.

  Definition Strline := Straightline_ imports modName.

  Definition SaveRv lv := Strline (IL.Assign lv (RvLval (LvReg Rv)) :: nil).

  Definition vars_start := 4 * 2.
  Definition var_slot x := LvMem (Sp + (vars_start + variablePosition vars x)%nat)%loc.

  Definition Skip := Straightline_ imports modName nil.

  Definition body :=
    match var with
      | None => Skip
      | Some x => SaveRv (var_slot x)
    end.

  Require Import Bedrock.Platform.Wrap.

  Opaque mult.
  Opaque evalInstrs.

  Lemma evalInstrs_write_var : forall sm x s,
    evalInstrs sm x (Assign (var_slot s) Rv :: nil)
    = evalInstrs sm x (Assign (LvMem (Imm ((Regs x Sp ^+ natToW vars_start) ^+ natToW (variablePosition vars s)))) Rv :: nil).
    Transparent evalInstrs.
    simpl.
    intros.
    replace (Regs x Sp ^+ natToW (vars_start + variablePosition vars s))
      with (Regs x Sp ^+ natToW vars_start ^+ natToW (variablePosition vars s)); auto.
    rewrite natToW_plus.
    words.
    Opaque evalInstrs.
  Qed.

  Lemma postOk : forall specs pre x,
    interp specs (Postcondition (body pre) x)
    -> imply pre new_pre
    -> syn_req
    -> exists x0, interp specs (pre (fst x, x0))
      /\ runs_to (fst x, x0) (snd x).
    intros.
    unfold syn_req, body, runs_to in *.
    destruct var; simpl in *; post.

    Focus 2.
    Transparent evalInstrs.
    simpl in H2.
    Opaque evalInstrs.
    injection H2; clear H2; intros; subst.
    descend; eauto.

    Opaque mult.

    Opaque mult.
    Opaque evalInstrs.

    rewrite evalInstrs_write_var in *.
    generalize H2; intro Hs.
    apply H0 in Hs; clear H0; post.
    clear_fancy.
    unfold vars_start in H3.
    change (4 * 2) with 8 in *.
    descend.
    eauto.
    clear H.
    unfold is_state in H0.
    evaluate auto_ext.
    destruct x; simpl in *.
    intuition.
    unfold is_state.
    step auto_ext.
  Qed.
  Opaque evalInstrs.

  Lemma verifCondOk : forall pre,
    imply pre new_pre
    -> syn_req
    -> vcs (VerifCond (body pre)).
    unfold syn_req, body; intros.
    destruct var; wrap0.
    rewrite evalInstrs_write_var in *.
    apply H in H1; clear H; post.
    unfold is_state in H.
    unfold vars_start in *.
    change (4 * 2) with 8 in *.
    clear_fancy.
    evaluate auto_ext.
    Transparent evalInstrs.
    discriminate.
    Opaque evalInstrs.
  Qed.

  Definition compile : cmd imports modName.
    refine (Wrap imports imports_global modName body post verifCond _ _).

    Opaque mult.
    Opaque evalInstrs.

    abstract (unfold verifCond; wrap0;
      match goal with
        | [ H : interp _ _ |- _ ] =>
          apply postOk in H; post; descend; eauto
      end).

    Opaque mult.
    Opaque evalInstrs.

    abstract (unfold verifCond; wrap0; eauto using verifCondOk).
 Defined.

End TopLevel.


(* File reduced by coq-bug-finder from original input, then from 10940 lines to 152 lines, then from 509 lines to 163 lines, then from 178 lines to 66 lines *)
(* coqc version 8.5beta1 (March 2015) compiled on Mar 2 2015 18:53:10 with OCaml 4.01.0
   coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (e77f178e60918f14eacd1ec0364a491d4cfd0f3f) *)

Global Set Primitive Projections.
Set Implicit Arguments.
Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
Axiom path_forall : forall {A : Type} {P : A -> Type} (f g : forall x : A, P x),
                      (forall x, f x = g x) -> f = g.
Lemma sigT_obj_eq
: forall (T : Type) (T0 : T -> Type)
         (s s0 : forall s : sigT T0,
                   sigT (fun _ : T0 (projT1 s) => unit) ->
                   sigT (fun _ : T0 (projT1 s) => unit)),
   s0 = s.
Proof.
  intros.
  Set Debug Tactic Unification.
  apply path_forall.


(** printing |-#    %\vdash_{\#}%    #⊢##     *)
(** printing |-##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing |-##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing |-!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

Set Implicit Arguments.

Require Import TLC.LibLN.
Require Import String.

Require Import Coq.Program.Equality.

Require Import Definitions RecordAndInertTypes Decompose ConstrLangAlt.

(** * Constraint Interpretation *)

(** ** Ground assignments *)

Definition tctx := env typ.
Definition vctx := env var.

Reserved Notation "e '⊧' C" (at level 40).
Reserved Notation "es '⊢t' T1 '⪯' T2" (at level 40, T1 at level 59, T2 at level 59).
Reserved Notation "es '⊢d' d1 '⪯' d2" (at level 40, d1 at level 59, d2 at level 59).
Reserved Notation "es '⊢v' x '⪯' y" (at level 40, x at level 59, y at level 59).
Reserved Notation "es '⊢vv' x '⪯' y" (at level 40, x at level 59, y at level 59).
Reserved Notation "es '⊢vd' x '⪯' y" (at level 40, x at level 59, y at level 59).
Reserved Notation "es '⊢vds' x '⪯' y" (at level 40, x at level 59, y at level 59).

(** *** Mapping with ground assignments *)

(** Map a constraint variable to concrete variable. *)
Inductive map_cvar : vctx -> cvar -> avar -> Prop :=
| map_cvar_f : forall vm x y,
    binds x y vm ->
    map_cvar vm (cvar_f x) (avar_f y)
| map_cvar_x : forall vm x,
    map_cvar vm (cvar_x x) x
.

(** Map a type containing type variables to a concrete type. *)
Inductive map_ctyp : (tctx * vctx) -> ctyp -> typ -> Prop :=

| map_ctyp_top : forall tm vm,
    (tm, vm) ⊢t ctyp_top ⪯ typ_top

| map_ctyp_bot : forall tm vm,
    (tm, vm) ⊢t ctyp_bot ⪯ typ_bot

| map_ctyp_tvar : forall tm vm x T,
    binds x T tm ->
    (tm, vm) ⊢t ctyp_tvar (tvar_f x) ⪯ T

| map_ctyp_rcd : forall tm vm D D',
    (tm, vm) ⊢d D ⪯ D' ->
    (tm, vm) ⊢t ctyp_rcd D ⪯ typ_rcd D'

| map_ctyp_and : forall tm vm T T' U U',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢t U ⪯ U' ->
    (tm, vm) ⊢t ctyp_and T U ⪯ typ_and T' U'

| map_ctyp_sel : forall tm vm x y T,
    map_cvar vm x y ->
    (tm, vm) ⊢t ctyp_sel x T ⪯ typ_sel y T

| map_ctyp_bnd : forall tm vm T T',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢t ctyp_bnd T ⪯ typ_bnd T'

| map_ctyp_all : forall tm vm T T' U U',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢t U ⪯ U' ->
    (tm, vm) ⊢t ctyp_all T U ⪯ typ_all T' U'

where "es '⊢t' T1 '⪯' T2" := (map_ctyp es T1 T2)
with map_cdec : (tctx * vctx) -> cdec -> dec -> Prop :=
| map_cdec_typ : forall tm vm A S S' T T',
    (tm, vm) ⊢t S ⪯ S' ->
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢d cdec_typ A S T ⪯ dec_typ A S' T'
| map_cdec_trm : forall tm vm a T T',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢d cdec_trm a T ⪯ dec_trm a T'
where "es '⊢d' D1 '⪯' D2" := (map_cdec es D1 D2).

Inductive map_ctrm : (tctx * vctx) -> ctrm -> trm -> Prop :=
| map_ctrm_cvar : forall tm vm x y,
    map_cvar vm x y ->
    (tm, vm) ⊢v ctrm_cvar x ⪯ trm_var y
| map_ctrm_val : forall tm vm v v',
    map_cval (tm, vm) v v' ->
    (tm, vm) ⊢v ctrm_val v ⪯ trm_val v'
where "es '⊢v' t1 '⪯' t2" := (map_ctrm es t1 t2)
with map_cval : (tctx * vctx) -> cval -> val -> Prop :=
| map_cval_new : forall tm vm T T' ds ds',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢vds ds ⪯ ds' ->
    (tm, vm) ⊢vv cval_new T ds ⪯ val_new T' ds'
| map_cval_lambda : forall tm vm T T' t t',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢v t ⪯ t' ->
    (tm, vm) ⊢vv cval_lambda T t ⪯ val_lambda T' t'
where "es '⊢vv' t1 '⪯' t2" := (map_cval es t1 t2)
with map_cdef : (tctx * vctx) -> cdef -> def -> Prop :=
| map_cdef_typ : forall tm vm A T T',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢vd cdef_typ A T ⪯ def_typ A T'
| map_cdef_trm : forall tm vm a t t',
    (tm, vm) ⊢v t ⪯ t' ->
    (tm, vm) ⊢vd cdef_trm a t ⪯ def_trm a t'
where "es '⊢vd' t1 '⪯' t2" := (map_cdef es t1 t2)
with map_cdefs : (tctx * vctx) -> cdefs -> defs -> Prop :=
| map_cdefs_nil : forall tm vm,
    (tm, vm) ⊢vds cdefs_nil ⪯ defs_nil
| map_cdefs_cons : forall tm vm ds ds' d d',
    (tm, vm) ⊢vds ds ⪯ ds' ->
    (tm, vm) ⊢vd d ⪯ d' ->
    (tm, vm) ⊢vds cdefs_cons ds d ⪯ defs_cons ds' d'
where "es '⊢vds' t1 '⪯' t2" := (map_cdefs es t1 t2).

Scheme map_ctyp_mut    := Induction for map_ctyp Sort Prop
with   map_cdec_mut    := Induction for map_cdec Sort Prop.
Combined Scheme map_ctyp_mutind from map_ctyp_mut, map_cdec_mut.

Scheme map_ctrm_mut     := Induction for map_ctrm Sort Prop
with   map_cval_mut     := Induction for map_cval Sort Prop
with   map_cdef_mut     := Induction for map_cdef Sort Prop
with   map_cdefs_mut    := Induction for map_cdefs Sort Prop.
Combined Scheme map_ctrm_mutind from map_ctrm_mut, map_cval_mut, map_cdef_mut, map_cdefs_mut.

(** *** Properties of mapping *)

Lemma map_ctyp_unique_typ : forall tm vm T T1 T2,
    (tm, vm) ⊢t T ⪯ T1 ->
    (tm, vm) ⊢t T ⪯ T2 ->
    T1 = T2
with map_cdec_unique_dec : forall tm vm D D1 D2,
    (tm, vm) ⊢d D ⪯ D1 ->
    (tm, vm) ⊢d D ⪯ D2 ->
    D1 = D2.
Proof.
  all: introv Hm1 Hm2.
  - dependent induction T; inversion Hm1; inversion Hm2; subst; trivial; try f_equal.
    -- inversion H7; subst. eapply binds_functional; eassumption.
    -- apply~ map_cdec_unique_dec; eassumption.
    -- specialize (IHT1 _ _ H4 H11). specialize (IHT2 _ _ H5 H12). subst. trivial.
    -- specialize (IHT1 _ _ H4 H11). specialize (IHT2 _ _ H5 H12). subst. trivial.
    -- destruct c.
       + inversion H4; inversion H10; subst.
         lets Heqy: (binds_functional H1 H6). subst. f_equal.
       + inversion H4; inversion H10; subst.
       + inversion H4; inversion H10; subst. trivial.
    -- apply~ IHT.
    -- specialize (IHT1 _ _ H4 H11). specialize (IHT2 _ _ H5 H12). subst. trivial.
    -- specialize (IHT1 _ _ H4 H11). specialize (IHT2 _ _ H5 H12). subst. trivial.
  - dependent induction D; inversion Hm1; inversion Hm2; subst; f_equal.
    -- eapply map_ctyp_unique_typ; eassumption.
    -- eapply map_ctyp_unique_typ; eassumption.
    -- eapply map_ctyp_unique_typ; eassumption.
Qed.

Lemma map_tvar_tail : forall tm vm x T,
    (tm & x ~ T, vm) ⊢t ctyp_tvar (tvar_f x) ⪯ T.
Proof.
  introv. constructor. apply binds_push_eq.
Qed.

Lemma map_tvar_tail_eq : forall tm vm x T T',
    (tm & x ~ T, vm) ⊢t ctyp_tvar (tvar_f x) ⪯ T' ->
    T = T'.
Proof.
  introv Hmx. inversion Hmx; subst.
  symmetry. eapply binds_push_eq_inv. eauto.
Qed.

Lemma strengthen_map_ctyp : forall tm vm x T S S',
    (tm & x ~ T, vm) ⊢t S ⪯ S' ->
    x \notin ftv_ctyp S ->
    (tm, vm) ⊢t S ⪯ S'
with strengthen_map_cdec : forall tm vm x T D D',
    (tm & x ~ T, vm) ⊢d D ⪯ D' ->
    x \notin ftv_cdec D ->
    (tm, vm) ⊢d D ⪯ D'.
Proof.
  all: introv Hmx Hn.
  - induction S;
      try (inversion Hmx; subst; constructor*);
      try (apply* strengthen_map_ctyp; simpl in Hn; auto).
    -- apply binds_concat_left_inv with (E2 := x ~ T); auto.
       unfold notin. introv Hin. rewrite dom_single in Hin.
       rewrite in_singleton in Hin. subst x0. simpl in Hn.
       apply Hn. rewrite -> in_singleton. trivial.
   - induction D; inversion Hmx; subst;
       simpl in Hn; constructor; apply* strengthen_map_ctyp.
Qed.

Lemma map_iso_ctyp : forall tm vm T T',
    T ⩭ T' ->
    (tm, vm) ⊢t T ⪯ T'
with map_iso_cdec : forall tm vm D D',
    iso_cdec_dec D D' ->
    (tm, vm) ⊢d D ⪯ D'.
Proof.
  all: introv Hc.
  - dependent induction Hc; try constructor; try apply IHHc1; try apply IHHc2;
      try apply IHHc.
    -- apply* map_iso_cdec.
    -- constructor.
  - dependent induction Hc; try constructor; try apply IHHc;
      try apply* map_iso_ctyp.
Qed.

Lemma map_iso_ctyp_eq : forall tm vm T T1 T2,
    T ⩭ T1 ->
    (tm, vm) ⊢t T ⪯ T2 ->
    T1 = T2
with map_iso_cdec_eq : forall tm vm D D1 D2,
    iso_cdec_dec D D1 ->
    (tm, vm) ⊢d D ⪯ D2 ->
    D1 = D2.
Proof.
  all: introv Hc Hm.
  - gen T2. dependent induction Hc; introv Hm.
    -- inversion Hm; subst. reflexivity.
    -- inversion Hm; subst. reflexivity.
    -- inversion Hm; subst. f_equal. apply* map_iso_cdec_eq.
    -- inversion Hm; subst. f_equal; try apply* IHHc1. apply* IHHc2.
    -- inversion Hm; subst. f_equal. inversion H4; subst. reflexivity.
    -- inversion Hm; subst. f_equal. apply* IHHc.
    -- inversion Hm; subst. f_equal. apply* IHHc1. apply* IHHc2.
  - gen D2. dependent induction Hc; introv Hm.
    -- inversion Hm; subst. f_equal; apply* map_iso_ctyp_eq.
    -- inversion Hm; subst. f_equal. apply* map_iso_ctyp_eq.
Qed.

Inductive satisfy_constr : (tctx * vctx * ctx) -> constr -> Prop :=

| sat_true : forall tm vm G,
    (tm, vm, G) ⊧ ⊤

| sat_and : forall tm vm G C1 C2,
    (tm, vm, G) ⊧ C1 ->
    (tm, vm, G) ⊧ C2 ->
    (tm, vm, G) ⊧ C1 ⋏ C2

| sat_or1 : forall tm vm G C1 C2,
    (tm, vm, G) ⊧ C1 ->
    (tm, vm, G) ⊧ C1 ⋎ C2

| sat_or2 : forall tm vm G C1 C2,
    (tm, vm, G) ⊧ C2 ->
    (tm, vm, G) ⊧ C1 ⋎ C2

| sat_exists_typ : forall L tm vm G T C,
    (forall x, x \notin L -> (tm & x ~ T, vm, G) ⊧ C ^^t x) ->
    (tm, vm, G) ⊧ (∃t C)

| sat_exists_var : forall L tm vm G u C,
    (forall x, x \notin L -> (tm, vm & x ~ u, G) ⊧ C ^^v x) ->
    (tm, vm, G) ⊧ (∃v C)

| sat_typ : forall tm vm G t t' T T',
    (tm, vm) ⊢v t ⪯ t' ->
    (tm, vm) ⊢t T ⪯ T' ->
    G ⊢ t' : T' ->
    (tm, vm, G) ⊧ t ⦂ T

| sat_sub : forall tm vm G S S' T T',
    (tm, vm) ⊢t S ⪯ S' ->
    (tm, vm) ⊢t T ⪯ T' ->
    G ⊢ S' <: T' ->
    (tm, vm, G) ⊧ S <⦂ T

where "e '⊧' C" := (satisfy_constr e C).

Hint Constructors satisfy_constr constr.

Definition constr_satisfiable (C : constr) (G : ctx) :=
  exists tm vm, (tm, vm, G) ⊧ C.

Notation "G '⊨' C" := (constr_satisfiable C G) (at level 40).


Require Import Recdef.
Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import Coq.Lists.List. Import ListNotations.
Require Import sha.general_lemmas.

Require Import tweetnacl20140427.split_array_lemmas.
Require Import ZArith.
Require Import tweetnacl20140427.Salsa20.
Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.tweetNaclBase.
Instance CompSpecs : compspecs.
Proof. make_compspecs prog. Defined.

Lemma data_at_ext sh t v v' p: v=v' -> data_at sh t v p |-- data_at sh t v' p.
Proof. intros; subst. auto. Qed.

(*
Definition EightWord (q:QuadWord * QuadWord) (v:val) : mpred :=
  match q with ((q0, q1, q2, q3),(q4, q5, q6, q7)) =>
    data_at Tsh (Tarray tuchar 4 noattr) (map Vint [q0; q1; q2; q3; q4; q5; q6; q7]) v
  end.*)
Definition QuadByte2ByteList (B:QuadByte) : list byte :=
  match B with (b0, b1, b2, b3) => [b0; b1; b2; b3]
  end.

Definition QuadByte2ValList (B:QuadByte) : list val :=
   map Vint (map Int.repr (map Byte.unsigned (QuadByte2ByteList B))).

Lemma QuadByteValList_length q: length (QuadByte2ValList q) = 4%nat.
  destruct q as [[[? ?] ?] ?]. reflexivity. Qed.

Definition EightByte (q:QuadByte * QuadByte) (v:val) : mpred :=
  match q with (q1, q2) =>
    data_at Tsh (Tarray tuchar 8 noattr) ((QuadByte2ValList q1) ++ (QuadByte2ValList q2)) v
  end.

Definition SixteenByte2ByteList (B:SixteenByte) : list byte :=
  match B with (q0, q1, q2, q3) =>
   QuadByte2ByteList q0 ++ QuadByte2ByteList q1 ++ QuadByte2ByteList q2 ++ QuadByte2ByteList q3
  end.

Definition SixteenByte2ValList (B:SixteenByte) : list val :=
   map Vint (map Int.repr (map Byte.unsigned (SixteenByte2ByteList B))).

Lemma SixteenByte2ValList_char B: SixteenByte2ValList B =
  match B with (q0, q1, q2, q3) =>
   QuadByte2ValList q0 ++ QuadByte2ValList q1 ++ QuadByte2ValList q2 ++ QuadByte2ValList q3
  end.
Proof. unfold SixteenByte2ValList, QuadByte2ValList .
 destruct B as [[[? ?] ?] ?]. simpl. repeat rewrite map_app. trivial.
Qed.

Definition ThirtyTwoByte (q:SixteenByte * SixteenByte) (v:val) : mpred :=
  match q with (q1, q2) =>
    @data_at CompSpecs Tsh (Tarray tuchar 32 noattr) ((SixteenByte2ValList q1) ++ (SixteenByte2ValList q2)) v
  end.

Definition QByte (q:QuadByte) (v:val) : mpred :=
  data_at Tsh (Tarray tuchar 4 noattr) (QuadByte2ValList q) v.

Definition QuadChunks2ValList (l: list QuadByte) : list val :=
  List.fold_right (fun q vals => QuadByte2ValList q ++ vals) nil l.

Definition flatten16 (B:SixteenByte) : list QuadByte :=
  match B with (q0, q1, q2, q3) => [q0; q1; q2; q3] end.
Lemma SixteenByte2ValList_flatten B:
  QuadChunks2ValList (flatten16 B) = SixteenByte2ValList B.
  destruct B as (((q0, q1), q2), q3). simpl.
  rewrite SixteenByte2ValList_char, app_nil_r. trivial.
Qed.

Lemma QuadByteByteList_ZLength q: 4 = Zlength (QuadByte2ByteList q).
  destruct q as (((q0, q1), q2), q3). simpl. reflexivity. Qed.
Lemma QuadByteValList_ZLength q: 4 = Zlength (QuadByte2ValList q).
  destruct q as (((q0, q1), q2), q3). simpl. reflexivity. Qed.

Lemma SixteenByte2ValList_Zlength C: 16 = Zlength (SixteenByte2ValList C).
  destruct C as (((q0, q1), q2), q3). unfold SixteenByte2ValList.
  repeat rewrite Zlength_map.  simpl.
  repeat rewrite Zlength_app. repeat rewrite <- QuadByteByteList_ZLength.
  reflexivity. Qed.

Definition SByte (q:SixteenByte) (v:val) : mpred :=
  @data_at CompSpecs Tsh (Tarray tuchar 16 noattr) (SixteenByte2ValList q) v.

Lemma ThirtyTwoByte_split16 q v:
  field_compatible (Tarray tuchar 32 noattr) [] v ->
  ThirtyTwoByte q v =
  (SByte (fst q) v * SByte (snd q) (offset_val 16 v))%logic.
Proof. destruct q as [s1 s2]. simpl; intros. unfold SByte.
  rewrite split2_data_at_Tarray_tuchar with (n1:= Zlength (SixteenByte2ValList s1));
     try rewrite Zlength_app; repeat rewrite <- SixteenByte2ValList_Zlength; try omega.
  unfold offset_val. red in H. destruct v; intuition.
  rewrite field_address0_offset. simpl.
  rewrite sublist_app1; try rewrite <- SixteenByte2ValList_Zlength; try omega.
  rewrite sublist_app2; try rewrite <- SixteenByte2ValList_Zlength; try omega.
  rewrite sublist_same; try rewrite <- SixteenByte2ValList_Zlength; trivial.
  rewrite sublist_same; try rewrite <- SixteenByte2ValList_Zlength; trivial.
  red; intuition.
Qed.

Lemma QuadByte2ValList_firstn4 q l:
         firstn 4 (QuadByte2ValList q ++ l) = QuadByte2ValList q.
   Proof. destruct q as (((b0, b1), b2), b3); trivial. Qed.

Lemma QuadByte2ValList_skipn4 q l:
         skipn 4 (QuadByte2ValList q ++ l) = l.
   Proof. destruct q as (((b0, b1), b2), b3); trivial. Qed.

Definition Select16Q (Q:SixteenByte) i :QuadByte :=
  match Q with (((b0, b1), b2), b3) =>
    if zeq i 0 then b0 else
    if zeq i 1 then b1 else
    if zeq i 2 then b2 else b3
  end.
Definition UnSelect16Q (Q:SixteenByte) i : list QuadByte :=
  match Q with (((b0, b1), b2), b3) =>
    if zeq i 0 then [b1;b2;b3] else
    if zeq i 1 then [b0;b2;b3] else
    if zeq i 2 then [b0;b1;b3] else [b0;b1;b2]
  end.
Definition SplitSelect16Q (Q:SixteenByte) i : (list QuadByte * list QuadByte) :=
  match Q with (((b0, b1), b2), b3) =>
    if zeq i 0 then ([], [b1;b2;b3]) else
    if zeq i 1 then ([b0], [b2;b3]) else
    if zeq i 2 then ([b0;b1], [b3]) else ([b0;b1;b2], [])
  end.
Lemma Select_SplitSelect16Q Q i front back:
    (front, back) = SplitSelect16Q Q i ->
    SixteenByte2ValList Q =
    QuadChunks2ValList front ++ QuadChunks2ValList [Select16Q Q i] ++ QuadChunks2ValList back.
Proof.
  unfold Select16Q, SplitSelect16Q; intros.
  destruct Q as (((q0, q1), q2), q3). simpl.
  destruct (zeq i 0); simpl. inv H; simpl. repeat rewrite app_nil_r. apply SixteenByte2ValList_char.
  destruct (zeq i 1); simpl. inv H; simpl. repeat rewrite app_nil_r. apply SixteenByte2ValList_char.
  destruct (zeq i 2); simpl. inv H; simpl. repeat rewrite app_nil_r. repeat rewrite <- app_assoc. apply SixteenByte2ValList_char.
  destruct (zeq i 3); simpl; inv H; simpl. repeat rewrite app_nil_r. repeat rewrite <- app_assoc. apply SixteenByte2ValList_char.
  repeat rewrite app_nil_r. repeat rewrite <- app_assoc. apply SixteenByte2ValList_char.
Qed.

Lemma QuadChunk2ValList_ZLength: forall l, Zlength (QuadChunks2ValList l) = (4 * Zlength l)%Z.
Proof.
  unfold QuadChunks2ValList. induction l; simpl. reflexivity.
  rewrite Zlength_app, IHl, <- QuadByteValList_ZLength.
  rewrite Zlength_cons; omega.
Qed.

Lemma Select_SplitSelect16Q_Zlength Q i front back:
    (front, back) = SplitSelect16Q Q i -> 0<= i < 4 ->
    Zlength front = i /\ Zlength back = 3-i.
Proof.
  unfold SplitSelect16Q; intros.
  destruct Q as (((q0, q1), q2), q3).
  destruct (zeq i 0). inv H. split; reflexivity.
  destruct (zeq i 1). inv H. split; reflexivity.
  destruct (zeq i 2). inv H. split; reflexivity.
  destruct (zeq i 3). inv H. split; reflexivity. omega.
Qed.

Definition QBytes (l:list QuadByte) (v:val) : mpred :=
  data_at Tsh (Tarray tuchar (4*Zlength l) noattr) (QuadChunks2ValList l) v.

Lemma QBytes16 s: SByte s = QBytes (flatten16 s).
Proof.
  destruct s as (((q0, q1), q2), q3). simpl.
  unfold SByte, QBytes. extensionality v. simpl. rewrite app_nil_r.
  rewrite SixteenByte2ValList_char. trivial.
Qed.

Definition QuadWordRep (q:QuadWord):list val :=
  match q with (q0, q1, q2, q3) => map Vint [q0;q1;q2;q3] end.
Definition SixteenWordRep (w:SixteenWord):list val :=
  match w with (q0, q1, q2, q3) => QuadWordRep q0 ++ QuadWordRep q1 ++ QuadWordRep q2 ++ QuadWordRep q3 end.

Definition littleendian_of_SixteenByte (x:SixteenByte): QuadWord :=
  match x with (q0, q1, q2, q3) => (littleendian q0, littleendian q1, littleendian q2, littleendian q3) end.

     Lemma QuadWR_length q: length (QuadWordRep q) = 4%nat.
        destruct q as [[[? ?] ?] ?]. simpl. reflexivity. Qed.
     Lemma QuadWR_zlength q: Zlength (QuadWordRep q) = 4.
        rewrite Zlength_correct, QuadWR_length. trivial. Qed.
     Lemma SixteenWR_length s: length (SixteenWordRep s) = 16%nat.
        destruct s as [[[? ?] ?] ?]. simpl.
        repeat rewrite app_length. repeat rewrite  QuadWR_length. reflexivity. Qed.
     Lemma SixteenWR_zlength s: Zlength (SixteenWordRep s) = 16.
        rewrite Zlength_correct, SixteenWR_length. trivial. Qed.

Lemma QuadWR_int q i: (0<=i<4)%nat -> exists ii, nth i (QuadWordRep q) Vundef = Vint ii.
  intros. destruct q as [[[? ?] ?] ?]. simpl.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity. omega. Qed.

Lemma SixteenWR_int s i: (0<=i<16)%nat -> exists ii, nth i (SixteenWordRep s) Vundef = Vint ii.
  intros. destruct s as [[[? ?] ?] ?]. simpl.
  destruct q as [[[? ?] ?] ?]. destruct q0 as [[[? ?] ?] ?].
  destruct q1 as [[[? ?] ?] ?]. destruct q2 as [[[? ?] ?] ?]. simpl.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity. omega.
Qed.

Lemma SixteenWR_Znth_int i s: (0 <= i < 16) ->
       exists ii : int, Znth i (SixteenWordRep s) = Vint ii.
Proof. intros. unfold Znth. if_tac; try omega.
   apply SixteenWR_int. destruct H. apply Z2Nat.inj_lt in H1; simpl in *; omega.
Qed.

Lemma QuadWR_Z_int: forall (q : QuadWord) (i : Z),
               0 <= i < 4 -> exists ii : int, Znth i (QuadWordRep q) = Vint ii.
Proof. intros. unfold Znth. if_tac. omega.
       apply QuadWR_int. destruct H.
       split.
         apply Z2Nat.inj_le in H. apply H. omega. omega.
         apply Z2Nat.inj_lt in H1. apply H1. omega. omega.
Qed.

Lemma SixteenWordRep_MapVint ss: exists l, SixteenWordRep ss = map Vint l.
Proof.
destruct ss as [[[s0 s1] s2] s3].
destruct s0 as [[[x0 x1] x2] x3].
destruct s1 as [[[x4 x5] x6] x7].
destruct s2 as [[[x8 x9] x10] x11].
destruct s3 as [[[x12 x13] x14] x15]. simpl.
exists [x0; x1; x2; x3; x4; x5; x6; x7;
    x8; x9; x10; x11; x12; x13; x14; x15].
reflexivity.
Qed.

Definition QuadWordRepI (q : QuadWord) :=
  match q with (q0, q1, q2, q3) => [q0; q1; q2; q3] end.
Lemma QuadWordRepI_QuadWordRep q: QuadWordRep q = map Vint  (QuadWordRepI q).
Proof. destruct q as [[[q0 q1] q2] q3]. reflexivity. Qed.

Definition SixteenWordRepI (w : SixteenWord) :=
  match w with (q0, q1, q2, q3) =>
    QuadWordRepI q0 ++ QuadWordRepI q1 ++ QuadWordRepI q2 ++ QuadWordRepI q3
  end.
Lemma SixteenWordRepI_SixteenWordRep w: SixteenWordRep w = map Vint (SixteenWordRepI w).
Proof. destruct w as [[[q0 q1] q2] q3]. simpl.
   repeat rewrite QuadWordRepI_QuadWordRep. repeat rewrite map_app. reflexivity.
Qed.

    Lemma QuadWordRepI_length s: length (QuadWordRepI s) = 4%nat.
    Proof. destruct s as [[[q0 q1] q2] q3]. reflexivity. Qed.
    Lemma SixteenWordRepI_length s: length (SixteenWordRepI s) = 16%nat.
    Proof. destruct s as [[[q0 q1] q2] q3]. simpl.
      repeat rewrite app_length. repeat rewrite QuadWordRepI_length. reflexivity.
    Qed.

Lemma QuadByte2ValList_bytes q: exists bytes, length bytes = 4%nat /\
      QuadByte2ValList q = map Vint (map Int.repr (map Byte.unsigned bytes)).
Proof. destruct q as [[[b0 b1] b2] b3]. unfold QuadByte2ValList; simpl.
  exists [b0;b1;b2;b3]. split; trivial.
Qed.

Lemma SixteenByte2ValList_bytes N: exists bytes, length bytes = 16%nat /\
      SixteenByte2ValList N =  map Vint (map Int.repr (map Byte.unsigned bytes)).
Proof. destruct N as [[[q0 q1] q2] q3]. rewrite SixteenByte2ValList_char.
  destruct (QuadByte2ValList_bytes q0) as [bytes0 [L0 Q0]]. rewrite Q0.
  destruct (QuadByte2ValList_bytes q1) as [bytes1 [L1 Q1]]; rewrite Q1.
  destruct (QuadByte2ValList_bytes q2) as [bytes2 [L2 Q2]]; rewrite Q2.
  destruct (QuadByte2ValList_bytes q3) as [bytes3 [L3 Q3]]; rewrite Q3.
  exists (bytes0 ++ bytes1 ++ bytes2 ++ bytes3).
  repeat rewrite map_app. repeat rewrite app_length. rewrite L0, L1, L2, L3.
  split; trivial.
Qed.

Lemma QuadByte2ValList_ints q: exists ints, length ints = 4%nat /\
      QuadByte2ValList q = map Vint ints.
Proof. destruct q as [[[b0 b1] b2] b3]. unfold QuadByte2ValList; simpl.
  exists [Int.repr (Byte.unsigned b0); Int.repr (Byte.unsigned b1);
          Int.repr (Byte.unsigned b2); Int.repr (Byte.unsigned b3)].
  split; trivial.
Qed.

Lemma SixteenByte2ValList_ints N: exists ints, length ints = 16%nat /\
      SixteenByte2ValList N = map Vint ints.
Proof. destruct N as [[[q0 q1] q2] q3]. rewrite SixteenByte2ValList_char.
  destruct (QuadByte2ValList_ints q0) as [ints0 [L0 Q0]]; rewrite Q0.
  destruct (QuadByte2ValList_ints q1) as [ints1 [L1 Q1]]; rewrite Q1.
  destruct (QuadByte2ValList_ints q2) as [ints2 [L2 Q2]]; rewrite Q2.
  destruct (QuadByte2ValList_ints q3) as [ints3 [L3 Q3]]; rewrite Q3.
  exists (ints0 ++ ints1 ++ ints2 ++ ints3).
  repeat rewrite map_app. repeat rewrite app_length. rewrite L0, L1, L2, L3.
  split; trivial.
Qed.

Lemma QuadChunks2ValList_bytes: forall l,
        exists bytes, length bytes = (4*length l)%nat /\
        QuadChunks2ValList l = map Vint (map Int.repr (map Byte.unsigned bytes)).
  Proof. unfold QuadChunks2ValList.
    induction l; simpl; intros. exists nil; split; trivial.
    destruct IHl as [? [X1 X2]]; rewrite X2; clear X2.
    destruct (QuadByte2ValList_bytes a) as [? [Y1 Y2]]; rewrite Y2; clear Y2.
    repeat rewrite <- map_app. exists (x0 ++ x); split; trivial.
    rewrite app_length, X1, Y1. omega.
  Qed.

Fixpoint upd_upto (x: SixteenByte * SixteenByte * (SixteenByte * SixteenByte)) i (l:list val):list val :=
  match i with
    O => l
  | S n =>
     match x with (Nonce, C, (Key1, Key2)) =>
     ((upd_Znth (11 + (Z.of_nat n))
     (upd_Znth(6 + (Z.of_nat n))
        (upd_Znth (1 + (Z.of_nat n))
           (upd_Znth (5 * (Z.of_nat n)) (upd_upto x n l)
              (Vint (littleendian (Select16Q C (Z.of_nat n)))))
           (Vint (littleendian (Select16Q Key1 (Z.of_nat n)))))
        (Vint (littleendian (Select16Q Nonce (Z.of_nat n)))))
     (Vint (littleendian (Select16Q Key2 (Z.of_nat n))))))
     end
  end.

Lemma upd_upto_Sn Nonce C Key1 Key2 n l: upd_upto (Nonce, C, (Key1, Key2)) (S n) l =
     ((upd_Znth (11 + (Z.of_nat n))
     (upd_Znth (6 + (Z.of_nat n))
        (upd_Znth (1 + (Z.of_nat n))
           (upd_Znth (5 * (Z.of_nat n)) (upd_upto (Nonce, C, (Key1, Key2))  n l)
              (Vint (littleendian (Select16Q C (Z.of_nat n)))))
           (Vint (littleendian (Select16Q Key1 (Z.of_nat n)))))
        (Vint (littleendian (Select16Q Nonce (Z.of_nat n)))))
     (Vint (littleendian (Select16Q Key2 (Z.of_nat n)))))).
 reflexivity. Qed.

Lemma upd_upto_Zlength data l (H: Zlength l = 16): forall i (I:(0<=i<=4)%nat),
      Zlength (upd_upto data i l) = 16.
  Proof. apply Zlength_length in H. 2: omega. simpl in H.
    destruct l; simpl in H. exfalso; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. 2: intros; omega. clear H.
    intros.
    induction i; destruct data as [[N C] [K1 K2]]. reflexivity.
    rewrite upd_upto_Sn. remember (11 + Z.of_nat i) as z1. remember (6 + Z.of_nat i) as z2.
    remember (1 + Z.of_nat i) as z3. remember (5 * Z.of_nat i)%Z as z4.
    remember (Vint (littleendian (Select16Q C (Z.of_nat i)))) as u4.
    remember (Vint (littleendian (Select16Q K1 (Z.of_nat i)))) as u3.
    remember (Vint (littleendian (Select16Q N (Z.of_nat i)))) as u2.
    remember (Vint (littleendian (Select16Q K2 (Z.of_nat i)))) as u1.
    assert ((0 <= i <= 4)%nat).
      split. omega. omega. (*rewrite Nat2Z.inj_succ in I. omega.*)
    repeat rewrite upd_Znth_Zlength; rewrite (IHi H); intros; try omega.
Qed.

Lemma upd_upto_Vint data: forall n, 0<=n<16 ->
      exists i, Znth n (upd_upto data 4 (list_repeat 16 Vundef)) = Vint i.
  Proof. unfold upd_upto; intros. destruct data as [[N C] [K1 K2]].
   repeat rewrite (upd_Znth_lookup' 16); trivial; simpl; try omega.
   if_tac. eexists; reflexivity.   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity. omega.
Qed.

(*cf xsalsa-paper, beginning of Section 2*)
Lemma upd_upto_char data l: Zlength l = 16 ->
      upd_upto data 4 l = match data with ((Nonce, C), (Key1, Key2)) =>
          match Nonce with (N1, N2, N3, N4) =>
          match C with (C1, C2, C3, C4) =>
          match Key1 with (K1, K2, K3, K4) =>
          match Key2 with (L1, L2, L3, L4) =>
      map Vint (map littleendian [C1; K1; K2; K3;
                                  K4; C2; N1; N2;
                                  N3; N4; C3; L1;
                                  L2; L3; L4; C4]) end end end end end.
Proof. intros. apply Zlength_length in H. 2: omega.
   destruct data as [[Nonce C] [Key1 Key2]].
   destruct Nonce as [[[N1 N2] N3] N4].
   destruct C as [[[C1 C2] C3] C4].
   destruct Key1 as [[[K1 K2] K3] K4].
   destruct Key2 as [[[L1 L2] L3] L4].
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. 2: omega. clear H. reflexivity.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Jacques-Henri Jourdan, 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 GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

Require Import Fappli_IEEE.
Require Import Fappli_IEEE_bits.
Require Import Floats.
Require Import ZArith.
Require Import Integers.

Program Definition default_pl : bool * nan_pl 53 := (false, nat_iter 51 xO xH).

Definition choose_binop_pl (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
  (** Choose second NaN if pl2 is sNaN but pl1 is qNan.
      In all other cases, choose first NaN *)
  (Pos.testbit (proj1_sig pl1) 51 &&
   negb (Pos.testbit (proj1_sig pl2) 51))%bool.