(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Cava.Cava.
Require Import Cava.CavaProperties.
Require Import AesSpec.AES256.
Require Import AesSpec.StateTypeConversions.
Require Import AesImpl.Pkg.
Require Import AesImpl.ShiftRowsCircuit.
Import StateTypeConversions.LittleEndian.

Section Equivalence.
  Local Notation byte := (Vector.t bool 8).
  Local Notation state := (Vector.t (Vector.t byte 4) 4) (only parsing).
  Local Notation key := (Vector.t (Vector.t byte 4) 4) (only parsing).

  Lemma shift_rows_equiv (is_decrypt : bool) (st : state) :
    aes_shift_rows is_decrypt st
    = AES256.aes_shift_rows_circuit_spec is_decrypt st.
  Proof.
    (* simplify RHS (specification) *)
    cbv [aes_shift_rows_circuit_spec
           AES256.shift_rows AES256.inv_shift_rows
           ShiftRows.shift_rows ShiftRows.inv_shift_rows].
    cbv [to_flat from_flat BigEndian.from_list_rows BigEndian.to_list_rows].
    autorewrite with conversions push_length push_to_list.
    cbn [List.map map]. autorewrite with push_to_list.
    cbv [ShiftRows.shift_rows_start ShiftRows.inv_shift_row].
    autorewrite with push_length. cbn [seq map2].
    autorewrite with push_of_list_sized. cbn [map].

    cbv [aes_shift_rows]. simpl_ident.

    (* break state vector into 16 bytes *)
    constant_vector_simpl st.
    repeat match goal with
           | v := _ : Vector.t byte 4 |- _ => constant_vector_simpl v
    end; clear.

    (* simplify LHS (implementation) *)
    cbv [aes_circ_byte_shift]. simpl_ident.
    repeat lazymatch goal with
           | |- context [map (@indexConst _ _ ?A _ [?x]%list) ?y] =>
             erewrite map_ext with (f:=@indexConst seqType _ A _ [x]%list)
                                   (g:=fun n => [nth_default (defaultCombValue A) n x])
               by (intros; rewrite !(@indexConst_singleton (Vec Bit 8));
                   reflexivity)
           end.
    rewrite !map_map.
    cbn [map].
    repeat match goal with
           | |- context [Nat.modulo ?n ?m] => compute_expr (Nat.modulo n m)
           end.
    cbn [map length fold_left PeanoNat.Nat.max seq List.nth
             List.map nth_default List.rev app].

    (* prove the two sides are equivalent *)
    destruct is_decrypt.
    { fequal_list; fequal_vector;
        cbn - [bitvec_to_byte byte_to_bitvec];
        rewrite !bitvec_to_byte_to_bitvec; reflexivity. }
    { fequal_list; fequal_vector;
        cbn - [bitvec_to_byte byte_to_bitvec];
        rewrite !bitvec_to_byte_to_bitvec; reflexivity. }
  Qed.
End Equivalence.


Load "tact_DH2".

Theorem Pi1_Pi2'': phi4 ~ phi34.
Proof.

  repeat unf_phi.
simpl.

assert(H: (ostomsg t15) # (ostomsg t35)).
simpl.

 repeat unf.

repeat rewrite andB_elm'' with (b1:= (EQ_M (to x1) (i 1)) ) (b2:= (EQ_M (act x1) new)  ).
 false_to_sesns_all; simpl.
repeat redg; repeat rewrite IFTFb.
aply_breq.
 repeat redg;  repeat rewrite IFTFb.
aply_breq.
 repeat redg;  repeat rewrite IFTFb.
false_to_sesns_all; simpl.
 repeat redg;  repeat rewrite IFTFb.
aply_breq.
 repeat redg;  repeat rewrite IFTFb.
false_to_sesns_all; simpl.
  repeat redg;  repeat rewrite IFTFb.
aply_breq.
 repeat redg;  repeat rewrite IFTFb.
false_to_sesns_all; simpl.
  repeat redg;  repeat rewrite IFTFb.
 aply_breq.
 repeat redg;  repeat rewrite IFTFb.
repeat aply_andB_elm.
false_to_sesns_all; simpl.
repeat redg;  repeat rewrite IFTFb.
 aply_breq.
 repeat redg;  repeat rewrite IFTFb. reflexivity.
false_to_sesns_all; simpl.
repeat redg;  repeat rewrite IFTFb.
 aply_breq.
 repeat redg;  repeat rewrite IFTFb.
aply_breq.
 repeat redg;  repeat rewrite IFTFb. reflexivity.
false_to_sesns_all; simpl.
 repeat redg;  repeat rewrite IFTFb.
aply_breq.
apply eqm in H. rewrite H. reflexivity.

Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import paths.
Require Import finset.
Require Import connect.
Require Import hypermap.
Require Import geometry.
Require Import color.
Require Import coloring.
Require Import quiz.
Require Import cfmap.
Require Import cfquiz.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* Compile a sequencs of (reducible) configurations into a set of quizzes,  *)
(* and store them in a tree structure according to the arities of the three *)
(* center regions. Rotations and reflections are also stored, so that the   *)
(* reducibility search can do a single lookup per triangle in the searched  *)
(* part (see file redpart.v).                                               *)
(* The middle nodes of the tree have four branches, for each of the arities *)
(* 5, 6, 7 and 8; the top node also has four branches, but with a different *)
(* interpretation: the first is a subtree for arities less than 9, and the  *)
(* other three for arities 9, 10, and 11 (we don't need to store those      *)
(* lower in the tree, since only the most central region of our             *)
(* configurations can have more than 8 sides). Also, since such a large     *)
(* region can only match the hub, we don't store the rotations of its quiz. *)
(*   The quiz fork and trees are traversed in the inner loop of the         *)
(* unavoidability computation, so, like parts, their representation has     *)
(* been compressed, with the quiz triples integrated in the list structure, *)
(* and the tree structure feeding directly in the list structure.           *)

Inductive quiz_tree : Set :=
  | QztNil : quiz_tree
  | QztLeaf : forall q1 q2 q3 : question, quiz_tree -> quiz_tree
  | QztNode : forall t5 t6 t7 t8 : quiz_tree, quiz_tree
  | QztHubNode : forall t58 t9 t10 t11 : quiz_tree, quiz_tree.

(* Not-nil test.                                                            *)

Definition qzt_proper qt' := if qt' is QztNil then false else true.

(* Update/store operations.                                                 *)

Fixpoint qzt_put1 (qa : qarity) (qr : quiz_tree -> quiz_tree) (t : quiz_tree)
    {struct t} : quiz_tree :=
  match t, qa with
  | QztNode t5 t6 t7 t8, Qa5 => QztNode (qr t5) t6 t7 t8
  | QztNode t5 t6 t7 t8, Qa6 => QztNode t5 (qr t6) t7 t8
  | QztNode t5 t6 t7 t8, Qa7 => QztNode t5 t6 (qr t7) t8
  | QztNode t5 t6 t7 t8, Qa8 => QztNode t5 t6 t7 (qr t8)
  | QztHubNode t58 t9 t10 t11, Qa9 => QztHubNode t58 (qr t9) t10 t11
  | QztHubNode t58 t9 t10 t11, Qa10 => QztHubNode t58 t9 (qr t10) t11
  | QztHubNode t58 t9 t10 t11, Qa11 => QztHubNode t58 t9 t10 (qr t11)
  | QztHubNode t58 t9 t10 t11, _ =>
      QztHubNode (qzt_put1 qa qr t58) t9 t10 t11
  | _, _ => t
  end.

Definition qzt_put3 qa1 qa2 qa3 q1 q2 q3 :=
  qzt_put1 qa1 (qzt_put1 qa2 (qzt_put1 qa3 (QztLeaf q1 q2 q3))).

Definition qzt_put3rot qa1 qa2 qa3 q1 q2 q3 t :=
  qzt_put3 qa1 qa2 qa3 q1 q2 q3
    (qzt_put3 qa2 qa3 qa1 q2 q3 q1 (qzt_put3 qa3 qa1 qa2 q3 q1 q2 t)).

Definition qzt_put (qa1 qa2 qa3 : qarity) q1 q2 q3 :=
  if 8 < qa1 then qzt_put3 qa1 qa2 qa3 q1 q2 q3 else
  qzt_put3rot qa1 qa2 qa3 q1 q2 q3.

Definition qzt_empty :=
  let mkn t := QztNode t t t t in
  let n2 := mkn (mkn QztNil) in QztHubNode (mkn n2) n2 n2 n2.

Definition normq q :=
  match q with
  | Qask1 qa => QaskLR qa Qask0 Qask0
  | QaskL qa ql => QaskLR qa ql Qask0
  | QaskR qa qr => QaskLR qa Qask0 qr
  | _ => q
  end.

Definition store_qz qz :=
  if qz is Quiz (QaskR qa1 q1) (QaskR qa2 q2) then
      match normq q1, normq q2 with
      | QaskLR qa1r q1l q1r, QaskLR qa2r q2l q2r =>
          if qa1r < qa2r then qzt_put qa1 qa2 qa1r q1l q2 q1r else
                              qzt_put qa1 qa2r qa2 q1 q2r q2l
      | QaskLR qa1r q1l q1r, _ => qzt_put qa1 qa2 qa1r q1l q2 q1r
      | _, QaskLR qa2r q2l q2r => qzt_put qa1 qa2r qa2 q1 q2r q2l
      | _, _ => fun t => t
      end
  else fun t => t.

Definition store_cf_qz qz (sym : bool) t :=
   store_qz qz (if sym then t else store_qz (flipqz qz) t).

Fixpoint cfquiz_tree_rec (qt : quiz_tree) (cfs : configseq)
          {struct cfs} : quiz_tree :=
  if cfs is Adds cf cfs' then
    if store_cf_qz (cfquiz cf) (cfsym cf) qt is QztHubNode t58 t9 t10 t11 then
      cfquiz_tree_rec (QztHubNode t58 t9 t10 t11) cfs'
    else QztNil
  else qt.

Definition cfquiz_tree := cfquiz_tree_rec qzt_empty.

(* Sanity checks; both computations should return the same result *)
(* (3361 for the full config list).                               *)

Fixpoint qzt_size (t : quiz_tree) : nat :=
  match t with
  | QztLeaf _ _ _ t' => S (qzt_size t')
  | QztNode t5 t6 t7 t8 =>
      qzt_size t5 + (qzt_size t6 + (qzt_size t7 + qzt_size t8))
  | QztHubNode t58 t9 t10 t11 =>
      qzt_size t58 + (qzt_size t9 + (qzt_size t10 + qzt_size t11))
  | _ => 0
  end.

Definition cf_main_arity cf :=
  if cfquiz cf is Quiz (QaskR qa _) _ then qa : nat else 0.

Definition cf_qzt_size1 cf :=
  let nperm := if cf_main_arity cf <= 8 then 3 else 1 in
  if cfsym cf then nperm else double nperm.

Definition cf_qzt_size := foldr (fun cf => plus (cf_qzt_size1 cf)) 0.

Definition configs_compiled cfs := qzt_size (cfquiz_tree cfs) = cf_qzt_size cfs.

(* end of sanity checks. *)

Fixpoint qzt_get1 (qa : qarity) (t : quiz_tree) {struct t} : quiz_tree :=
  match t, qa with
  | QztNode t' _ _ _, Qa5 => t'
  | QztNode _ t' _ _, Qa6 => t'
  | QztNode _ _ t' _, Qa7 => t'
  | QztNode _ _ _ t', Qa8 => t'
  | QztHubNode _ t' _ _, Qa9 => t'
  | QztHubNode _ _ t' _, Qa10 => t'
  | QztHubNode _ _ _ t', Qa11 => t'
  | QztHubNode t' _ _ _, _ => qzt_get1 qa t'
  | _, _ => QztNil
  end.

Definition qzt_get2 qa2 qa3 t := qzt_get1 qa3 (qzt_get1 qa2 t).

Definition qzt_get3 qa1 qa2 qa3 t := qzt_get2 qa2 qa3 (qzt_get1 qa1 t).

Section FitQuizTree.

Variables (cfs : configseq) (g : hypermap).
Hypothesis Hg : plain_cubic g.
Let De2 := plain_eq Hg.
Let Dn3 := cubic_eq Hg.

Lemma fit_normq : forall (x : g) q, fitq x (normq q) = fitq x q.
Proof. by move=> x q; case: q => *; rewrite /fitq /= ?cats0. Qed.

Variable x1 : g.
Notation x2 := (node x1).
Notation x3 := (node x2).
Let ax1 := qarity_of_nat (arity x1).
Let ax2 := qarity_of_nat (arity x2).
Let ax3 := qarity_of_nat (arity x3).

Notation "x '=a' y" := ((x : nat) =d arity y) (at level 70, only parsing).
Definition qzt_fita := and3b (ax1 =a x1) (ax2 =a x2) (ax3 =a x3).

Fixpoint qzt_fitl (t : quiz_tree) : bool :=
  if t is QztLeaf q1 q2 q3 t' then
      and3b (fitq (qstepR x1) q1) (fitq (qstepR x2) q2) (fitq (qstepR x3) q3)
    || qzt_fitl t'
  else false.

Definition qzt_fit t := qzt_fita && qzt_fitl (qzt_get3 ax1 ax2 ax3 t).

Notation quiz3 := (fun qa1 qa2 qa3 q1 q2 q3 =>
   Quiz (QaskR qa1 (QaskLR qa3 q1 q3)) (QaskR qa2 q2)).

Lemma qzt_get_put1 : forall qa qa' qr t,
    qa = qa' /\ qr (qzt_get1 qa t) = qzt_get1 qa (qzt_put1 qa' qr t)
 \/ qzt_get1 qa t = qzt_get1 qa (qzt_put1 qa' qr t).
Proof. move=> qa qa' qr; elim; auto; case qa'; auto; case qa; auto. Qed.

Let Hfp1 := qzt_get_put1.
Lemma qzt_fit_put3 : forall qa1 qa2 qa3 q1 q2 q3 t,
                     qzt_fit (qzt_put3 qa1 qa2 qa3 q1 q2 q3 t) ->
 fitqz (edge x2) (quiz3 qa1 qa2 qa3 q1 q2 q3) \/ qzt_fit t.
Proof.
move=> qa1 qa2 qa3 q1 q2 q3 t; case/andP=> [Hax]; rewrite /qzt_fit Hax.
rewrite /fitqz /= /eqd /= eqseqE -arity_face Enode /qstepR De2 /qstepL Dn3 -!catA.
rewrite /= 2!fitq_cat maps_adds eqseq_adds; case/and3P: Hax; do 3 move/eqP => <-.
rewrite /qzt_get3 /qzt_get2 /qzt_put3; set qr := QztLeaf q1 q2 q3.
case: (Hfp1 ax1 qa1 (qzt_put1 qa2 (qzt_put1 qa3 qr)) t) => [[<- <-]|<-]; auto.
case: (Hfp1 ax2 qa2 (qzt_put1 qa3 qr) (qzt_get1 ax1 t)) => [[<- <-]|<-]; auto.
case: (Hfp1 ax3 qa3 qr (qzt_get1 ax2 (qzt_get1 ax1 t))) => [[<- <-]|<-]; auto.
rewrite !set11 /= {1}[andb]lock andbC -lock; case/orP; auto.
Qed.

Lemma fitqz_rot : forall (y : g) qa1 qa2 qa3 q1 q2 q3,
  fitqz y (quiz3 qa1 qa2 qa3 q1 q2 q3)
   = fitqz (edge (face y)) (quiz3 qa3 qa1 qa2 q3 q1 q2).
Proof.
move=> y qa1 qa2 qa3 q1 q2 q3; rewrite /fitqz /= /eqd /= !eqseqE -!catA.
rewrite !fitq_cat !maps_adds !eqseq_adds /qstepL /qstepR !De2 Eface.
rewrite -{1}[node (edge y)]Enode !arity_face -{1 2}[edge y]Eedge De2 Dn3.
rewrite -{8 9}[y]De2 Eedge.
case: (qa1 =a y) => /=; last by rewrite !andbF.
congr andb; rewrite andbC -!andbA.
by case (qa2 =a edge y); last by rewrite /= !andbF.
Qed.

Lemma qzt_fit_put : forall qa1 qa2 qa3 q1 q2 q3 t,
   qzt_fit (qzt_put qa1 qa2 qa3 q1 q2 q3 t) ->
 (exists y : g, fitqz y (quiz3 qa1 qa2 qa3 q1 q2 q3)) \/ qzt_fit t.
Proof.
move=> qa1 qa2 qa3 q1 q2 q3 t; rewrite /qzt_put /qzt_put3rot.
case (8 < qa1); first by case/qzt_fit_put3; auto; left; exists (edge x2).
case/qzt_fit_put3; first by left; exists (edge x2).
case/qzt_fit_put3; first by rewrite fitqz_rot Enode; left; exists (edge x1).
case/qzt_fit_put3; auto.
by rewrite 2!fitqz_rot -[x1]Dn3 !Enode; left; exists (edge x3).
Qed.

Lemma fitqz_swap : forall (y : g) qa1 qa2 qa3 q1 q2 q3,
 fitqz y (quiz3 qa1 qa2 qa3 q1 q2 q3) =
   fitqz (face y) (Quiz (QaskR qa1 q1) (QaskR qa3 (QaskLR qa2 q3 q2))).
Proof.
move=> y qa1 qa2 qa3 q1 q2 q3; rewrite /fitqz /= /eqd /= !eqseqE -!catA.
rewrite !fitq_cat !maps_adds !eqseq_adds fitq_cat.
rewrite /qstepR /qstepL !De2 -{1}[node (edge y)]Enode !arity_face Eface.
by rewrite -{1 2}[edge y]Eedge De2 Dn3 -{10 11}[y]De2 Eedge; repeat BoolCongr.
Qed.

Lemma qzt_fit_store : forall qz t, qzt_fit (store_qz qz t) ->
  (isQuizR qz /\ exists y : g, fitqz y qz) \/ qzt_fit t.
Proof.
move=> [q1 q2] t; case: q1; auto; case: q2; auto => qa2 q2 qa1 q1 Hx.
set qz := Quiz _ _; set G := (exists y : g, fitqz y qz) \/ qzt_fit t.
suffice: G by move=> [H|H]; [ left; split | right ].
have HxG1: forall qa1r q1l q1r, normq q1 = QaskLR qa1r q1l q1r ->
    qzt_fit (qzt_put qa1 qa2 qa1r q1l q2 q1r t) -> G.
  move=> qa1r q1l q1r Dq1'; case/qzt_fit_put; last by right.
  move=> [y Hy]; left; exists y; move: Hy; rewrite -Dq1' /fitqz /eqd /= !eqseqE.
  by rewrite fitq_cat fit_normq -fitq_cat.
have HxG2: forall qa2r q2l q2r, normq q2 = QaskLR qa2r q2l q2r ->
    qzt_fit (qzt_put qa1 qa2r qa2 q1 q2r q2l t) -> G.
  move=> qa2r q2l q2r Dq2'; case/qzt_fit_put; last by right.
  move=> [y Hy]; left; exists (face y); apply: etrans Hy.
  rewrite fitqz_swap -Dq2' /fitqz /eqd /= !eqseqE !fitq_cat !maps_adds.
  by rewrite !eqseq_adds !andbA; congr andb; symmetry; apply: fit_normq.
move: Hx; simpl; case: {-1}(normq q1) (erefl (normq q1));
 case: {-1}(normq q2) (erefl (normq q2)); first [ by right | eauto ].
move=> qa2r q2l q2r Dq2 qa1r q1l q1r Dq1; case (qa1r < qa2r); eauto.
Qed.

Lemma qzt_fit_store_cf : forall qz sym t, qzt_fit (store_cf_qz qz sym t) ->
    isQuizR qz /\ ((exists y : g, fitqz y qz) \/ (exists y : mirror g, fitqz y qz))
 \/ qzt_fit t.
Proof.
move=> qz sym t; rewrite /store_cf_qz /=.
case: sym; repeat case/qzt_fit_store; auto; move=> [Hqz Hgqz]; left;
 try by split; auto.
have Hqz': (isQuizR qz) by case: (qz) Hqz => [q1 q2]; case q1; case q2.
split; auto; right; case: Hgqz => [y Hy]; rewrite fitqz_flip //= in Hy.
by exists (face y).
Qed.

Lemma qzt_fit_cfquiz : forall cfs, qzt_fit (cfquiz_tree cfs) ->
 exists2 cf, cfs cf &
 exists2 qz, (exists y : g, fitqz y qz) \/ (exists y : mirror g, fitqz y qz)
          & embeddable (cfring cf) /\ (exists u, valid_quiz (cfring cf) u qz).
Proof.
move=> cfs'; rewrite /cfquiz_tree.
have: qzt_fit qzt_empty = false.
  by rewrite /qzt_fit andbC; case: ax1 => //; case: ax2 => //; case ax3.
elim: cfs' qzt_empty => [|cf cfs' Hrec] qt0 Hqt0 /=; first by rewrite Hqt0.
have Hqt00: qzt_fit QztNil = false by apply: andbF.
set qt := store_cf_qz _ _ qt0.
case Dqt: qt => [|q1 q2 q3 t|t5 t6 t7 t8|t58 t9 t10 t11]; try by rewrite Hqt00.
 rewrite -{t58 t9 t10 t11}Dqt => Hqt'; case Hqt: (qzt_fit qt).
  case/qzt_fit_store_cf: Hqt; last by rewrite Hqt0.
  move=> [Hqz Hgqz]; exists cf; [ apply: setU11 | exists (cfquiz cf); auto ].
  by split; [ apply embeddable_cfquiz | apply valid_cfquiz ].
  case: {Hrec Hqt' Hqt}(Hrec _ Hqt Hqt') => [cf' Hcf' Hx].
by exists cf'; first by apply setU1r.
Qed.

Definition qzt_truncate t :=
  if t is  QztHubNode (QztNode _ _ _ _ as t58) _ _ _ then t58 else t.

Lemma qzt_get1_truncate : forall qa t,
 let t' := qzt_get1 qa (qzt_truncate t) in
 qzt_proper t' -> t' = qzt_get1 qa t.
Proof. by do 3 case=> //. Qed.

End FitQuizTree.

(*  global sanity check, using the functions define above
Require configurations.

Eval Compute in (qzt_size (cfquiz_tree the_configs)).
Eval Compute in (cf_qzt_size the_configs).
Goal (configs_compiled the_configs).
Split.
Save the_configs_compiled.
*)

Unset Implicit Arguments.


Require Import os_code_defs.
Require Import os_ucos_h.

Local Open Scope code_scope.

Definition PlaceHolder:= &ₐ OSPlaceHolder′.

(*
Definition OSTaskChangePrio_impl :=
Int32 ·OSTaskChangePrio·(⌞oldprio @ Int8u; newprio @ Int8u⌟)··{
      ⌞
        ptcb @ OS_TCB∗;
        x @ Int8u;
        y @ Int8u;
        bitx @ Int8u;
        bity @ Int8u
      ⌟;

      If( (oldprio′ ≥ ′OS_LOWEST_PRIO &&ₑ oldprio′ !=ₑ ′OS_PRIO_SELF) ||ₑ (newprio′ ≥ ′OS_LOWEST_PRIO) )
      {
        RETURN ′OS_PRIO_INVALID
      };ₛ

      ENTER_CRITICAL;ₛ
      If (OSTCBPrioTbl′[newprio′] !=ₑ NULL) (*newprio exist or newprio is vhold*)
      {
        EXIT_CRITICAL;ₛ
        RETURN ′OS_PRIO_EXIST
      };ₛ

      If (oldprio′ ==ₑ ′OS_PRIO_SELF)
      {
        oldprio′ =ₑ OSTCBCur′→OSTCBPrio
      };ₛ

      If (OSTCBPrioTbl′[oldprio′] ==ₑ NULL)
      {
        EXIT_CRITICAL;ₛ
        RETURN ′OS_PRIO_ERR
      };ₛ

      If (OSTCBPrioTbl′[oldprio′] ==ₑ PlaceHolder)
      {
        EXIT_CRITICAL;ₛ
        RETURN ′OS_PRIO_ERR
      };ₛ

      y′ =ₑ ′newprio ≫ ′3;ₛ
      bity′ =ₑ ′OSMapTbl[′y];ₛ
      x′ =ₑ ′newprio &ₑ ′7;ₛ
      bitx′ =ₑ ′OSMapTbl[′x];ₛ

      ptcb′ =ₑ OSTCBPrioTbl′[oldprio′];ₛ
      OSTCBPrioTbl′[oldprio′] =ₑ NULL;ₛ

      IF((OSRdyTbl′[ptcb′→OSTCBY] &&ₑ ptcb′→OSTCBBitX) !=ₑ ′0)
      {
        OS_RdyTblClearBit(ptcb′);ₛ
        OSRdyGrp′ =ₑ ′OSRdyGrp |ₑ ′bity;ₛ
        OSRdyTbl′[y′] =ₑ ′OSRdyTbl[y′] |ₑ ′bitx
      }
      ELSE
      {
        pevent′ =ₑ ′ptcb→OSTCBEventPtr;ₛ
        If(pevent′ !=ₑ NULL)
        {
          pevent′→OSEventTbl[ptcb′→OSTCBY] &= ∼ptcb′→OSTCBBitX;ₛ
          If(pevent′→OSEventTbl[ptcb′→OSTCBY] ==ₑ ′0)
          {
            pevent′→OSEventGrp &= ′ptcb→OSTCBBitY
          };ₛ
          pevent′→OSEventGrp =ₑ pevent′→OSEventGrp |ₑ ′bity;ₛ
          pevent′→OSEventTbl[y′] =ₑ pevent′→OSEventTbl[y′] |ₑ ′bitx
        }
      };ₛ

      OSTCBPrioTbl′[newprio′] =ₑ ′ptcb;ₛ
      ptcb′→OSTCBPrio =ₑ ′newprio;ₛ
      ptcb′→OSTCBY =ₑ ′y;ₛ
      ptcb′→OSTCBX =ₑ ′x;ₛ
      ptcb′→OSTCBBitY =ₑ ′bity;ₛ
      ptcb′→OSTCBBitX =ₑ ′bitx;ₛ

      EXIT_CRITICAL;ₛ
      OS_Sched();ₛ
      RETURN ′OS_NO_ERR
 }·.
*)
Definition STKINIT (a : expr * expr * expr ) :=
  let ( vt, v3 ) := a in let (v1, v2) := vt in  sprim (stkinit v1 v2 v3).

Definition OSTaskCreate_impl :=
Int8u ·OSTaskCreate·(⌞task @ Void∗; pdata @ Void∗; prio @ Int8u⌟)··{
       ⌞ err @ Int8u⌟;

       If(prio′ >ₑ ′OS_LOWEST_PRIO) {
           RETURN ′OS_PRIO_INVALID
       };ₛ

       ENTER_CRITICAL;ₛ
       If (OSTCBPrioTbl′[prio′] ==ₑ NULL){
           (*OSTCBPrioTbl′[prio′] =ₑ ′ 1;ₛ (*Fix Me*)
           EXIT_CRITICAL;ₛ *)

           err′ =ᶠ OS_TCBInit(·prio′ (*, task′, pdata′*) ·);ₛ
           IF (err′ ==ₑ ′OS_NO_ERR) {
               (*ENTER_CRITICAL;ₛ*)
               STKINIT (task′, pdata′,  OSTCBPrioTbl′[prio′ ]);ₛ
               (* ++ OSTaskCtr′;ₛ *)
               EXIT_CRITICAL;ₛ
               (* If (OSRunning′ ==ₑ CTrue) { *)
                OS_Sched()
               (* } *)
           }ELSE{
               (*ENTER_CRITICAL;ₛ*)
               (* OSTCBPrioTbl′[prio′] =ₑ NULL;ₛ *)
               EXIT_CRITICAL
           };ₛ
           RETURN  err′
       };ₛ
       EXIT_CRITICAL;ₛ
       RETURN  ′OS_PRIO_EXIST
}·.

Definition STKFREE (a : expr ) :=
  sprim (stkfree a).

Require Import inline_definitions.
Require Import inline_bittblfunctions.

Definition OSTaskDel_impl :=
Int8u ·OSTaskDel·(⌞prio @ Int8u⌟)··{
      ⌞
        pevent @ OS_EVENT∗;
        ptcb @ OS_TCB∗;
        self @ Int8u;
        x @ OS_TCB∗
      ⌟;
(*
      If (OSIntNesting′ >ₑ ′0){
          RETURN (OSTaskDel) ′OS_TASK_DEL_ISR
      };ₛ
*)

      If (prio′ ==ₑ ′OS_IDLE_PRIO) {
          RETURN ′OS_TASK_DEL_IDLE
      };ₛ
      If (prio′ ≥ ′OS_LOWEST_PRIO (* &&ₑ prio′ !=ₑ ′OS_PRIO_SELF *)){
          RETURN ′OS_PRIO_INVALID
      };ₛ
      ENTER_CRITICAL;ₛ
      (* If(prio′ ==ₑ ′OS_PRIO_SELF)
       * {
       *     prio′ =ₑ OSTCBCur′→OSTCBPrio;ₛ
       *     If (prio′ ==ₑ ′OS_IDLE_PRIO)
       *     {
       *       EXIT_CRITICAL;ₛ
       *       RETURN ′OS_TASK_DEL_IDLE
       *     }
       * };ₛ        *)
      ptcb′ =ₑ OSTCBPrioTbl′[prio′];ₛ

     If (ptcb′ ==ₑ NULL){
        EXIT_CRITICAL;ₛ
        RETURN ′OS_TASK_DEL_ERR
      };ₛ
      If (ptcb′ ==ₑ PlaceHolder){
        EXIT_CRITICAL;ₛ
        RETURN ′OS_TASK_DEL_ERR
      };ₛ
      self′ =ᶠ OS_IsSomeMutexOwner(·ptcb′·);ₛ
      If (self′==ₑ ′ 1){
        EXIT_CRITICAL;ₛ
        RETURN ′OS_TASK_DEL_SOME_MUTEX_OWNER
      };ₛ
      If (ptcb′→OSTCBNext ==ₑ NULL){
        EXIT_CRITICAL;ₛ
        RETURN ′OS_TASK_DEL_HAS_NO_NEXT
      };ₛ

      (* If (ptcb′ !=ₑ NULL){ *)

      inline_call inline_bittbl_clearbit ((OSRdyGrp ′):: (OSRdyTbl ′)::(ptcb ′ → OSTCBBitX)::(ptcb ′ → OSTCBBitY)::(ptcb ′ → OSTCBY)::nil);ₛ

      (* OSRdyTbl′[ptcb′→OSTCBY] &= ∼ptcb′→OSTCBBitX;ₛ
       * If(OSRdyTbl′[ptcb′→OSTCBY] ==ₑ ′0){
       *     OSRdyGrp′  &= ∼ptcb′→OSTCBBitY
       * };ₛ *)
      pevent′ =ₑ ptcb′→OSTCBEventPtr;ₛ
      If (pevent′ !=ₑ NULL){

          inline_call inline_bittbl_clearbit ((pevent′→OSEventGrp):: (pevent′→OSEventTbl)::(ptcb ′ → OSTCBBitX)::(ptcb ′ → OSTCBBitY)::(ptcb ′ → OSTCBY)::nil)
          (* pevent′→OSEventTbl[ptcb′→OSTCBY] =ₑ pevent′→OSEventTbl[ptcb′→OSTCBY] &ₑ (∼ptcb′→OSTCBBitX);ₛ
           * If(pevent′→OSEventTbl[ptcb′→OSTCBY] ==ₑ ′0){
           *     pevent′→OSEventGrp =ₑ pevent′→OSEventGrp &ₑ (∼ptcb′→OSTCBBitY)
           * } *)
      };ₛ
      ptcb′→OSTCBDly =ₑ ′0;ₛ
      ptcb′→OSTCBStat =ₑ ′OS_STAT_RDY;ₛ
      (* −−OSTaskCtr′;ₛ *)
      OSTCBPrioTbl′[prio′] =ₑ NULL;ₛ
      ptcb′→OSTCBEventPtr =ₑ NULL;ₛ
      IF (ptcb′→OSTCBPrev ==ₑ NULL){
          x ′=ₑ ptcb′→OSTCBNext;ₛ
          x′→OSTCBPrev =ₑ NULL;ₛ
          OSTCBList′ =ₑ x′
      }ELSE{
          x′ =ₑ ptcb′→OSTCBPrev;ₛ
          x′→OSTCBNext =ₑ ptcb′→OSTCBNext;ₛ
          x′ =ₑ ptcb′→OSTCBNext;ₛ
          x′→OSTCBPrev =ₑ ptcb′→OSTCBPrev
      };ₛ
      ptcb′→OSTCBNext =ₑ OSTCBFreeList′;ₛ
      OSTCBFreeList′ =ₑ ptcb′;ₛ
      STKFREE (    ptcb′  );ₛ
      ptcb′→OSTCBflag =ₑ ′0;ₛ
      EXIT_CRITICAL;ₛ
      OS_Sched();ₛ
      RETURN ′OS_NO_ERR
      (* };ₛ *)
      (* EXIT_CRITICAL;ₛ *)
      (* RETURN ′OS_TASK_DEL_ERR *)
}·.

(* ** ac: Check (inline_call inline_bittbl_clearbit ((OSRdyGrp ′):: (OSRdyTbl ′)::(ptcb ′ → OSTCBBitX)::(ptcb ′ → OSTCBBitY)::(ptcb ′ → OSTCBY)::nil)) . *)
(* ** ac: Eval simpl in (inline_call inline_bittbl_clearbit ((OSRdyGrp ′):: (OSRdyTbl ′)::(ptcb ′ → OSTCBBitX)::(ptcb ′ → OSTCBBitY)::(ptcb ′ → OSTCBY)::nil)). *)

(* Eval simpl in (          inline_call inline_bittbl_clearbit ((pevent′→OSEventGrp):: (pevent′→OSEventTbl)::(ptcb ′ → OSTCBBitX)::(ptcb ′ → OSTCBBitY)::(ptcb ′ → OSTCBY)::nil)
 *)
(*               ). *)


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coqlib.
Require Import Maps.
Require Import ASTExtra.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Stacklayout.
Require Import Globalenvs.
Require Import AsmX.
Require Import Smallstep.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import FlatMemory.
Require Import CommonTactic.
Require Import AuxLemma.
Require Import RealParams.
Require Import PrimSemantics.
Require Import LAsm.
Require Import XOmega.

Require Import compcert.cfrontend.Ctypes.
Require Import Conventions.
Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compat.CompatLayers.

Require Import AbstractDataType.
Require Import Soundness.

Require Import SecurityCommon.
Require Import FunctionalExtensionality.

Open Scope Z_scope.

(* This file defines the observation function for mCertiKOS.
   Paper Reference: Section 4 *)

Section WITHMEM.

  Context `{Hstencil: Stencil}.
  Context `{Hmem: Mem.MemoryModel}.
  Context `{Hmwd: UseMemWithData mem}.
  Context `{Hcomp: CompatData RData}.

  (* A typeclass for defining observation functions over mCertiKOS abstract state
     (type cdata RData). As in the paper, the function takes both a principal
     and a state as parameters, and produces a value of an arbitrary observation type.
     Observable equivalence is defined to be equality of observations.
     We add a property over principals to allow for distinguishing trusted processes
     from untrusted processes (the final security proof will only apply to principals
     for which the property holds). *)
  Class Observer (obs : Type) :=
    {
      obs_id : Z;
      obs_id_prop: obs_id > high_id;

      observe : cdata RData -> obs;
      obs_eq s1 s2 := observe s1 = observe s2
    }.

  Lemma obs_eq_equiv {obs} {o : Observer obs} : Equivalence (obs_eq(Observer:=o)).
  Proof.
    constructor; unfold obs_eq; congruence.
  Qed.

  Section OBS_EQ.

    (* This is the virtual address space observation function, which produces
       an option value for each virtual address location, based on whether
       that location is mapped in the process's page tables. As explained in
       the paper, it is *crucial* that this observation hides physical
       address locations like the pi variable below (pi is the physical
       page index; "PTADRR pi vadr" is defined as pi*PGSIZE + (vadr % PGSIZE)). *)

    Function vread i vadr (ptp: PMapPool) (hp : FlatMem.flatmem) :=
      (* User space addresses are between constants adr_low and adr_high *)
      if zle_lt adr_low vadr adr_high then
        (* first level of page tables *)
        match ZMap.get (PDX vadr) (ZMap.get i ptp) with
          | PDEValid _ pte =>
            (* second level of page tables *)
            match ZMap.get (PTX vadr) pte with
              | PTEValid pi _ => Some (ZMap.get (PTADDR pi vadr) hp)
              | _ => None
            end
          | _ => None
        end
      else None.

    (* Various permission bits in the page tables must be observable. This
       is mostly only needed for the SafeSecure lemma. *)

    Inductive ObsPerm :=
    | ObsValid : PTPerm -> PPgInfo -> ObsPerm
    | ObsPDEID : ObsPerm
    | ObsPDEUnPresent : ObsPerm
    | ObsPDEUndef : ObsPerm
    | ObsPTEUnPresent : ObsPerm
    | ObsPTEUndef : ObsPerm.

    Function vread_perm i vadr (ptp: PMapPool) (pp : PPermT) :=
      if zle_lt adr_low vadr adr_high then
        match ZMap.get (PDX vadr) (ZMap.get i ptp) with
          | PDEValid _ pte =>
            match ZMap.get (PTX vadr) pte with
              | PTEValid v p => Some (ObsValid p (ZMap.get v pp))
              | PTEUnPresent => Some ObsPTEUnPresent
              | PTEUndef => Some ObsPTEUndef
            end
          | PDEUnPresent => Some ObsPDEUnPresent
          | PDEID => Some ObsPDEID
          | PDEUndef => Some ObsPDEUndef
        end
      else None.

    (* The type of observations over abstract data *)
    Record my_obs :=
      {
        observe_HP: Z -> option FlatMem.flatmem_val;
        observe_perm: Z -> option ObsPerm;
        observe_AC_quota: Z;
        observe_AC_nchildren: nat;
        observe_AC_used: bool;
        observe_cid: bool;
        observe_kctxt: regset;
        observe_uctxt: UContext;
        observe_ti: option int;
        observe_OUT: list DeviceAction;
        observe_ikern: option bool;
        observe_ihost: option bool;
        observe_pg: option bool;
        observe_ipt: option bool;
        observe_init: option bool
      }.

    (* For some reason, the f_equal tactic takes an extremely long time for this definition
       of my_obs (too many fields maybe?). Following is a specialization of the tactic
       that terminates immediately. *)
    Fact f_equal_my_obs :
      forall a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15
             b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15,
        a1 = b1 -> a2 = b2 -> a3 = b3 -> a4 = b4 -> a5 = b5 ->
        a6 = b6 -> a7 = b7 -> a8 = b8 -> a9 = b9 -> a10 = b10 ->
        a11 = b11 -> a12 = b12 -> a13 = b13 -> a14 = b14 -> a15 = b15 ->
        Build_my_obs a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 =
        Build_my_obs b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15.
    Proof.
      intros; subst; reflexivity.
    Qed.

    (* The observation function for abstract data.
       Paper Reference: Section 4 *)
    Definition my_observe (i: Z) (d: cdata RData) : my_obs :=
      {|
        observe_HP vadr:= vread i vadr (ptpool d) (HP d);
        observe_perm vadr:= vread_perm i vadr (ptpool d) (pperm d);
        observe_AC_quota:=
          cquota (ZMap.get i (AC d)) - cusage (ZMap.get i (AC d));
        observe_AC_nchildren:= length (cchildren (ZMap.get i (AC d)));
        observe_AC_used:= cused (ZMap.get i (AC d));
        observe_cid:= zeq i (cid d);
        observe_kctxt:= ZMap.get i (kctxt d);
        observe_uctxt:= ZMap.get i (uctxt d);
        observe_ti:= if zeq i (cid d) then Some (fst (ti d)) else None;
        observe_OUT:= ZMap.get i (devout d);

        (* the following global flags only need to be observable for the SafeSecure proof *)
        observe_ikern:= if zeq i (cid d) then Some (ikern d) else None;
        observe_ihost:= if zeq i (cid d) then Some (ihost d) else None;
        observe_pg:= if zeq i (cid d) then Some (pg d) else None;
        observe_ipt:= if zeq i (cid d) then Some (ipt d) else None;
        observe_init:= if zeq i (cid d) then Some (init d) else None
      |}.

    (* An observable equivalence relation defined for convenience *)
    Record my_obs_eq (i: Z) (d1 d2: cdata RData) :=
      {
        obs_eq_HP:
          forall vadr,
            vread i vadr (ptpool d1) (HP d1) = vread i vadr (ptpool d2) (HP d2);
        obs_eq_perm:
          forall vadr,
            vread_perm i vadr (ptpool d1) (pperm d1) = vread_perm i vadr (ptpool d2) (pperm d2);
        obs_eq_AC_quota:
          cquota (ZMap.get i (AC d1)) - cusage (ZMap.get i (AC d1)) =
          cquota (ZMap.get i (AC d2)) - cusage (ZMap.get i (AC d2));
        obs_eq_AC_nchildren: length (cchildren (ZMap.get i (AC d1))) =
                             length (cchildren (ZMap.get i (AC d2)));
        obs_eq_AC_used: cused (ZMap.get i (AC d1)) = cused (ZMap.get i (AC d2));
        obs_eq_cid: i = cid d1 <-> i = cid d2;
        obs_eq_kctxt: ZMap.get i (kctxt d1) = ZMap.get i (kctxt d2);
        obs_eq_uctxt: ZMap.get i (uctxt d1) = ZMap.get i (uctxt d2);
        obs_eq_ti: i = cid d1 -> fst (ti d1) = fst (ti d2);
        obs_eq_OUT: ZMap.get i (devout d1) = ZMap.get i (devout d2);
        obs_eq_ikern: i = cid d1 -> ikern d1 = ikern d2;
        obs_eq_ihost: i = cid d1 -> ihost d1 = ihost d2;
        obs_eq_pg: i = cid d1 -> pg d1 = pg d2;
        obs_eq_ipt: i = cid d1 -> ipt d1 = ipt d2;
        obs_eq_init: i = cid d1 -> init d1 = init d2
      }.

    (* Proof that the observable equivalence relation is
       consistent with the observation function *)
    Lemma my_obs_eq_convert :
      forall i d1 d2, my_obs_eq i d1 d2 <-> my_observe i d1 = my_observe i d2.
    Proof.
      intros i d1 d2; split; intro.
      - unfold my_observe.
        apply f_equal_my_obs.
        + extensionality vadr; apply obs_eq_HP; auto.
        + extensionality vadr; apply obs_eq_perm; auto.
        + apply obs_eq_AC_quota; auto.
        + apply obs_eq_AC_nchildren; auto.
        + apply obs_eq_AC_used; auto.
        + destruct (zeq i (cid d1)); destruct (zeq i (cid d2)); simpl; auto.
          erewrite obs_eq_cid in e; eauto; contradiction.
          erewrite <- obs_eq_cid in e; eauto; contradiction.
        + apply obs_eq_kctxt; auto.
        + apply obs_eq_uctxt; auto.
        + destruct (zeq i (cid d1)); destruct (zeq i (cid d2)); simpl; auto.
          f_equal; eapply obs_eq_ti; eauto.
          erewrite obs_eq_cid in e; eauto; contradiction.
          erewrite <- obs_eq_cid in e; eauto; contradiction.
        + apply obs_eq_OUT; auto.
        + destruct (zeq i (cid d1)); destruct (zeq i (cid d2)); simpl; auto.
          f_equal; eapply obs_eq_ikern; eauto.
          erewrite obs_eq_cid in e; eauto; contradiction.
          erewrite <- obs_eq_cid in e; eauto; contradiction.
        + destruct (zeq i (cid d1)); destruct (zeq i (cid d2)); simpl; auto.
          f_equal; eapply obs_eq_ihost; eauto.
          erewrite obs_eq_cid in e; eauto; contradiction.
          erewrite <- obs_eq_cid in e; eauto; contradiction.
        + destruct (zeq i (cid d1)); destruct (zeq i (cid d2)); simpl; auto.
          f_equal; eapply obs_eq_pg; eauto.
          erewrite obs_eq_cid in e; eauto; contradiction.
          erewrite <- obs_eq_cid in e; eauto; contradiction.
        + destruct (zeq i (cid d1)); destruct (zeq i (cid d2)); simpl; auto.
          f_equal; eapply obs_eq_ipt; eauto.
          erewrite obs_eq_cid in e; eauto; contradiction.
          erewrite <- obs_eq_cid in e; eauto; contradiction.
        + destruct (zeq i (cid d1)); destruct (zeq i (cid d2)); simpl; auto.
          f_equal; eapply obs_eq_init; eauto.
          erewrite obs_eq_cid in e; eauto; contradiction.
          erewrite <- obs_eq_cid in e; eauto; contradiction.
      - inv H; constructor; auto;
          try solve [destruct (zeq i (cid d1)); destruct (zeq i (cid d2)); inv H6; intuition].
        + apply equal_f; auto.
        + apply equal_f; auto.
    Qed.

  End OBS_EQ.

  Section WITHOBS.

    Variable id : Z.

    Hypothesis id_prop: id > high_id.

    Instance user_observer : Observer my_obs.
    Proof.
      apply (Build_Observer _ id id_prop (my_observe id)).
    Defined.

  End WITHOBS.

End WITHMEM.

  Lemma quota_convert :
    forall x y, (x <? y) = (0 <? y - x).
  Proof.
    intros.
    destruct (x <? y) eqn:H1; destruct (0 <? y - x) eqn:H2; auto.
    rewrite Z.ltb_lt in H1; rewrite Z.ltb_nlt in H2; omega.
    rewrite Z.ltb_nlt in H1; rewrite Z.ltb_lt in H2; omega.
  Qed.

  Lemma quota_convert' :
    forall x y, (cusage x <? cquota y) = (0 <? cquota y - cusage x).
  Proof.
    intros; apply quota_convert.
  Qed.

  Close Scope Z_scope.

  Ltac obs_eq_rewrite Hobs_eq :=
      try rewrite <- (obs_eq_HP _ _ _ Hobs_eq) in *;
      try rewrite quota_convert' in *;
      try rewrite <- (obs_eq_AC_quota _ _ _ Hobs_eq) in *;
      try rewrite <- (obs_eq_AC_nchildren _ _ _ Hobs_eq) in *;
      try rewrite <- (obs_eq_AC_used _ _ _ Hobs_eq) in *;
      try match goal with
            | [ H : id = cid ?d |- _ ] =>
              rewrite <- H in *;
              rewrite <- (proj1 (obs_eq_cid _ _ _ Hobs_eq)) in *; auto
          end;
      auto; try rewrite <- (obs_eq_kctxt _ _ _ Hobs_eq) in *;
      try rewrite <- (obs_eq_uctxt _ _ _ Hobs_eq) in *;
      try rewrite <- (obs_eq_OUT _ _ _ Hobs_eq) in *;
      try rewrite <- (obs_eq_ti _ _ _ Hobs_eq) in *; auto.

  Ltac obs_eq_rewrites Hobs_eq := repeat obs_eq_rewrite Hobs_eq.

  Ltac solve_obs_eq Hobs_eq :=
    destruct Hobs_eq; constructor; simpl; auto; zmap_solve; try congruence.


Require Import Coq.Sorting.Permutation.
Require Import Coq.Sorting.Sorting.
Require Import Coq.Structures.Orders.
Require Import VST.veric.base.
Require Import VST.veric.Clight_lemmas.
Require Import VST.veric.type_induction.
Require Import VST.veric.composite_compute.

(* This file contains three computational align criteria.
   1: the hardware alignof is not larger than alignof (and additional criterion for array).
   2: all fields are aligned as hardware requires. size as a multiple of hardware alignof.
   3: all value is well-aligned stored.
   The third one is the final specification we want. *)

Section align_compatible_rec.

Context (cenv: composite_env).

Inductive align_compatible_rec: type -> Z -> Prop :=
| align_compatible_rec_by_value: forall t ch z, access_mode t = By_value ch -> (Memdata.align_chunk ch | z) -> align_compatible_rec t z
| align_compatible_rec_Tarray: forall t n a z, (forall i, 0 <= i < n -> align_compatible_rec t (z + sizeof cenv t * i)) -> align_compatible_rec (Tarray t n a) z
| align_compatible_rec_Tstruct: forall i a co z, cenv ! i = Some co -> (forall i0 t0 z0, field_type i0 (co_members co) = Errors.OK t0 -> field_offset cenv i0 (co_members co) = Errors.OK z0 -> align_compatible_rec t0 (z + z0)) -> align_compatible_rec (Tstruct i a) z
| align_compatible_rec_Tunion: forall i a co z, cenv ! i = Some co -> (forall i0 t0, field_type i0 (co_members co) = Errors.OK t0 -> align_compatible_rec t0 z) -> align_compatible_rec (Tunion i a) z.

Lemma align_compatible_rec_by_value_inv : forall t ch z,
  access_mode t = By_value ch ->
  align_compatible_rec t z -> (Memdata.align_chunk ch | z).
Proof.
  intros.
  inv H0.
  + rewrite H in H1; inv H1; auto.
  + inv H.
  + inv H.
  + inv H.
Qed.

Lemma align_compatible_rec_Tarray_inv: forall t n a z,
  align_compatible_rec (Tarray t n a) z ->
  (forall i : Z, 0 <= i < n -> align_compatible_rec t (z + sizeof cenv t * i)).
Proof.
  intros.
  inv H.
  + inv H1.
  + auto.
Qed.

Lemma align_compatible_rec_Tstruct_inv: forall i a co z,
  cenv ! i = Some co ->
  align_compatible_rec (Tstruct i a) z ->
  (forall i0 t0 z0, field_type i0 (co_members co) = Errors.OK t0 -> field_offset cenv i0 (co_members co) = Errors.OK z0 -> align_compatible_rec t0 (z + z0)).
Proof.
  intros.
  inv H0.
  + inv H3.
  + rewrite H in H5; inv H5.
    eauto.
Qed.

Lemma align_compatible_rec_Tunion_inv: forall i a co z,
  cenv ! i = Some co ->
  align_compatible_rec (Tunion i a) z ->
  (forall i0 t0, field_type i0 (co_members co) = Errors.OK t0 -> align_compatible_rec t0 z).
Proof.
  intros.
  inv H0.
  + inv H2.
  + rewrite H in H4; inv H4.
    eauto.
Qed.

End align_compatible_rec.

Lemma align_chunk_1248: forall ch, align_chunk ch = 1 \/ align_chunk ch = 2 \/ align_chunk ch = 4 \/ align_chunk ch = 8.
Proof.
  intros.
  destruct ch; simpl;
  auto.
Qed.

Lemma align_chunk_two_p:
  forall ch, exists n, align_chunk ch = two_power_nat n.
Proof.
  intros.
  pose proof align_chunk_1248 ch as [| [| [|]]]; rewrite H.
  + exists 0%nat; auto.
  + exists 1%nat; auto.
  + exists 2%nat; auto.
  + exists 3%nat; auto.
Qed.

Fixpoint hardware_alignof (ha_env: PTree.t Z) t: Z :=
  match t with
  | Tarray t' _ _ => hardware_alignof ha_env t'
  | Tstruct id _ =>
      match ha_env ! id with
      | Some ha => ha
      | None => 1
      end
  | Tunion id _ =>
      match ha_env ! id with
      | Some ha => ha
      | None => 1
      end
  | _ => match access_mode t with
         | By_value ch => Memdata.align_chunk ch
         | _ => 1
         end
  end.

Fixpoint hardware_alignof_composite (ha_env: PTree.t Z) (m: members): Z :=
  match m with
  | nil => 1
  | (_, t) :: m' => Z.max (hardware_alignof ha_env t) (hardware_alignof_composite ha_env m')
  end.

Definition hardware_alignof_env (cenv: composite_env): PTree.t Z :=
  let l := composite_reorder.rebuild_composite_elements cenv in
  fold_right (fun (ic: positive * composite) (T0: PTree.t Z) => let (i, co) := ic in let T := T0 in PTree.set i (hardware_alignof_composite T (co_members co)) T) (PTree.empty _) l.

Definition hardware_alignof_env_consistent (cenv: composite_env) (ha_env: PTree.t Z): Prop :=
  forall i co ha,
    cenv ! i = Some co ->
    ha_env ! i = Some ha ->
    ha = hardware_alignof_composite ha_env (co_members co).

Definition hardware_alignof_env_complete (cenv: composite_env) (ha_env: PTree.t Z): Prop :=
  forall i,
    (exists co, cenv ! i = Some co) <->
    (exists ha, ha_env ! i = Some ha).

Module Type HARDWARE_ALIGNOF_FACTS.

  Axiom hardware_alignof_consistency:
    forall (cenv: composite_env) (ha_env: PTree.t Z),
      composite_env_consistent cenv ->
      ha_env = hardware_alignof_env cenv ->
      hardware_alignof_env_consistent cenv ha_env.

  Axiom hardware_alignof_completeness:
    forall (cenv: composite_env) (ha_env: PTree.t Z),
      ha_env = hardware_alignof_env cenv ->
      hardware_alignof_env_complete cenv ha_env.

End HARDWARE_ALIGNOF_FACTS.

Module hardware_alignof_facts: HARDWARE_ALIGNOF_FACTS.

Lemma aux1: forall T co,
  (fix fm (l : list (ident * type * Z)) : Z :=
     match l with
     | nil => 1
     | (_, _, ha) :: l' => Z.max ha (fm l')
     end)
    (map
       (fun it0 : positive * type =>
        let (i0, t0) := it0 in
        (i0, t0,
        type_func.F
          (fun t : type =>
           match access_mode t with
           | By_value ch => align_chunk ch
           | By_reference => 1
           | By_copy => 1
           | By_nothing => 1
           end) (fun (ha : Z) (_ : type) (_: Z) (_ : attr) => ha)
          (fun (ha : Z) (_ : ident) (_ : attr) => ha)
          (fun (ha : Z) (_ : ident) (_ : attr) => ha) T t0)) (co_members co)) =
                    hardware_alignof_composite T (co_members co).
Proof.
  intros; unfold hardware_alignof_composite, hardware_alignof.
  induction (co_members co) as [| [i t] ?].
  + auto.
  + simpl.
    f_equal; auto.
    clear.
    induction t; auto.
Qed.

Lemma aux2: forall (cenv: composite_env),
  type_func.Env
          (fun t : type =>
           match access_mode t with
           | By_value ch => align_chunk ch
           | By_reference => 1
           | By_copy => 1
           | By_nothing => 1
           end) (fun (ha : Z) (_ : type) (_: Z) (_ : attr) => ha)
          (fun (ha : Z) (_ : ident) (_ : attr) => ha)
          (fun (ha : Z) (_ : ident) (_ : attr) => ha)
          (fun _ : struct_or_union =>
           fix fm (l : list (ident * type * Z)) : Z :=
             match l with
             | nil => 1
             | (_, _, ha) :: l' => Z.max ha (fm l')
             end) (composite_reorder.rebuild_composite_elements cenv) =
  hardware_alignof_env cenv.
Proof.
  intros.
  unfold type_func.Env, type_func.env_rec, hardware_alignof_env.
  f_equal.
  extensionality ic.
  destruct ic as [i co].
  extensionality T.
  f_equal.
  apply aux1.
Qed.

Lemma hardware_alignof_consistency (cenv: composite_env) (ha_env: PTree.t Z):
  composite_env_consistent cenv ->
  ha_env = hardware_alignof_env cenv ->
  forall i co ha,
    cenv ! i = Some co ->
    ha_env ! i = Some ha ->
    ha = hardware_alignof_composite ha_env (co_members co).
Proof.
  intros.
  pose proof @composite_reorder_consistent Z cenv
             (fun t =>
                match access_mode t with
                | By_value ch => Memdata.align_chunk ch
                | _ => 1
                end)
             (fun ha _ _ _ => ha)
             (fun ha _ _ => ha)
             (fun ha _ _ => ha)
             (fun _ =>
                fix fm (l: list (ident * type * Z)): Z :=
                match l with
                | nil => 1
                | (_, _, ha) :: l' => Z.max ha (fm l')
                end)
             H
    as HH.
  hnf in HH.
  subst ha_env.
  rewrite aux2 in HH.
  specialize (HH _ _ ha H1 H2).
  rewrite HH, aux1; auto.
Qed.

Lemma hardware_alignof_completeness (cenv: composite_env) (ha_env: PTree.t Z):
  ha_env = hardware_alignof_env cenv ->
  forall i,
    (exists co, cenv ! i = Some co) <->
    (exists ha, ha_env ! i = Some ha).
Proof.
  intros.
  pose proof @composite_reorder_complete Z cenv
             (fun t =>
                match access_mode t with
                | By_value ch => Memdata.align_chunk ch
                | _ => 1
                end)
             (fun ha _ _ _ => ha)
             (fun ha _ _ => ha)
             (fun ha _ _ => ha)
             (fun _ =>
                fix fm (l: list (ident * type * Z)): Z :=
                match l with
                | nil => 1
                | (_, _, ha) :: l' => Z.max ha (fm l')
                end)
    as HH.
  hnf in HH.
  subst.
  rewrite aux2 in HH.
  auto.
Qed.

End hardware_alignof_facts.

Export hardware_alignof_facts.

Lemma hardware_alignof_two_p: forall (cenv: composite_env) (ha_env: PTree.t Z),
  composite_env_consistent cenv ->
  hardware_alignof_env_consistent cenv ha_env ->
  hardware_alignof_env_complete cenv ha_env ->
  forall t, exists n,
  hardware_alignof ha_env t = two_power_nat n.
Proof.
  intros ? ? CENV_CONS HA_ENV_CONS HA_ENV_COMPL ?.
  type_induction t cenv CENV_CONS.
  + exists 0%nat; reflexivity.
  + destruct s, i; try solve [exists 0%nat; reflexivity | exists 1%nat; reflexivity | exists 2%nat; reflexivity | exists 3%nat; reflexivity].
  + destruct s; try solve [exists 0%nat; reflexivity | exists 1%nat; reflexivity | exists 2%nat; reflexivity | exists 3%nat; reflexivity].
  + destruct f; try solve [exists 0%nat; reflexivity | exists 1%nat; reflexivity | exists 2%nat; reflexivity | exists 3%nat; reflexivity].
  + exists 2%nat; reflexivity.
  + simpl.
    auto.
  + exists 0%nat; reflexivity.
  + simpl.
    pose proof HA_ENV_CONS id; pose proof HA_ENV_COMPL id.
    destruct (cenv ! id) as [co |] eqn:?H, (ha_env ! id) eqn:?H.
    Focus 2. { pose proof proj1 H0 (ex_intro _ _ eq_refl) as [? ?]; congruence. } Unfocus.
    Focus 2. { pose proof proj2 H0 (ex_intro _ _ eq_refl) as [? ?]; congruence. } Unfocus.
    - specialize (H _ _ eq_refl eq_refl).
      subst z.
      clear - IH.
      induction IH.
      * exists 0%nat; reflexivity.
      * destruct x as [i t], H as [n1 ?], IHIH as [n2 ?].
        simpl in H |- *.
        rewrite H, H0.
        rewrite max_two_power_nat.
        eexists; reflexivity.
    - exists 0%nat; reflexivity.
  + simpl.
    pose proof HA_ENV_CONS id; pose proof HA_ENV_COMPL id.
    destruct (cenv ! id) as [co |] eqn:?H, (ha_env ! id) eqn:?H.
    Focus 2. { pose proof proj1 H0 (ex_intro _ _ eq_refl) as [? ?]; congruence. } Unfocus.
    Focus 2. { pose proof proj2 H0 (ex_intro _ _ eq_refl) as [? ?]; congruence. } Unfocus.
    - specialize (H _ _ eq_refl eq_refl).
      subst z.
      clear - IH.
      induction IH.
      * exists 0%nat; reflexivity.
      * destruct x as [i t], H as [n1 ?], IHIH as [n2 ?].
        simpl in H |- *.
        rewrite H, H0.
        rewrite max_two_power_nat.
        eexists; reflexivity.
    - exists 0%nat; reflexivity.
Qed.

Lemma hardware_alignof_pos: forall (cenv: composite_env) (ha_env: PTree.t Z),
  composite_env_consistent cenv ->
  hardware_alignof_env_consistent cenv ha_env ->
  hardware_alignof_env_complete cenv ha_env ->
  forall t,
  hardware_alignof ha_env t > 0.
Proof.
  intros.
  pose proof hardware_alignof_two_p _ _ H H0 H1 t as [n ?].
  rewrite H2.
  apply two_power_nat_pos.
Qed.

Lemma hardware_alignof_composite_two_p: forall (cenv: composite_env) (ha_env: PTree.t Z),
  composite_env_consistent cenv ->
  hardware_alignof_env_consistent cenv ha_env ->
  hardware_alignof_env_complete cenv ha_env ->
  forall m, exists n,
    hardware_alignof_composite ha_env m = two_power_nat n.
Proof.
  intros.
  induction m as [| [i t] ?].
  + exists 0%nat.
    reflexivity.
  + destruct IHm as [n1 ?], (hardware_alignof_two_p _ _ H H0 H1 t) as [n2 ?].
    simpl.
    rewrite H2, H3.
    rewrite max_two_power_nat.
    eexists; reflexivity.
Qed.

Hint Resolve alignof_two_p: align.
Hint Resolve align_chunk_two_p: align.
Hint Extern 10 (exists n: nat, hardware_alignof _ _ = two_power_nat n) => (eapply hardware_alignof_two_p; eassumption): align.
Hint Extern 10 (exists n: nat, hardware_alignof_composite _ _ = two_power_nat n) => (eapply hardware_alignof_composite_two_p; eassumption): align.

Lemma hardware_alignof_by_value: forall ha_env t ch,
  access_mode t = By_value ch ->
  hardware_alignof ha_env t = align_chunk ch.
Proof.
  intros.
  destruct t as [| [| | |] [|] | [|] | [|] | | | | |]; inv H; auto.
Qed.

Lemma align_compatible_rec_hardware_alignof_divide: forall cenv ha_env t z1 z2,
  composite_env_consistent cenv ->
  composite_env_complete_legal_cosu_type cenv ->
  hardware_alignof_env_consistent cenv ha_env ->
  hardware_alignof_env_complete cenv ha_env ->
  complete_legal_cosu_type cenv t = true ->
  (hardware_alignof ha_env t | z1 - z2) ->
  (align_compatible_rec cenv t z1 <-> align_compatible_rec cenv t z2).
Proof.
  intros ? ? ? ? ? CENV_CONS CENV_COSU HA_ENV_CONS HA_ENV_COMPL.
  revert t z1 z2.
  assert (BY_VALUE: forall t z1 z2, (exists ch, access_mode t = By_value ch) -> (hardware_alignof ha_env t | z1 - z2) -> align_compatible_rec cenv t z1 <-> align_compatible_rec cenv t z2).
  Focus 1. {
    intros ? ? ? [? ?] ?.
    split; intros.
    + eapply align_compatible_rec_by_value_inv in H1; eauto.
      eapply align_compatible_rec_by_value; eauto.
      replace z2 with (z1 - (z1 - z2)) by omega.
      erewrite hardware_alignof_by_value in H0 by eauto.
      apply Z.divide_sub_r; auto.
    + eapply align_compatible_rec_by_value_inv in H1; eauto.
      eapply align_compatible_rec_by_value; eauto.
      replace z1 with (z2 + (z1 - z2)) by omega.
      erewrite hardware_alignof_by_value in H0 by eauto.
      apply Z.divide_add_r; auto.
  } Unfocus.
  intro t; type_induction t cenv CENV_CONS; intros.
  + split; intros; inv H1; inv H2.
  + eapply BY_VALUE; auto.
    destruct s, i; eexists; reflexivity.
  + eapply BY_VALUE; auto.
    destruct s; eexists; reflexivity.
  + eapply BY_VALUE; auto.
    destruct f; eexists; reflexivity.
  + eapply BY_VALUE; auto.
    eexists; reflexivity.
  + simpl in H0.
    split; intros; apply align_compatible_rec_Tarray; intros;
    eapply align_compatible_rec_Tarray_inv in H1; eauto.
    - specialize (IH (z1 + sizeof cenv t0 * i) (z2 + sizeof cenv t0 * i)).
      replace (z1 + sizeof cenv t0 * i - (z2 + sizeof cenv t0 * i)) with (z1 - z2) in IH by omega.
      tauto.
    - specialize (IH (z1 + sizeof cenv t0 * i) (z2 + sizeof cenv t0 * i)).
      replace (z1 + sizeof cenv t0 * i - (z2 + sizeof cenv t0 * i)) with (z1 - z2) in IH by omega.
      tauto.
  + split; intros; inv H1; inv H2; econstructor.
  + simpl in H, H0.
    destruct (cenv ! id) as [co |] eqn:?H; [| inv H].
    destruct (co_su co) eqn:?H; inv H.
    assert (forall i0 t0 ofs0,
              field_type i0 (co_members co) = Errors.OK t0 ->
              field_offset cenv i0 (co_members co) = Errors.OK ofs0 ->
              (align_compatible_rec cenv t0 (z1 + ofs0) <->
               align_compatible_rec cenv t0 (z2 + ofs0))) as HH;
    [ | split; intros; eapply align_compatible_rec_Tstruct; eauto;
        intros; eapply align_compatible_rec_Tstruct_inv in H; eauto;
        eapply HH; eauto].
    pose proof proj1 (HA_ENV_COMPL id) (ex_intro _ co H1) as [ha ?].
    rewrite H in H0.
    pose proof HA_ENV_CONS _ _ _ H1 H.
    rewrite H3 in H0.
    pose proof CENV_COSU _ _ H1.
    clear H H1 H2 H3 ha.
    intros. clear H1.
    induction IH as [| [i t] ?].
    - inv H.
    - simpl in H, H0, H4.
      autorewrite with align in H0, H4.
      if_tac in H.
      * subst i; inv H.
        apply H1; [simpl; tauto |].
        replace (z1 + ofs0 - (z2 + ofs0)) with (z1 - z2) by omega; tauto.
      * apply IHIH; tauto.
  + simpl in H, H0.
    destruct (cenv ! id) as [co |] eqn:?H; [| inv H].
    destruct (co_su co) eqn:?H; inv H.
    assert (forall i0 t0,
              field_type i0 (co_members co) = Errors.OK t0 ->
              (align_compatible_rec cenv t0 z1 <->
               align_compatible_rec cenv t0 z2)) as HH;
    [ | split; intros; eapply align_compatible_rec_Tunion; eauto;
        intros; eapply align_compatible_rec_Tunion_inv in H; eauto;
        eapply HH; eauto].
    pose proof proj1 (HA_ENV_COMPL id) (ex_intro _ co H1) as [ha ?].
    rewrite H in H0.
    pose proof HA_ENV_CONS _ _ _ H1 H.
    rewrite H3 in H0.
    pose proof CENV_COSU _ _ H1.
    clear H H1 H2 H3 ha.
    intros.
    induction IH as [| [i t] ?].
    - inv H.
    - simpl in H, H0, H4.
      autorewrite with align in H0, H4.
      if_tac in H.
      * subst i; inv H.
        apply H1; simpl; tauto.
      * apply IHIH; tauto.
Qed.

Lemma align_compatible_rec_hardware_1: forall cenv ha_env t z,
  composite_env_consistent cenv ->
  composite_env_complete_legal_cosu_type cenv ->
  hardware_alignof_env_consistent cenv ha_env ->
  hardware_alignof_env_complete cenv ha_env ->
  complete_legal_cosu_type cenv t = true ->
  hardware_alignof ha_env t = 1 ->
  align_compatible_rec cenv t z.
Proof.
  intros ? ? ? ? CENV_CONS CENV_COSU HA_ENV_CONS HA_ENV_COMPL.
  revert z; type_induction t cenv CENV_CONS; intros.
  + inv H.
  + destruct s, i; inv H0;
    econstructor; try reflexivity; apply Z.divide_1_l.
  + destruct s; inv H0.
  + destruct f; inv H0.
  + inv H0.
  + apply align_compatible_rec_Tarray.
    intros.
    apply IH; auto.
  + inv H.
  + simpl in H, H0.
    destruct (cenv ! id) as [co |] eqn:?H; [| inv H].
    destruct (co_su co) eqn:?H; inv H.
    pose proof proj1 (HA_ENV_COMPL id) (ex_intro _ co H1) as [ha ?].
    rewrite H in H0.
    pose proof HA_ENV_CONS _ _ _ H1 H.
    rewrite H3 in H0.
    pose proof CENV_COSU _ _ H1.
    eapply align_compatible_rec_Tstruct; eauto.
    clear H H1 H2 H3 ha.
    intros; clear H1.
    induction IH as [| [i t] ?].
    - inv H.
    - simpl in H, H0, H4.
      autorewrite with align in H0, H4.
      destruct H0, H4.
      if_tac in H.
      * subst i; inv H.
        apply H1; auto.
      * apply IHIH; auto.
  + simpl in H, H0.
    destruct (cenv ! id) as [co |] eqn:?H; [| inv H].
    destruct (co_su co) eqn:?H; inv H.
    pose proof proj1 (HA_ENV_COMPL id) (ex_intro _ co H1) as [ha ?].
    rewrite H in H0.
    pose proof HA_ENV_CONS _ _ _ H1 H.
    rewrite H3 in H0.
    pose proof CENV_COSU _ _ H1.
    eapply align_compatible_rec_Tunion; eauto.
    clear H H1 H2 H3 ha.
    intros.
    induction IH as [| [i t] ?].
    - inv H.
    - simpl in H, H0, H4.
      autorewrite with align in H0, H4.
      destruct H0, H4.
      if_tac in H.
      * subst i; inv H.
        apply H1; auto.
      * apply IHIH; auto.
Qed.

Module Type LEGAL_ALIGNAS.

  Parameter legal_alignas_obs: Type.
  Parameter legal_alignas_type: composite_env -> PTree.t Z -> PTree.t legal_alignas_obs -> type -> legal_alignas_obs.
  Parameter legal_alignas_composite: composite_env -> PTree.t Z -> PTree.t legal_alignas_obs -> composite -> legal_alignas_obs.
  Parameter legal_alignas_env: composite_env -> PTree.t Z -> PTree.t legal_alignas_obs.
  Parameter is_aligned_aux: legal_alignas_obs -> Z -> Z -> bool.

End LEGAL_ALIGNAS.

Module LegalAlignasDefsGen (LegalAlignas: LEGAL_ALIGNAS).

  Import LegalAlignas.

  Definition legal_alignas_env_consistent (cenv: composite_env) (ha_env: PTree.t Z) (la_env: PTree.t legal_alignas_obs): Prop :=
    forall i co la,
      cenv ! i = Some co ->
      la_env ! i = Some la ->
      la = legal_alignas_composite cenv ha_env la_env co.

  Definition legal_alignas_env_complete (cenv: composite_env) (la_env: PTree.t legal_alignas_obs): Prop :=
    forall i,
      (exists co, cenv ! i = Some co) <->
      (exists la, la_env ! i = Some la).

  Definition is_aligned cenv ha_env la_env (t: type) (ofs: Z): bool := is_aligned_aux (legal_alignas_type cenv ha_env la_env t) (hardware_alignof ha_env t) ofs.

  Definition legal_alignas_env_sound (cenv: composite_env) (ha_env: PTree.t Z) (la_env: PTree.t legal_alignas_obs): Prop :=
    forall ofs t,
      complete_legal_cosu_type cenv t = true ->
      is_aligned cenv ha_env la_env t ofs = true ->
      align_compatible_rec cenv t ofs.

End LegalAlignasDefsGen.

Module Type LEGAL_ALIGNAS_FACTS.

  Declare Module LegalAlignas: LEGAL_ALIGNAS.
  Module LegalAlignasDefs := LegalAlignasDefsGen (LegalAlignas).
  Export LegalAlignas LegalAlignasDefs.

  Axiom legal_alignas_env_consistency: forall cenv ha_env,
    composite_env_consistent cenv ->
    legal_alignas_env_consistent cenv ha_env (legal_alignas_env cenv ha_env).

  Axiom legal_alignas_env_completeness: forall cenv ha_env,
    legal_alignas_env_complete cenv (legal_alignas_env cenv ha_env).

  Axiom legal_alignas_soundness: forall cenv ha_env la_env,
    composite_env_consistent cenv ->
    composite_env_complete_legal_cosu_type cenv ->
    hardware_alignof_env_consistent cenv ha_env ->
    hardware_alignof_env_complete cenv ha_env ->
    legal_alignas_env_consistent cenv ha_env la_env ->
    legal_alignas_env_complete cenv la_env ->
    legal_alignas_env_sound cenv ha_env la_env.

End LEGAL_ALIGNAS_FACTS.

Module LegalAlignasStrict <: LEGAL_ALIGNAS.

Section legal_alignas.

Context (cenv: composite_env) (ha_env: PTree.t Z).

Definition legal_alignas_obs: Type := bool.

Fixpoint legal_alignas_type (la_env: PTree.t bool) t: bool :=
  (hardware_alignof ha_env t <=? alignof cenv t) &&
  match t with
  | Tarray t' _ _ => (sizeof cenv t' mod alignof cenv t' =? 0) && legal_alignas_type la_env t'
  | Tstruct id _ =>
      match la_env ! id with
      | Some la => la
      | None => false
      end
  | Tunion id _ =>
      match la_env ! id with
      | Some la => la
      | None => false
      end
  | _ => match access_mode t with
         | By_value ch => true
         | _ => false
         end
  end.

Fixpoint legal_alignas_members (la_env: PTree.t bool) (m: members): bool :=
  match m with
  | nil => true
  | (_, t) :: m' => (legal_alignas_type la_env t) && (legal_alignas_members la_env m')
  end.

Definition legal_alignas_composite (la_env: PTree.t bool) (co: composite): bool :=
  legal_alignas_members la_env (co_members co).

Definition legal_alignas_env: PTree.t bool :=
  let l := composite_reorder.rebuild_composite_elements cenv in
  fold_right (fun (ic: positive * composite) (T0: PTree.t bool) => let (i, co) := ic in let T := T0 in PTree.set i (legal_alignas_composite T co) T) (PTree.empty _) l.

Definition is_aligned_aux (b: bool) (ha: Z) (ofs: Z) := b && ((ofs mod ha) =? 0).

End legal_alignas.

End LegalAlignasStrict.

Module LegalAlignasStrictFacts: LEGAL_ALIGNAS_FACTS with Module LegalAlignas := LegalAlignasStrict.

Module LegalAlignas := LegalAlignasStrict.
Module LegalAlignasDefs := LegalAlignasDefsGen (LegalAlignas).
Export LegalAlignas LegalAlignasDefs.

Section legal_alignas.

Context (cenv: composite_env) (ha_env: PTree.t Z).

Lemma aux1: forall T co,
      (fix fm (l : list (ident * type * bool)) : bool :=
          match l with
          | nil => true
          | (_, _, la) :: l' => la && fm l'
          end)
         (map
            (fun it0 : positive * type =>
             let (i0, t0) := it0 in
             (i0, t0,
             type_func.F
               (fun t : type =>
                (hardware_alignof ha_env t <=? alignof cenv t) &&
                match access_mode t with
                | By_value _ => true
                | By_reference => false
                | By_copy => false
                | By_nothing => false
                end)
               (fun (la : bool) (t : type) (n : Z) (a0 : attr) =>
                (hardware_alignof ha_env (Tarray t n a0) <=? alignof cenv (Tarray t n a0)) && ((sizeof cenv t mod alignof cenv t =? 0) && la))
               (fun (la : bool) (id : ident) (a0 : attr) =>
                (hardware_alignof ha_env (Tstruct id a0) <=? alignof cenv (Tstruct id a0)) && la)
               (fun (la : bool) (id : ident) (a0 : attr) =>
                (hardware_alignof ha_env (Tunion id a0) <=? alignof cenv (Tunion id a0)) && la) T t0)) (co_members co)) =
      legal_alignas_composite cenv ha_env T co.
Proof.
  intros; unfold legal_alignas_composite, legal_alignas_members, legal_alignas_type.
  induction (co_members co) as [| [i t] ?].
  + auto.
  + simpl.
    f_equal; auto.
    clear.
    induction t; auto.
    - simpl.
      rewrite IHt.
      auto.
    - simpl.
      destruct (T ! i); auto.
    - simpl.
      destruct (T ! i); auto.
Qed.

Lemma aux2:
    (type_func.Env
          (fun t : type =>
           (hardware_alignof ha_env t <=? alignof cenv t) &&
           match access_mode t with
           | By_value _ => true
           | By_reference => false
           | By_copy => false
           | By_nothing => false
           end)
          (fun (la : bool) (t : type) (n : Z) (a0 : attr) =>
           (hardware_alignof ha_env (Tarray t n a0) <=? alignof cenv (Tarray t n a0)) && ((sizeof cenv t mod alignof cenv t =? 0) && la))
          (fun (la : bool) (id : ident) (a0 : attr) =>
           (hardware_alignof ha_env (Tstruct id a0) <=? alignof cenv (Tstruct id a0)) && la)
          (fun (la : bool) (id : ident) (a0 : attr) =>
           (hardware_alignof ha_env (Tunion id a0) <=? alignof cenv (Tunion id a0)) && la)
          (fun _ : struct_or_union =>
           fix fm (l : list (ident * type * bool)) : bool :=
             match l with
             | nil => true
             | (_, _, la) :: l' => la && fm l'
             end) (composite_reorder.rebuild_composite_elements cenv)) =
    legal_alignas_env cenv ha_env.
Proof.
  intros.
  unfold type_func.Env, type_func.env_rec, legal_alignas_env.
  f_equal.
  extensionality ic.
  destruct ic as [i co].
  extensionality T.
  f_equal.
  apply aux1.
Qed.

End legal_alignas.

Theorem legal_alignas_env_consistency:
  forall (cenv: composite_env) (ha_env: PTree.t Z),
    composite_env_consistent cenv ->
    legal_alignas_env_consistent cenv ha_env (legal_alignas_env cenv ha_env).
Proof.
  intros.
  pose proof @composite_reorder_consistent bool cenv
             (fun t => (hardware_alignof ha_env t <=? alignof cenv t) &&
                match access_mode t with
                | By_value _ => true
                | _ => false
                end)
             (fun la t n a => (hardware_alignof ha_env (Tarray t n a) <=? alignof cenv (Tarray t n a)) && ((sizeof cenv t mod alignof cenv t =? 0) && la))
             (fun la id a => (hardware_alignof ha_env (Tstruct id a) <=? alignof cenv (Tstruct id a)) && la)
             (fun la id a => (hardware_alignof ha_env (Tunion id a) <=? alignof cenv (Tunion id a)) && la)
             (fun _ =>
                fix fm (l: list (ident * type * bool)): bool :=
                match l with
                | nil => true
                | (_, _, la) :: l' => la && (fm l')
                end)
             H
    as HH.
  hnf in HH.
  rewrite aux2 in HH.
  hnf; intros.
  specialize (HH _ _ la H0 H1).
  rewrite HH, aux1; auto.
Qed.

Theorem legal_alignas_env_completeness:
  forall (cenv: composite_env) (ha_env: PTree.t Z),
    legal_alignas_env_complete cenv (legal_alignas_env cenv ha_env).
Proof.
  intros.
  pose proof @composite_reorder_complete bool cenv
             (fun t => (hardware_alignof ha_env t <=? alignof cenv t) &&
                match access_mode t with
                | By_value _ => true
                | _ => false
                end)
             (fun la t n a => (hardware_alignof ha_env (Tarray t n a) <=? alignof cenv (Tarray t n a)) && ((sizeof cenv t mod alignof cenv t =? 0) && la))
             (fun la id a => (hardware_alignof ha_env (Tstruct id a) <=? alignof cenv (Tstruct id a)) && la)
             (fun la id a => (hardware_alignof ha_env (Tunion id a) <=? alignof cenv (Tunion id a)) && la)
             (fun _ =>
                fix fm (l: list (ident * type * bool)): bool :=
                match l with
                | nil => true
                | (_, _, la) :: l' => la && (fm l')
                end)
    as HH.
  hnf in HH.
  rewrite aux2 in HH.
  auto.
Qed.

Section soundness.

Context (cenv: composite_env)
        (ha_env: PTree.t Z)
        (la_env: PTree.t bool)
        (CENV_CONSI: composite_env_consistent cenv)
        (CENV_COSU: composite_env_complete_legal_cosu_type cenv)
        (HA_ENV_CONSI: hardware_alignof_env_consistent cenv ha_env)
        (HA_ENV_COMPL: hardware_alignof_env_complete cenv ha_env)
        (LA_ENV_CONSI: legal_alignas_env_consistent cenv ha_env la_env)
        (LA_ENV_COMPL: legal_alignas_env_complete cenv la_env).

Lemma legal_alignas_type_divide: forall t,
  legal_alignas_type cenv ha_env la_env t = true ->
  (hardware_alignof ha_env t | alignof cenv t).
Proof.
  intros.
  assert (hardware_alignof ha_env t <=? alignof cenv t = true).
  Focus 1. {
    destruct t; simpl in H |- *;
    solve [inv H | rewrite andb_true_iff in H; tauto].
  } Unfocus.
  autorewrite with align in H0.
  auto.
Qed.

Lemma by_value_sound:
  forall t ofs,
    is_aligned cenv ha_env la_env t ofs = true ->
    (exists ch, access_mode t = By_value ch) ->
    align_compatible_rec cenv t ofs.
Proof.
  intros.
  unfold is_aligned, is_aligned_aux, legal_alignas_type, hardware_alignof in H.
  destruct H0 as [ch ?].
  assert ((align_chunk ch <=? alignof cenv t) && true && (ofs mod align_chunk ch =? 0) = true) by
    (destruct t; try solve [inversion H0]; rewrite H0 in H; auto); clear H.
  autorewrite with align in H1.
  destruct H1 as [_ ?].
  eapply align_compatible_rec_by_value; eauto.
Qed.

Theorem legal_alignas_soundness:
  legal_alignas_env_sound cenv ha_env la_env.
Proof.
  pose proof CENV_COSU.
  clear CENV_COSU H.
  intros.
  hnf; intros ? ? _ ?.
  revert ofs H; type_induction t cenv CENV_CONSI; intros.
  + inversion H.
  + eapply by_value_sound; eauto.
    destruct i, s; eexists; try reflexivity.
  + eapply by_value_sound; eauto.
    destruct s; eexists; try reflexivity.
  + eapply by_value_sound; eauto.
    destruct f; eexists; try reflexivity.
  + eapply by_value_sound; eauto.
    eexists; try reflexivity.
  + apply align_compatible_rec_Tarray; intros.
    apply IH; clear IH.
    unfold is_aligned, is_aligned_aux in H |- *.
    Opaque alignof. simpl in H |- *. Transparent alignof.
    autorewrite with align in H |- *.
    destruct H as [[? [? ?]] ?].
    split; auto.
    apply Z.divide_add_r; auto.
    apply Z.divide_mul_l.
    clear H H3.
    apply legal_alignas_type_divide in H2.
    eapply Z.divide_trans; try eassumption.
  + inv H.
  + unfold is_aligned, is_aligned_aux in H, IH.
    Opaque alignof. simpl in H, IH. Transparent alignof.
    destruct (la_env ! id) as [la |] eqn:?H.
    Focus 2. {
      rewrite (andb_comm _ false) in H.
      inv H.
    } Unfocus.
    pose proof proj2 (LA_ENV_COMPL id) (ex_intro _ _ H0) as [co ?].
    pose proof proj1 (HA_ENV_COMPL id) (ex_intro _ _ H1) as [ha ?].
    rewrite H1 in IH; rewrite H2 in H.
    rewrite (HA_ENV_CONSI id _ _ H1 H2) in H.
    rewrite (LA_ENV_CONSI id _ _ H1 H0) in H.
    eapply align_compatible_rec_Tstruct; [eassumption | intros].
    pose proof field_offset_aligned _ _ _ _ _ H4 H3.
    unfold field_offset in H4.
    clear H0 H1 H2 H4.
    unfold legal_alignas_composite in *.
    induction IH as [| [i t] ?].
    - inv H3.
    - Opaque alignof. simpl in H0, H3, H. Transparent alignof.
      if_tac in H3.
      * subst i0; inv H3.
        apply H0; simpl.
        autorewrite with align in H |- *.
        destruct H as [[_ [? ?]] [? ?]].
        split; auto.
        apply Z.divide_add_r; auto.
        apply legal_alignas_type_divide in H.
        apply Z.divide_trans with (alignof cenv t0); try eassumption.
      * apply IHIH; auto.
        autorewrite with align in H |- *.
        split; [split |]; tauto.
  + unfold is_aligned, is_aligned_aux in H, IH.
    Opaque alignof. simpl in H, IH. Transparent alignof.
    destruct (la_env ! id) as [la |] eqn:?H.
    Focus 2. {
      rewrite (andb_comm _ false) in H.
      inv H.
    } Unfocus.
    pose proof proj2 (LA_ENV_COMPL id) (ex_intro _ _ H0) as [co ?].
    pose proof proj1 (HA_ENV_COMPL id) (ex_intro _ _ H1) as [ha ?].
    rewrite H1 in IH; rewrite H2 in H.
    rewrite (HA_ENV_CONSI id _ _ H1 H2) in H.
    rewrite (LA_ENV_CONSI id _ _ H1 H0) in H.
    eapply align_compatible_rec_Tunion; [eassumption | intros].
    clear H0 H1 H2.
    unfold legal_alignas_composite in *.
    induction IH as [| [i t] ?].
    - inv H3.
    - Opaque alignof. simpl in H0, H3, H. Transparent alignof.
      if_tac in H3.
      * subst i0; inv H3.
        apply H0; simpl.
        autorewrite with align in H |- *.
        destruct H as [[_ [? ?]] [? ?]].
        split; auto.
      * apply IHIH; auto.
        autorewrite with align in H |- *.
        split; [split |]; tauto.
Qed.

End soundness.

End LegalAlignasStrictFacts.

Module LegalAlignasStrong <: LEGAL_ALIGNAS.

Section legal_alignas.

Context (cenv: composite_env) (ha_env: PTree.t Z).

Definition legal_alignas_obs: Type := bool.

Fixpoint legal_alignas_type (la_env: PTree.t bool) t: bool :=
  match t with
  | Tarray t' _ _ => (sizeof cenv t' mod hardware_alignof ha_env t' =? 0) && legal_alignas_type la_env t'
  | Tstruct id _ =>
      match la_env ! id with
      | Some la => la
      | None => false
      end
  | Tunion id _ =>
      match la_env ! id with
      | Some la => la
      | None => false
      end
  | _ => match access_mode t with
         | By_value ch => true
         | _ => false
         end
  end.

Fixpoint legal_alignas_struct_members_rec (la_env: PTree.t bool) (m: members) (pos: Z): bool :=
  match m with
  | nil => true
  | (_, t) :: m' => (align pos (alignof cenv t) mod hardware_alignof ha_env t =? 0) && (legal_alignas_type la_env t) && (legal_alignas_struct_members_rec la_env m' (align pos (alignof cenv t) + sizeof cenv t))
  end.

Fixpoint legal_alignas_union_members_rec (la_env: PTree.t bool) (m: members): bool :=
  match m with
  | nil => true
  | (_, t) :: m' => (legal_alignas_type la_env t) && (legal_alignas_union_members_rec la_env m')
  end.

Definition legal_alignas_composite (la_env: PTree.t bool) (co: composite): bool :=
  match co_su co with
  | Struct => legal_alignas_struct_members_rec la_env (co_members co) 0
  | Union => legal_alignas_union_members_rec la_env (co_members co)
  end.

Definition legal_alignas_env: PTree.t bool :=
  let l := composite_reorder.rebuild_composite_elements cenv in
  fold_right (fun (ic: positive * composite) (T0: PTree.t bool) => let (i, co) := ic in let T := T0 in PTree.set i (legal_alignas_composite T co) T) (PTree.empty _) l.

Definition is_aligned_aux (b: bool) (ha: Z) (ofs: Z) := b && ((ofs mod ha) =? 0).

End legal_alignas.

End LegalAlignasStrong.

Module LegalAlignasStrongFacts: LEGAL_ALIGNAS_FACTS with Module LegalAlignas := LegalAlignasStrong.

Module LegalAlignas := LegalAlignasStrong.
Module LegalAlignasDefs := LegalAlignasDefsGen (LegalAlignas).
Export LegalAlignas LegalAlignasDefs.

Section legal_alignas.

Context (cenv: composite_env) (ha_env: PTree.t Z).

Lemma aux1: forall T co,
  match co_su co with
  | Struct =>
      (fix fm (pos : Z) (l : list (ident * type * bool)) {struct l} : bool :=
         match l with
         | nil => true
         | (_, t, la) :: l' =>
             (align pos (alignof cenv t) mod hardware_alignof ha_env t =? 0) &&
             la && fm (align pos (alignof cenv t) + sizeof cenv t) l'
         end) 0
  | Union =>
      fix fm (l : list (ident * type * bool)) : bool :=
        match l with
        | nil => true
        | (_, _, la) :: l' => la && fm l'
        end
  end
    (map
       (fun it0 : positive * type =>
        let (i0, t0) := it0 in
        (i0, t0,
        type_func.F
          (fun t : type =>
           match access_mode t with
           | By_value _ => true
           | By_reference => false
           | By_copy => false
           | By_nothing => false
           end)
          (fun (la : bool) (t : type) (_ : Z) (_ : attr) =>
           (sizeof cenv t mod hardware_alignof ha_env t =? 0) && la)
          (fun (la : bool) (_ : ident) (_ : attr) => la)
          (fun (la : bool) (_ : ident) (_ : attr) => la) T t0))
       (co_members co)) = legal_alignas_composite cenv ha_env T co.
Proof.
  intros; unfold legal_alignas_composite, legal_alignas_type.
  destruct (co_su co).
  {
  generalize 0 at 2 4.
  induction (co_members co) as [| [i t] ?]; intros.
  + auto.
  + simpl.
    f_equal; [f_equal |]; auto.
    clear.
    induction t; auto.
    simpl.
    rewrite IHt.
    auto.
  }
  {
  induction (co_members co) as [| [i t] ?]; intros.
  + auto.
  + simpl.
    f_equal; [f_equal |]; auto.
    clear.
    induction t; auto.
    simpl.
    rewrite IHt.
    auto.
  }
Qed.

Lemma aux2:
    (type_func.Env
                  (fun t : type =>
                   match access_mode t with
                   | By_value _ => true
                   | By_reference => false
                   | By_copy => false
                   | By_nothing => false
                   end)
                  (fun (la : bool) (t : type) (_ : Z) (_ : attr) =>
                   (sizeof cenv t mod hardware_alignof ha_env t =? 0) && la)
                  (fun (la : bool) (_ : ident) (_ : attr) => la)
                  (fun (la : bool) (_ : ident) (_ : attr) => la)
                  (fun su : struct_or_union =>
                   match su with
                   | Struct =>
                       (fix
                        fm (pos : Z) (l : list (ident * type * bool)) {struct l} :
                          bool :=
                          match l with
                          | nil => true
                          | (_, t, la) :: l' =>
                              (align pos (alignof cenv t)
                               mod hardware_alignof ha_env t =? 0) && la &&
                              fm (align pos (alignof cenv t) + sizeof cenv t) l'
                          end) 0
                   | Union =>
                       fix fm (l : list (ident * type * bool)) : bool :=
                         match l with
                         | nil => true
                         | (_, _, la) :: l' => la && fm l'
                         end
                   end) (composite_reorder.rebuild_composite_elements cenv)) =
    legal_alignas_env cenv ha_env.
Proof.
  intros.
  unfold type_func.Env, type_func.env_rec, legal_alignas_env.
  f_equal.
  extensionality ic.
  destruct ic as [i co].
  extensionality T.
  f_equal.
  apply aux1.
Qed.

End legal_alignas.

Theorem legal_alignas_env_consistency:
  forall (cenv: composite_env) (ha_env: PTree.t Z),
    composite_env_consistent cenv ->
    legal_alignas_env_consistent cenv ha_env (legal_alignas_env cenv ha_env).
Proof.
  intros.
  pose proof @composite_reorder_consistent bool cenv
             (fun t =>
                match access_mode t with
                | By_value _ => true
                | _ => false
                end)
             (fun la t n a => ((sizeof cenv t mod hardware_alignof ha_env t =? 0) && la))
             (fun la id a => la)
             (fun la id a => la)
             (fun su =>
                match su with
                | Struct =>
                   (fix fm (pos: Z) (l: list (ident * type * bool)) : bool :=
                    match l with
                    | nil => true
                    | (_, t, la) :: l' => (align pos (alignof cenv t) mod hardware_alignof ha_env t =? 0) && la && (fm (align pos (alignof cenv t) + sizeof cenv t) l')
                    end) 0
                | Union =>
                   (fix fm (l: list (ident * type * bool)) : bool :=
                    match l with
                    | nil => true
                    | (_, t, la) :: l' => la && (fm l')
                    end)
                end)
             H
    as HH.
  hnf in HH.
  rewrite aux2 in HH.
  hnf; intros.
  specialize (HH _ _ la H0 H1).
  rewrite HH, <- aux1; auto.
Qed.

Theorem legal_alignas_env_completeness:
  forall (cenv: composite_env) (ha_env: PTree.t Z),
    legal_alignas_env_complete cenv (legal_alignas_env cenv ha_env).
Proof.
  intros.
  pose proof @composite_reorder_complete bool cenv
             (fun t =>
                match access_mode t with
                | By_value _ => true
                | _ => false
                end)
             (fun la t n a => ((sizeof cenv t mod hardware_alignof ha_env t =? 0) && la))
             (fun la id a => la)
             (fun la id a => la)
             (fun su =>
                match su with
                | Struct =>
                   (fix fm (pos: Z) (l: list (ident * type * bool)) : bool :=
                    match l with
                    | nil => true
                    | (_, t, la) :: l' => (align pos (alignof cenv t) mod hardware_alignof ha_env t =? 0) && la && (fm (align pos (alignof cenv t) + sizeof cenv t) l')
                    end) 0
                | Union =>
                   (fix fm (l: list (ident * type * bool)) : bool :=
                    match l with
                    | nil => true
                    | (_, t, la) :: l' => la && (fm l')
                    end)
                end)
    as HH.
  hnf in HH.
  rewrite aux2 in HH.
  auto.
Qed.

Section soundness.

Context (cenv: composite_env)
        (ha_env: PTree.t Z)
        (la_env: PTree.t bool)
        (CENV_CONSI: composite_env_consistent cenv)
        (CENV_COSU: composite_env_complete_legal_cosu_type cenv)
        (HA_ENV_CONSI: hardware_alignof_env_consistent cenv ha_env)
        (HA_ENV_COMPL: hardware_alignof_env_complete cenv ha_env)
        (LA_ENV_CONSI: legal_alignas_env_consistent cenv ha_env la_env)
        (LA_ENV_COMPL: legal_alignas_env_complete cenv la_env).

Lemma by_value_sound:
  forall t ofs,
    is_aligned cenv ha_env la_env t ofs = true ->
    (exists ch, access_mode t = By_value ch) ->
    align_compatible_rec cenv t ofs.
Proof.
  intros.
  unfold is_aligned, is_aligned_aux, legal_alignas_type, hardware_alignof in H.
  destruct H0 as [ch ?].
  assert ((ofs mod align_chunk ch =? 0) = true) by
    (destruct t; try solve [inversion H0]; rewrite H0 in H; auto); clear H.
  autorewrite with align in H1.
  eapply align_compatible_rec_by_value; eauto.
Qed.

Theorem legal_alignas_soundness:
  legal_alignas_env_sound cenv ha_env la_env.
Proof.
  intros.
  hnf; intros.
  revert ofs H H0; type_induction t cenv CENV_CONSI; intros.
  + inversion H0.
  + eapply by_value_sound; eauto.
    destruct i, s; eexists; try reflexivity.
  + eapply by_value_sound; eauto.
    destruct s; eexists; try reflexivity.
  + eapply by_value_sound; eauto.
    destruct f; eexists; try reflexivity.
  + eapply by_value_sound; eauto.
    eexists; try reflexivity.
  + apply align_compatible_rec_Tarray; intros.
    apply IH; clear IH; [auto |].
    unfold is_aligned, is_aligned_aux in H0 |- *.
    simpl in H0 |- *.
    autorewrite with align in H0 |- *.
    destruct H0 as [[? ?] ?].
    split; auto.
    apply Z.divide_add_r; auto.
    apply Z.divide_mul_l; auto.
  + inv H.
  + unfold is_aligned, is_aligned_aux in H0, IH.
    simpl in H, H0, IH.
    destruct (la_env ! id) as [la |] eqn:?H; [| inv H0].
    pose proof proj2 (LA_ENV_COMPL id) (ex_intro _ _ H1) as [co ?].
    pose proof proj1 (HA_ENV_COMPL id) (ex_intro _ _ H2) as [ha ?].
    pose proof CENV_COSU _ _ H2.
    rewrite H2 in IH, H; rewrite H3 in H0.
    rewrite (HA_ENV_CONSI id _ _ H2 H3) in H0.
    rewrite (LA_ENV_CONSI id _ _ H2 H1) in H0.
    autorewrite with align in H0 |- *.
    destruct H0.
    unfold legal_alignas_composite in H0.
    destruct (co_su co); [| inv H].
    eapply align_compatible_rec_Tstruct; [eassumption | intros].
    unfold field_offset in H7.
    clear H H1 H2 H3.
    revert H0 H4 H5 H6 H7; generalize 0;
    induction IH as [| [i t] ?]; intros.
    - inv H6.
    - simpl in H, H0, H4, H5, H6, H7.
      if_tac in H6.
      * subst i0; inv H6; inv H7.
        autorewrite with align in H4, H5, H0 |- *.
        destruct H0 as [[? ?] ?], H4 as [? ?], H5 as [? ?].
        apply H; simpl; [tauto |].
        autorewrite with align.
        split; auto.
        apply Z.divide_add_r; auto.
      * autorewrite with align in H0, H4, H5.
        destruct H4, H5.
        apply (IHIH (align z (alignof cenv t) + sizeof cenv t)); auto.
        tauto.
  + unfold is_aligned, is_aligned_aux in H0, IH.
    simpl in H, H0, IH.
    destruct (la_env ! id) as [la |] eqn:?H; [| inv H0].
    pose proof proj2 (LA_ENV_COMPL id) (ex_intro _ _ H1) as [co ?].
    pose proof proj1 (HA_ENV_COMPL id) (ex_intro _ _ H2) as [ha ?].
    pose proof CENV_COSU _ _ H2.
    rewrite H2 in IH, H; rewrite H3 in H0.
    rewrite (HA_ENV_CONSI id _ _ H2 H3) in H0.
    rewrite (LA_ENV_CONSI id _ _ H2 H1) in H0.
    autorewrite with align in H0 |- *.
    destruct H0.
    unfold legal_alignas_composite in H0.
    destruct (co_su co); [inv H |].
    eapply align_compatible_rec_Tunion; [eassumption | intros].
    clear H H1 H2 H3.
    revert H0 H4 H5 H6;
    induction IH as [| [i t] ?]; intros.
    - inv H6.
    - simpl in H, H0, H4, H5, H6.
      if_tac in H6.
      * subst i0; inv H6.
        autorewrite with align in H4, H5, H0 |- *.
        destruct H0 as [? ?], H4 as [? ?], H5 as [? ?].
        apply H; simpl; [tauto |].
        autorewrite with align.
        split; auto.
      * autorewrite with align in H0, H4, H5.
        destruct H4, H5.
        apply IHIH; auto.
        tauto.
Qed.

End soundness.

End LegalAlignasStrongFacts.

Module Export LegalAlignasFacts := LegalAlignasStrongFacts.