(* SPDX-License-Identifier: GPL-2.0 *)
Require Import List.
Import ListNotations.
(* From RecordUpdate Require Import RecordSet. *)
(* Import RecordSetNotations. *)

Require Import theorem4.Base theorem4.Promising.

(* DRF-kernel constraint *)

Definition OwnershipMap := Address -> option TID.

Inductive rel_global_ownership : View -> OwnershipMap -> (View -> option Promise) -> OwnershipMap -> Prop :=
| GO_EMPTY : forall om lp, rel_global_ownership 0 om lp om
| GO_PULL : forall n om lp omr tid addr
                (Hlp : rel_global_ownership n om lp omr)
                (Hown : om addr = None)
                (Hlp : lp (S n) = Some (PULL tid addr)),
                rel_global_ownership (S n) (update om addr (Some tid)) lp omr
| GO_PUSH : forall n om lp omr tid addr
                (Hlp : rel_global_ownership n om lp omr)
                (Hown : om addr = Some tid)
                (Hlp : lp (S n) = Some (PUSH tid addr)),
                rel_global_ownership (S n) (update om addr None) lp omr
| GO_WRITE : forall n om lp omr tid val addr
                (Hlp : rel_global_ownership n om lp omr)
                (Hown : om addr = Some tid)
                (Hlp : lp (S n) = Some (WRITE tid val addr)),
                rel_global_ownership (S n) om lp omr
| GO_NONE : forall n om lp omr
                (Hlp : rel_global_ownership n om lp omr)
                (Hlp : lp (S n) = None),
                rel_global_ownership (S n) om lp omr.

(* No-barrier-misuse constraint *)

Record LocalOwnership := mkLocalOwnership{
    ownership_local : Address -> bool;
    lastbarrier_local : Address -> View
}.
(* )Instance etaLocalOwnership : Settable _ := settable! mkLocalOwnership <ownership_local; lastbarrier_local>.
 *)

Definition update_ownership_local (a : LocalOwnership) b :=
  mkLocalOwnership b (lastbarrier_local a).
Notation "a <|ownership_local := b |>" := (update_ownership_local a b) (at level 1).

Definition update_lastbarrier_local (a : LocalOwnership) b :=
  mkLocalOwnership (ownership_local a) b.
Notation "a <|lastbarrier_local := b |>" := (update_lastbarrier_local a b) (at level 1).
Definition initownership :=
    {|
        ownership_local := fun addr => false;
        lastbarrier_local := fun addr => 0
    |}.

Inductive rel_local_ownership : (View -> option Promise) -> list Event -> LocalOwnership -> Prop :=
| LO_EMPTY : forall promises, rel_local_ownership promises [] initownership
| LO_LOAD : forall promises le lo addr view reg
                (Hlo : rel_local_ownership promises le lo)
                (Hown : ownership_local lo addr = true),
                rel_local_ownership promises ((LOAD addr view reg) :: le) lo
| LO_STORE : forall promises le lo addr view reg
                (Hlo : rel_local_ownership promises le lo)
                (Hown : ownership_local lo addr = true),
                rel_local_ownership promises ((STORE addr view reg) :: le) lo
| LO_ACQ : forall promises le lo addr view
                (Hlo : rel_local_ownership promises le lo)
                (Hown : ownership_local lo addr = false)
                (Hview : lastbarrier_local lo addr <= view),
                rel_local_ownership promises ((ACQ view addr) :: le)
                (lo
                    <|ownership_local := update (ownership_local lo) addr true |>
                    <|lastbarrier_local := update (lastbarrier_local lo) addr view |>
                )
| LO_REL : forall promises le lo addr view
                (Hlo : rel_local_ownership promises le lo)
                (Hown : ownership_local lo addr = true)
                (Hview : lastbarrier_local lo addr <= view),
                rel_local_ownership promises ((REL view addr) :: le)
                (lo
                    <|ownership_local := update (ownership_local lo) addr false |>
                    <|lastbarrier_local := update (lastbarrier_local lo) addr view |>
                )
| LO_INTERNAL : forall promises le lo i
                (Hlo : rel_local_ownership promises le lo),
                rel_local_ownership promises ((INTERNAL i) :: le) lo
| LO_ORACLE : forall promises le lo reg val
                (Hlo : rel_local_ownership promises le lo),
                rel_local_ownership promises ((ORACLE reg val) :: le) lo.

Inductive DRF : Trace -> Prop :=
| DRF_TRACE : forall (t : Trace)  (n : View)
                (Hglobal : exists om : OwnershipMap, rel_global_ownership n om (promiselist t) (fun _ => None))
                (Hlocal : forall tid : TID, exists lo, rel_local_ownership (promiselist t) (executions t tid) lo),
                DRF t.


Require Import VST.floyd.base2.
Require Import VST.floyd.client_lemmas.

Local Open Scope logic.

Lemma typed_true_nullptr:
 forall v t0 t t',
   typed_true t0 (force_val (sem_cmp Ceq (tptr t) (tptr t') v (Vint Int.zero))) ->
   v=nullval.
Proof.
 intros.
 simpl in H. rewrite !andb_false_r in H. simpl in H.
 unfold typed_true, force_val, sem_cmp_pp, strict_bool_val, nullval in *.
 destruct Archi.ptr64  eqn:Hp;
 destruct t0, v; inv H;
 unfold sem_cmp_pp, strict_bool_val in H1;
 try (clear i; rename i0 into i);
 pose proof (Int.eq_spec i Int.zero);
 destruct (Int.eq i Int.zero); inv H1; auto.
Qed.

Lemma typed_true_nullptr':
  forall  {cs: compspecs} t0  t t' v,
    typed_true t0 (eval_binop Cop.Oeq (tptr t) (tptr t') v nullval) -> v=nullval.
Proof.
 intros.
 simpl in H. unfold sem_binary_operation' in H.
 unfold tptr, typed_true, force_val, sem_cmp, Cop.classify_cmp, sem_cmp_pp,
   typeconv, remove_attributes, change_attributes, strict_bool_val, nullval, Val.of_bool in *.
   rewrite (proj2 (eqb_type_false (Tpointer t noattr) int_or_ptr_type)) in H
     by (intro Hx; inv Hx).
   rewrite (proj2 (eqb_type_false (Tpointer t' noattr) int_or_ptr_type)) in H
     by (intro Hx; inv Hx).
   simpl in H.
 destruct Archi.ptr64  eqn:Hp;
 destruct t0, v; inv H;
 try solve [revert H1; simple_if_tac; intro H1; inv H1].
 pose proof (Int64.eq_spec i0 Int64.zero);
 destruct (Int64.eq i0 Int64.zero); inv H1; auto.
 pose proof (Int.eq_spec i0 Int.zero);
 destruct (Int.eq i0 Int.zero); inv H1; auto.
Qed.

Lemma typed_true_Oeq_nullval:
 forall  {cs: compspecs}  v t t',
   local (`(typed_true tint) (`(eval_binop Cop.Oeq (tptr t) (tptr t')) v `(nullval))) |--
   local (`(eq nullval) v).
Proof.
intros.
 intro rho; unfold local, lift1; unfold_lift.
 apply prop_derives; intro.
 unfold tptr in H; simpl in H. unfold sem_binary_operation' in H.
 simpl in H. rewrite !andb_false_r in H.
 destruct (v rho); inv H.
 unfold sem_cmp_pp, strict_bool_val, nullval in *.
 destruct Archi.ptr64  eqn:Hp; simpl in H1;
 try solve [inv H1];
 try solve [pose proof (Int64.eq_spec i Int64.zero);
                destruct (Int64.eq i Int64.zero); inv H1; auto];
 try solve [pose proof (Int.eq_spec i Int.zero);
                destruct (Int.eq i Int.zero); inv H1; auto].
Qed.

Definition  binary_operation_to_comparison (op: Cop.binary_operation) :=
 match op with
 | Cop.Oeq => Some (@eq Z)
 | Cop.One => Some Zne
 | Cop.Olt => Some Z.lt
 | Cop.Ole => Some Z.le
 | Cop.Ogt => Some Z.gt
 | Cop.Oge => Some Z.ge
 | _ => None
 end.

(*
Lemma typed_true_binop_int:
  forall op op' e1 e2 Espec  {cs: compspecs} Delta P Q R c Post,
   binary_operation_to_comparison op = Some op' ->
   typeof e1 = tint ->
   typeof e2 = tint ->
   (PROPx P (LOCALx (tc_env Delta :: Q) (SEPx R))) |--  tc_expr Delta e1 ->
   (PROPx P (LOCALx (tc_env Delta :: Q) (SEPx R))) |-- tc_expr Delta e2 ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`op' (`force_signed_int (eval_expr e1)) (`force_signed_int (eval_expr e2))
          :: Q) (SEPx R))) c Post ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`(typed_true
          (typeof (Ebinop op e1 e2 tint)))
          (eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R))) c Post.
Proof.
intros.
eapply semax_pre; [clear H4 | apply H4].
eapply derives_trans with
 (tc_expr Delta e1 && (tc_expr Delta e2
   && PROPx P (LOCALx (tc_environ Delta :: `(typed_true (typeof (Ebinop op e1 e2 tint)))(eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R)))).
rewrite <- andp_assoc.
apply andp_right; auto.
do 2 rewrite <- insert_local.
rewrite <- andp_assoc.
rewrite (andp_comm (local _)).
rewrite andp_assoc.
apply andp_left2.
rewrite insert_local.
apply andp_right; auto.
clear H2 H3.
(*do 2 rewrite insert_local.*)
unfold PROPx, LOCALx; intro rho; simpl.
normalize.
autorewrite with norm1 norm2; normalize.
rewrite <- andp_assoc.
apply andp_derives; auto.
eapply derives_trans.
apply andp_derives; apply typecheck_expr_sound; auto.
normalize. split; auto.
rewrite H1,H0 in *.
clear H5 H2 H0 H1.
destruct (eval_expr e1 rho); inv H6.
destruct (eval_expr e2 rho); inv H7.
unfold force_signed_int, force_int.
unfold typed_true, eval_binop in H4.
destruct op; inv H; simpl in H4.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); subst; auto.
 contradiction H4; auto.
unfold Zne.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); subst; auto.
contradict H.
rewrite <- (Int.repr_signed i).
rewrite <- (Int.repr_signed i0).
f_equal; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i) (Int.signed i0)); auto; contradict H4; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i0) (Int.signed i)); auto; try omega; contradict H4; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i0) (Int.signed i)); auto; try omega; contradict H4; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i) (Int.signed i0)); auto; try omega; contradict H4; auto.
Qed.
*)

Definition  binary_operation_to_opp_comparison (op: Cop.binary_operation) :=
 match op with
 | Cop.Oeq => Some Zne
 | Cop.One => Some (@eq Z)
 | Cop.Olt => Some Z.ge
 | Cop.Ole => Some Z.gt
 | Cop.Ogt => Some Z.le
 | Cop.Oge => Some Z.lt
 | _ => None
 end.

(*
Lemma typed_false_binop_int:
  forall op op' e1 e2 Espec  {cs: compspecs} Delta P Q R c Post,
   binary_operation_to_opp_comparison op = Some op' ->
   typeof e1 = tint ->
   typeof e2 = tint ->
   (PROPx P (LOCALx (tc_environ Delta :: Q) (SEPx R))) |-- (tc_expr Delta e1) ->
   (PROPx P (LOCALx (tc_environ Delta :: Q) (SEPx R))) |-- (tc_expr Delta e2) ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`op' (`force_signed_int (eval_expr e1)) (`force_signed_int (eval_expr e2))
          :: Q) (SEPx R))) c Post ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`(typed_false
          (typeof (Ebinop op e1 e2 tint)))
          (eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R))) c Post.
Proof.
intros.
eapply semax_pre; [clear H4 | apply H4].
eapply derives_trans with
 ( local (tc_environ Delta) && ((tc_expr Delta e1) && ( (tc_expr Delta e2)
   && PROPx P (LOCALx (tc_environ Delta :: `(typed_false (typeof (Ebinop op e1 e2 tint)))(eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R))))).
apply andp_right.
rewrite <- insert_local. apply andp_left1; auto.
rewrite <- andp_assoc.
apply andp_right; auto.
do 2 rewrite <- insert_local.
rewrite <- andp_assoc.
rewrite (andp_comm (local _)).
rewrite andp_assoc.
apply andp_left2.
rewrite insert_local.
apply andp_right; auto.
clear H2 H3.
unfold PROPx, LOCALx; intro rho; simpl.
unfold local,lift1 at 1.
apply derives_extract_prop; intro TCE.
eapply derives_trans.
apply andp_derives; [ apply typecheck_expr_sound; auto | ].
apply andp_derives; [ apply typecheck_expr_sound; auto | ].
apply derives_refl.
normalize. autorewrite with norm1 norm2; normalize.
apply andp_right; auto. apply prop_right.
split; auto.
clear H6 TCE.
rewrite H0 in *; rewrite H1 in *.
clear H0 H1 H4.
destruct (eval_expr e1 rho); inv H2.
destruct (eval_expr e2 rho); inv H3.
unfold force_signed_int, force_int.
unfold typed_true, eval_binop in H5.
destruct op; inv H; simpl in H5.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); inv H5; auto.
intro; apply H.
rewrite <- (Int.repr_signed i).
rewrite <- (Int.repr_signed i0).
f_equal; auto.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); inv H5; auto.
unfold Int.lt in H5.
destruct (zlt (Int.signed i) (Int.signed i0)); inv H5; auto.
unfold Int.lt in H5.
destruct (zlt (Int.signed i0) (Int.signed i)); inv H5; omega.
unfold Int.lt in H5.
destruct (zlt (Int.signed i0) (Int.signed i)); inv H5; omega.
unfold Int.lt in H5.
destruct (zlt (Int.signed i) (Int.signed i0)); inv H5; omega.
Qed.
*)

Lemma typed_false_One_nullval:
 forall  {cs: compspecs}  v t t',
   local (`(typed_false tint) (`(eval_binop Cop.One (tptr t) (tptr t')) v `(nullval))) |--
    local (`(eq nullval) v).
Proof.
intros.
 intro rho; unfold local, lift1; unfold_lift.
 apply prop_derives; intro.
 simpl in H. unfold sem_binary_operation' in H.
 simpl in H. rewrite !andb_false_r in H.
 unfold sem_cmp_pp, nullval in *.
 destruct Archi.ptr64 eqn:Hp;
 destruct (v rho); inv H.
 pose proof (Int64.eq_spec i Int64.zero).
 destruct (Int64.eq i Int64.zero); inv H1.
 reflexivity.
 pose proof (Int.eq_spec i Int.zero).
 destruct (Int.eq i Int.zero); inv H1.
 reflexivity.
Qed.

Lemma typed_true_One_nullval:
 forall  {cs: compspecs}  v t t',
   local (`(typed_true tint) (`(eval_binop Cop.One (tptr t) (tptr t')) v `(nullval))) |--
   local (`(ptr_neq nullval) v).
Proof.
intros.
 intro rho; unfold local, lift1; unfold_lift.
 apply prop_derives; intro.
 simpl in H. unfold sem_binary_operation' in H.
 simpl in H. rewrite !andb_false_r in H.
 unfold sem_cmp_pp, ptr_neq, ptr_eq, nullval in *; simpl; intro.
 destruct (v rho); try contradiction.
 simpl in *.
 unfold typed_true, force_val, strict_bool_val in *.
 destruct Archi.ptr64 eqn:?; auto.
 destruct H0 as [? [? ?]].
 first [ pose proof (Int64.eq_spec Int64.zero i)
        | pose proof (Int.eq_spec Int.zero i)];
 rewrite H1 in H3;
 subst; inv H.
Qed.

Lemma typed_false_Oeq_nullval:
 forall  {cs: compspecs} v t t',
   local (`(typed_false tint) (`(eval_binop Cop.Oeq (tptr t) (tptr t')) v `(nullval))) |--
   local (`(ptr_neq nullval) v).
Proof.
intros. subst.
 unfold_lift; intro rho.  unfold local, lift1; apply prop_derives; intro.
 simpl in H. unfold sem_binary_operation' in H.
 simpl in H. rewrite !andb_false_r in H.
 intro. apply ptr_eq_e in H0. rewrite <- H0 in H.
 inv H.
Qed.

Lemma local_entail_at:
  forall n S T (H: local (locald_denote S) |-- local (locald_denote T))
    P Q R,
    nth_error Q n = Some S ->
    PROPx P (LOCALx Q (SEPx R)) |--
    PROPx P (LOCALx (replace_nth n Q T) (SEPx R)).
Proof.
 intros.
 unfold PROPx, LOCALx; simpl; intro rho;  apply andp_derives; auto.
 apply andp_derives; auto.
 unfold local, lift1.
 specialize (H rho). unfold local,lift1 in H.
 revert Q H0; induction n; destruct Q; simpl; intros; inv H0.
 unfold_lift; repeat rewrite prop_and.
 apply andp_derives; auto.
  unfold_lift; repeat rewrite prop_and.
 apply andp_derives; auto.
Qed.

Lemma local_entail_at_semax_0:
  forall Espec {cs: compspecs}Delta P Q1 Q1' Q R c Post,
   local (locald_denote Q1) |-- local (locald_denote Q1') ->
   @semax cs Espec Delta (PROPx P (LOCALx (Q1'::Q) (SEPx R))) c Post  ->
   @semax cs Espec Delta (PROPx P (LOCALx (Q1::Q) (SEPx R))) c Post.
Proof.
intros.
eapply semax_pre0.
eapply (local_entail_at 0).
apply H. reflexivity.
auto.
Qed.

(*
Ltac simplify_typed_comparison :=
match goal with
| |- semax _ (PROPx _ (LOCALx (`(typed_true _) ?A :: _) _)) _ _ =>
 (eapply typed_true_binop_int;
   [reflexivity | reflexivity | reflexivity
   | try solve [go_lowerx; apply prop_right; auto ]
   | try solve [go_lowerx; apply prop_right; auto ]
   | ])
 ||
  (let a := fresh "a" in set (a:=A); simpl in a; unfold a; clear a;
   eapply local_entail_at_semax_0; [
    first [ apply typed_true_Oeq_nullval
           | apply typed_true_One_nullval
           ]
    |  ])
| |- semax _ (PROPx _ (LOCALx (`(typed_false _) ?A :: _) _)) _ _ =>
 (eapply typed_false_binop_int;
   [reflexivity | reflexivity | reflexivity
   | try solve [go_lowerx; apply prop_right; auto ]
   | try solve [go_lowerx; apply prop_right; auto ]
   | ])
 ||
  let a := fresh "a" in set (a:=A); simpl in a; unfold a; clear a;
   eapply local_entail_at_semax_0; [
    first [ apply typed_false_Oeq_nullval
           | apply typed_false_One_nullval
           ]
    |  ]
| |- _ => idtac
end.
*)

Definition compare_pp op p q :=
   match p with
            | Vptr b z =>
               match q with
               | Vptr b' z' => if eq_block b b'
                              then Vint (if Ptrofs.cmpu op z z' then Int.one else Int.zero)
                              else Vundef
               | _ => Vundef
               end
             | _ => Vundef
   end.

Lemma force_sem_cmp_pp:
  forall op p q,
  isptr p -> isptr q ->
  force_val (sem_cmp_pp op p q) =
   match op with
   | Ceq => Vint (if eq_dec p q then Int.one else Int.zero)
   | Cne => Vint (if eq_dec p q then Int.zero else Int.one)
   | _ => compare_pp op p q
   end.
Proof.
intros.
destruct p; try contradiction.
destruct q; try contradiction.
clear.
unfold sem_cmp_pp, compare_pp, Ptrofs.cmpu, Val.cmplu_bool.
destruct Archi.ptr64 eqn:Hp.
destruct op; simpl; auto.
if_tac. if_tac. inv H0. rewrite Ptrofs.eq_true; reflexivity.
rewrite Ptrofs.eq_false by congruence; reflexivity.
if_tac. congruence. reflexivity.
if_tac. if_tac. inv H0. rewrite Ptrofs.eq_true by auto. reflexivity.
rewrite Ptrofs.eq_false by congruence; reflexivity.
rewrite if_false by congruence. reflexivity.
if_tac; [destruct (Ptrofs.ltu i i0); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i i0); reflexivity | reflexivity].
destruct op; simpl; auto; rewrite Hp.
if_tac. if_tac. inv H0. rewrite Ptrofs.eq_true; reflexivity.
rewrite Ptrofs.eq_false by congruence; reflexivity.
if_tac. congruence. reflexivity.
if_tac. if_tac. inv H0. rewrite Ptrofs.eq_true by auto. reflexivity.
rewrite Ptrofs.eq_false by congruence; reflexivity.
rewrite if_false by congruence. reflexivity.
if_tac; [destruct (Ptrofs.ltu i i0); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i i0); reflexivity | reflexivity].
Qed.

Hint Rewrite force_sem_cmp_pp using (now auto) : norm.


Require Import
        Coq.omega.Omega
        Coq.Strings.String
        Coq.Vectors.Vector.

Require Import
        Fiat.Computation
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.WordFacts
        Fiat.Narcissus.Common.ComposeIf
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Automation.Solver
        Fiat.Narcissus.BinLib.AlignedByteString
        Fiat.Narcissus.BinLib.AlignWord
        Fiat.Narcissus.BinLib.AlignedList
        Fiat.Narcissus.BinLib.AlignedDecoders
        Fiat.Narcissus.Formats.WordOpt
        Fiat.Narcissus.Formats.NatOpt
        Fiat.Narcissus.Formats.FixListOpt
        Fiat.Narcissus.Stores.EmptyStore.

Instance ByteStringQueueMonoid : Monoid ByteString := ByteStringQueueMonoid.

Definition simple_record := ((word 16) * list (word 8))%type.

Definition Simple_Format
           (p : simple_record) :=
        format_nat 8 (|snd p|)
  ThenC format_word (fst p)
  ThenC format_list format_word (snd p)
  DoneC.

Definition Simply_OK (p : simple_record) :=
  ((|snd p|) < pow2 8)%nat.

Arguments split1 : simpl never.
Arguments split2 : simpl never.
Arguments weq : simpl never.
Arguments natToWord : simpl never.
Arguments Guarded_Vector_split : simpl never.
Arguments Core.append_word : simpl never.

Definition refine_simple_format
  : { numBytes : _ &
    { v : _ &
    { c : _ & forall (p : simple_record)
                     (p_OK : Simply_OK p),
          refine (Simple_Format p ())
                 (ret (@build_aligned_ByteString (numBytes p) (v p), c p)) } } }.
Proof.
  unfold Simple_Format.
  eexists _, _, _; intros.
  (* Step 1: simplification with monad laws so that any complex
       subformats are inlined properly. (Not needed for this example) *)
  eapply refine_refineEquiv_Proper;
    [ unfold flip;
      repeat first
             [ etransitivity; [ apply refineEquiv_compose_compose with (monoid := monoid) | idtac ]
             | etransitivity; [ apply refineEquiv_compose_Done with (monoid := monoid) | idtac ]
             | apply refineEquiv_under_compose with (monoid := monoid) ];
      intros; higher_order_reflexivity
    | reflexivity | ].
    etransitivity.
    (* Replace formats with byte-aligned versions. *)
    eapply AlignedFormatChar; eauto.
    eapply AlignedFormat2Char; eauto.
    eapply AlignedFormatListDoneC with (A_OK := fun _ => True); intros; eauto.
    rewrite aligned_format_char_eq.
    encoder_reflexivity.
    encoder_reflexivity.
Defined.

Definition byte_aligned_simple_encoder
             (r : simple_record)
  := Eval simpl in (projT1 (projT2 refine_simple_format) r).

Import Vectors.VectorDef.VectorNotations.
Print byte_aligned_simple_encoder.

Definition Simple_Format_decoder
  : CorrectDecoderFor Simply_OK Simple_Format.
Proof.
  start_synthesizing_decoder.
  normalize_compose monoid.
  repeat decode_step idtac.
  intros; eauto using FixedList_predicate_rest_True.
  synthesize_cache_invariant.
  cbv beta; optimize_decoder_impl.
Defined.

Definition SimpleDecoderImpl
    := Eval simpl in (proj1_sig Simple_Format_decoder).

Ltac rewrite_DecodeOpt2_fmap :=
  set_refine_evar;
  progress rewrite ?BindOpt_map, ?DecodeOpt2_fmap_if,
  ?DecodeOpt2_fmap_if_bool;
  subst_refine_evar.

Definition ByteAligned_SimpleDecoderImpl {A}
           (f : _ -> A)
           n
  : {impl : _ & forall (v : Vector.t _ (3 + n)),
         f (fst SimpleDecoderImpl (build_aligned_ByteString v) ()) =
         impl v () }.
Proof.
  eexists _; intros.
  etransitivity.
  set_refine_evar; simpl.
  unfold DecodeBindOpt2 at 1; rewrite_DecodeOpt2_fmap.
  rewrite (@AlignedDecodeNat test_cache).
  subst_refine_evar; apply rewrite_under_LetIn; intros; set_refine_evar.
  unfold DecodeBindOpt2 at 1; rewrite_DecodeOpt2_fmap.
  rewrite (@AlignedDecode2Char test_cache).
  subst_refine_evar; apply rewrite_under_LetIn; intros; set_refine_evar.
  unfold DecodeBindOpt2 at 1; rewrite_DecodeOpt2_fmap.
  erewrite optimize_align_decode_list.
  rewrite Ifopt_Ifopt; simpl.
  etransitivity.
  eapply optimize_under_if_opt; simpl; intros.
  higher_order_reflexivity.
  reflexivity.
  Focus 2.
  clear H; intros.
  etransitivity.
  match goal with
    |- ?b = _ =>
    let b' := (eval pattern (build_aligned_ByteString v0) in b) in
    let b' := match b' with ?f _ => f end in
      eapply (@optimize_Guarded_Decode n0 _ 1 b')
  end.
  destruct n0 as [ | [ | ?] ]; intros; try omega.
  apply (@decode_word_aligned_ByteString_overflow test_cache) with (sz := 1); auto.
  destruct n0 as [ | ?]; intros; try omega.
  higher_order_reflexivity.
  instantiate (1 := fun n1 v1 (cd0 : CacheDecode) =>
                      If NPeano.leb 1 n1 Then (Some ((Vector.hd (Guarded_Vector_split 1 n1 v1), @existT _ (Vector.t _) _ (Vector.tl (Guarded_Vector_split 1 n1 v1))), cd0)) Else None).
  simpl; find_if_inside; simpl; try reflexivity.
  pattern n0, v0; apply Vector.caseS; simpl; intros.
  unfold decode_word, WordOpt.decode_word.
  rewrite aligned_decode_char_eq; reflexivity.
  subst_refine_evar; higher_order_reflexivity.
  higher_order_reflexivity.
Defined.

Definition ByteAligned_SimpleDecoderImpl' n :=
  Eval simpl in (projT1 (ByteAligned_SimpleDecoderImpl id n)).

Print ByteAligned_SimpleDecoderImpl'.


Require Import Coq.Program.Equality.

Require Import BinNums.

Require Import Prelude.Control.
Require Import Prelude.Control.Classes.

Require Import FreeSpec.Tactics.
Require Import FreeSpec.Interface.
Require Import FreeSpec.Semantics.
Require Import FreeSpec.Program.
Require Import FreeSpec.Compose.
Require Import FreeSpec.Component.
Require Import FreeSpec.Specification.

Require Import FreeSpec.Stdlib.FileSystem.Definitions.
Require Import FreeSpec.Stdlib.FileSystem.Specifications.

Require Import String.

Local Open Scope prelude_scope.
Local Open Scope free_scope.

Definition close {ix} `{Use FileSystem.i ix} (fd : Z) : Program ix unit :=
	FileSystem.close fd.

Lemma correct (s : state) (fd : Z) :
	close fd |> specs[s].
Proof.
constructor.
+ constructor.
	unfold opened_fd.
	destruct s.
	intro.
Abort.


Require Import Coqlib.
Require Import AST.
Require Import Globalenvs.
Require Import Events.
Require Import Smallstep.
Require Import Asm.
Require Import Values.
Require Import Memory.
Require Import Integers.
Require Import Axioms.

Require Import PeekLib.
Require Import PeekTactics.
Require Import PregTactics.
Require Import SplitLib.
Require Import StepLib.
Require Import StepIn.
Require Import AsmCallingConv.
Require Import StepEquiv.
Require Import FindInstrLib.
Require Import SameBlockLib.
Require Import ProgPropDec.
Require Import MemoryAxioms.
Require Import AsmBits.
Require Import ProgPropDec.
Require Import Zlen.

Definition measure_fun (z : Z) (st : state_bits) : nat :=
  match st with
    | State_bits rs m md =>
      match rs PC with
        | Values.Vint bits =>
          match psur md bits with
            | Some (b,i) => nat_of_Z (z - Int.unsigned i)
            | None => O
          end
        | _ => O
      end
  end.

Lemma nat_of_Z_lt :
  forall z z',
    z >= 0 -> z' >= 0 ->
    z < z' ->
    (nat_of_Z z < nat_of_Z z')%nat.
Proof.
  intros. unfold nat_of_Z.
  apply Z2Nat.inj_lt; omega.
Qed.

Lemma instr_class :
  forall i,
    straightline i \/ (exists l, labeled_jump i l) \/ is_call_return i \/ trace_internal i.
Proof.
  intros.
  destruct i;
  try solve [left; unfold straightline; exact I];
  try solve [right; left; unfold labeled_jump; eauto];
  try solve [right; unfold is_call_return; auto].
  destruct tbl. left. simpl. reflexivity.
  right. left. unfold labeled_jump. simpl. eauto.
  right. right. right. simpl. exact I.
  right. right. right. simpl. exact I.
Qed.

Lemma in_code_at_code :
  forall c z rs m ge md,
    in_code z c ge (State_bits rs m md) ->
    exists z' i,
      at_code z' (i :: nil) 0 ge (State_bits rs m md) /\ In i c.
Proof.
  induction c; intros.
  inv H. inv H1. simpl.
  unfold zlen in *. simpl in *.
  omega.
  inv H. inv H1.
  assert (ofs = 1 \/ ofs > 1) by omega.
  break_or. destruct c.
  rewrite zlen_cons in H11. simpl in H11. omega.
  exists (Int.unsigned i). exists i0.
  split; try solve [simpl; right; left; reflexivity].
  rewrite H6. replace (zlen c1 + 1) with (zlen (c1 ++ a :: nil)).
  econstructor; eauto.
  rewrite zlen_app. rewrite zlen_cons. simpl. omega.
  rewrite zlen_cons. simpl. omega.
  simpl. rewrite app_ass. simpl.
  rewrite H13. reflexivity.
  rewrite zlen_app. rewrite zlen_cons. simpl. reflexivity.
  assert (in_code (zlen (c1 ++ a :: nil)) c ge (State_bits rs m md)).
  econstructor. instantiate (1 := ofs - 1). omega.
  econstructor; eauto.
  rewrite H6. rewrite zlen_app.
  rewrite zlen_cons. simpl. omega.
  rewrite zlen_cons in H11. omega.
  rewrite H13. rewrite app_ass. simpl. reflexivity.
  app IHc H. exists x. exists x0. break_and.
  split; eauto. simpl. right. eauto.
Qed.

Lemma step_in_step_t' :
  forall z c ge st t st',
    in_code z c ge st ->
    step_bits ge st t st' ->
    exists i,
      step_t (i :: nil) ge st t st' /\ In i c.
Proof.
  intros.
  destruct st.
  app in_code_at_code H. exists x0. break_and.
  split; auto. replace t with (t ** E0) by (apply E0_right).
  econstructor; eauto. econstructor.
Qed.

Lemma step_in_step_t :
  forall z c ge st t st',
    step_in z c ge st t st' ->
    exists i,
      step_t (i :: nil) ge st t st' /\ In i c.
Proof.
  intros. inv H.
  app step_in_step_t' H2.
Qed.

Lemma step_at_step_t :
  forall z c ofs ge st t st',
    at_code z c ofs ge st ->
    step_bits ge st t st' ->
    exists i, step_t (i :: nil) ge st t st' /\ In i c.
Proof.
  intros.
  destruct (zeq ofs 0). subst ofs.
  destruct c. inv H. unfold zlen in H4. simpl in H4. omega.
  exists i. split; try solve [simpl; left; reflexivity].
  replace t with (t ** E0) by apply E0_right.
  econstructor; try solve [econstructor]; eauto.
  eapply at_code_cons; eauto.
  assert (in_code z c ge st).
  econstructor; eauto.
  inv H. omega.
  app step_in_step_t' H0.
Qed.

Lemma find_instr_in :
  forall c i,
    In i c <-> (exists z, find_instr z c = Some i).
Proof.
  induction c; split; intros.
  simpl in H. inv H.
  break_exists. simpl in H. inv H.
  simpl in H. break_or. exists 0. simpl. reflexivity.
  rewrite IHc in H0. break_exists. simpl. exists (x+1).
  apex in_range_find_instr H. break_match; try omega.
  replace (x+1-1) with x by omega. eauto.
  break_exists. simpl in H. break_match_hyp.
  inv H. simpl. left. reflexivity.
  apex IHc H. simpl. right. eauto.
Qed.

Lemma no_trace_trace :
  forall x,
    trace_internal x ->
    ~ no_trace x.
Proof.
  intros; destruct x; simpl; eauto.
Qed.

Lemma at_code_straightline_end :
  forall z x p st t st',
    no_PC_overflow_prog p ->
    straightline x ->
    at_code z (x :: nil) 0 (Genv.globalenv p) st ->
    step_bits (Genv.globalenv p) st t st' ->
    at_code_end z (x :: nil) (Genv.globalenv p) st'.
Proof.
  intros. inv H1.
  invs.
  unify_psur. unify_find_funct_ptr.
  name H16 Hfind_instr.
  rewrite H8 in H16. rewrite H5 in H16.
  rewrite find_instr_append_head in H16 by omega.
  simpl in H16. inv H16.
  app straightline_exec H17. break_and.
  Focus 2. app weak_valid_pointer_sur H12.
  break_and. eauto.
  econstructor; eauto.

  (* New stuff *)
  app md_extends_step H2.
  assert (Hadd_i : Int.unsigned (Int.add i Int.one) = Int.unsigned i + 1). {
    unfold Int.add.
    erewrite unsigned_repr_PC; eauto.
    left. rewrite Int.unsigned_one.
    replace (Int.unsigned i + 1 - 1) with (Int.unsigned i) by omega.
    eauto.
  } idtac.
  erewrite weak_valid_pointer_sur in H12; eauto.
  break_and.
  eapply pinj_add in H11.
  instantiate (1 := Int.one) in H11.
  eapply pinj_extends in H11; eauto.
  unify_pinj.
  instantiate (1 := Int.add i Int.one).
  app step_match_metadata H10.
  erewrite weak_valid_pointer_sur; eauto.
  split. eassumption.
  app step_gp H11.
  break_and.
  app global_perms_valid_globals H16.
  eapply Mem.weak_valid_pointer_spec. right.
  replace (Int.unsigned (Int.add i Int.one) - 1) with (Int.unsigned i) by omega.
  apply H16.
  unfold is_global. left.
  unfold in_code_range.
  unfold fundef in *.
  collapse_match.
  apex in_range_find_instr Hfind_instr.
  omega.
  (* end new stuff *)

  rewrite zlen_cons. simpl.
  replace (zlen c0 + 0) with (zlen c0) in H5 by omega.
  rewrite <- H5.
  apply add_one_no_overflow.
  unfold no_PC_overflow_prog in H.
  assert (no_PC_overflow (fn_code f)).
  apply H. unfold code_of_prog. app Genv.find_funct_ptr_inversion H7.
  destruct f. eauto.
  unfold no_PC_overflow in H10. eapply H10; eauto.

  unify_psur. unify_find_funct_ptr.
  rewrite H8 in H14. rewrite H5 in H14.
  rewrite find_instr_append_head in H14 by omega.
  simpl in H14. inv H14.
  simpl in H0. inv H0.

  unify_psur. unify_find_funct_ptr.
  rewrite H8 in H16. rewrite H5 in H16.
  rewrite find_instr_append_head in H16 by omega.
  simpl in H16. inv H16.
  simpl in H0. inv H0.

  unify_psur. unify_find_funct_ptr.

Qed.

Lemma at_code_label_end :
  forall z x p st t st',
    no_PC_overflow_prog p ->
    (exists l, x = Plabel l) ->
    at_code z (x :: nil) 0 (Genv.globalenv p) st ->
    step_bits (Genv.globalenv p) st t st' ->
    at_code_end z (x :: nil) (Genv.globalenv p) st'.
Proof.
  intros. inv H1.
  invs.
  unify_psur. unify_find_funct_ptr.
  name H16 Hfind_instr.
  rewrite H8 in H16. rewrite H5 in H16.
  rewrite find_instr_append_head in H16 by omega.
  simpl in H16. inv H16.
  app label_exec H17. break_and.
  econstructor; eauto.

  (* New stuff *)
  NP _app md_extends_step step_bits.
  assert (Hadd_i : Int.unsigned (Int.add i Int.one) = Int.unsigned i + 1). {
    unfold Int.add.
    erewrite unsigned_repr_PC; eauto.
    left. rewrite Int.unsigned_one.
    replace (Int.unsigned i + 1 - 1) with (Int.unsigned i) by omega.
    eauto.
  } idtac.
  erewrite weak_valid_pointer_sur in H12; eauto.
  break_and.
  eapply pinj_add in H11.
  instantiate (1 := Int.one) in H11.
  instantiate (1 := i) in H9.
  eapply pinj_extends in H11; eauto.
  unify_pinj.
  instantiate (1 := Int.add i Int.one).
  app step_match_metadata H10.
  erewrite weak_valid_pointer_sur; eauto.
  split. eassumption.
  NP _app step_gp step_bits.
  break_and.
  app global_perms_valid_globals H15.
  eapply Mem.weak_valid_pointer_spec. right.
  rewrite Hadd_i. replace (Int.unsigned i + 1 - 1) with (Int.unsigned i) by omega.
  apply H15.
  unfold is_global. left.
  unfold in_code_range.
  unfold fundef in *.
  collapse_match.
  apex in_range_find_instr Hfind_instr. omega.
  (* end new stuff *)

  rewrite zlen_cons. simpl.
  replace (zlen c0 + 0) with (zlen c0) in H5 by omega.
  rewrite <- H5.
  apply add_one_no_overflow.
  unfold no_PC_overflow_prog in H.
  assert (no_PC_overflow (fn_code f)).
  apply H. unfold code_of_prog. app Genv.find_funct_ptr_inversion H7.
  destruct f. eauto.
  unfold no_PC_overflow in H10. eapply H10; eauto.
  eapply weak_valid_pointer_sur in H12. break_and. eauto.
  invs; eauto.

  unify_psur. unify_find_funct_ptr.
  rewrite H8 in H14. rewrite H5 in H14.
  rewrite find_instr_append_head in H14 by omega.
  simpl in H14. inv H14.
  simpl in H0. inv H0. inv H1.

  unify_psur. unify_find_funct_ptr.
  rewrite H8 in H16. rewrite H5 in H16.
  rewrite find_instr_append_head in H16 by omega.
  simpl in H16. inv H16.
  simpl in H0. inv H0. inv H1.

  unify_psur. unify_find_funct_ptr.
Qed.

Lemma step_t_to_at_code_0 :
  forall i ge st t st',
    step_t (i :: nil) ge st t st' ->
    exists z',
      at_code z' (i :: nil) 0 ge st.
Proof.
  intros. inv H. eauto.
Qed.

Lemma Z_add_lt :
  forall (a b c : Z),
    a < b ->
    c + a < c + b.
Proof.
  intros. omega.
Qed.

Lemma step_t_labeled_jump_no_trace :
  forall i ge st t st',
    step_t (i :: nil) ge st t st' ->
    (exists l : label, labeled_jump i l) ->
    t = E0.
Proof.
  intros. break_exists.
  inv H. inv H9. inv H3.
  invs.
  reflexivity.
  unify_stuff. find_one_instr. inv H0.
  unify_stuff. find_one_instr. inv H0.
  unify_stuff. unify_find_funct_ptr.
Qed.

Lemma is_label_instr_labeled_jump:
  forall i l l',
    is_label_instr i l ->
    labeled_jump i l' ->
    labeled_jump i l.
Proof.
  intros.
  destruct i; simpl in *; tauto.
Qed.

Lemma measure_decr_fw_j :
  forall c,
    only_forward_jumps c ->
    forall z prog st t st' ofs ofs',
      (no_PC_overflow_prog prog /\ not_after_label_in_code (Genv.globalenv prog) st z c) ->
      step_bits (Genv.globalenv prog) st t st' ->
      at_code z c ofs (Genv.globalenv prog) st ->
      at_code z c ofs' (Genv.globalenv prog) st' ->
      (* step_in z c (Genv.globalenv prog) st t st' -> *)
      lt (measure_fun (z + zlen c) st') (measure_fun (z + zlen c) st).
Proof.

  intros. break_and.
  unfold only_forward_jumps in *. repeat break_and.
  unfold no_calls in *. unfold no_trace_code in *.
  unfold only_forward_jumps_lab in *.
  app step_at_step_t H1. rename x into instr.
  break_and.
  app find_instr_in H8.
  clear H8. remember True as H8. clear HeqH8.
  name (instr_class instr) Hic.
  repeat break_or.
  - (* straightline case *)
    app step_t_to_at_code_0 H1.
    app at_code_straightline_end H7.
    destruct st as (rs, m). destruct st' as (rs', m').
    inv H1.
    inv H7.
    simpl.
    do 7 find_rewrite.
    inv H2.
    inv H3.
    unify_stuff.
    rewrite zlen_cons.
    simpl.
    eapply Z2Nat.inj_lt.
    omega. omega. omega.
  -   clear H8.
      destruct st as (rs, m).
      destruct st' as (rs', m').
      assert (t = E0) by (app step_t_labeled_jump_no_trace H11).
      subst t.
      copy step_t_labeled_jump.
      copy H1.
      inv H10. inv H20. inv H15.
      app H8 H11. clear H8.

      break_or.
      + (*jump-ish*)
        destruct H8 as (ilbl).
        destruct H8 as (l').
        repeat break_and.

        repeat P inv step_t.
        inv H2.
        inv H3.
        inv H23.
        unify_stuff.
        name H11 Hfind_instr.
        find_one_instr.

        simpl.
        P rwrt_n (rs PC).
        P rwrt_n (rs' PC).
        P rwrt_n (psur a bits).
        rename bits1 into bits0.
        P rwrt_n (psur a0 bits0).

        simpl_exec.
        repeat break_match_hyp; try state_inv.
        clear H18. clear H28.

        P preg_simpl_hyp (Vint bits0).
        P inv (Vint bits0).

        unfold goto_label_bits in *.
        repeat break_match_hyp; try congruence.
        st_inv.
        preg_simpl_hyp H3. inv H3.

        eapply Z2Nat.inj_lt. omega. omega.
        replace (zlen c5 + zlen c - Int.unsigned i1) with
                ((zlen c5 + zlen c) + (- Int.unsigned i1)) by omega.
        replace (zlen c5 + zlen c - Int.unsigned i2) with
        ((zlen c5 + zlen c) + (- Int.unsigned i2)) by omega.
        eapply Z_add_lt.

        cut (Int.unsigned i2 < Int.unsigned i1); try omega.
        rewrite H29. rewrite H32.
        rewrite H1.
        eapply Z_add_lt.

        app label_pos_find_instr Heqo.
        rewrite H36 in H11.
        rewrite H29 in H11.
        rewrite find_instr_append_head in H11 by omega.
        erewrite find_instr_append_tail with (c := nil) in H11 by omega.
        rewrite app_nil_r in H11.

        unfold not_after_label_in_code in *.

        app step_md H7.
        break_and.
        assert (Mem.weak_valid_pointer m' b2 (Int.unsigned (Int.repr (z))) = true).
        eapply Mem.weak_valid_pointer_spec. right.
        erewrite unsigned_repr_PC; eauto.
        erewrite <- (unsigned_repr_PC _ _ (z - 1)); eauto.
        app step_gp H3.
        break_and.
        eapply global_perms_valid_globals in H20.
        unfold valid_globals in H20.
        apply H20.
        unfold is_global. left.
        unfold in_code_range. unfold fundef in *.
        collapse_match. apex in_range_find_instr Heqo.
        erewrite unsigned_repr_PC; eauto.
        omega.

        name (conj Heqo0 H18) Hpsur.
        erewrite <- weak_valid_pointer_sur in Hpsur.
        unify_psur.
        2: assumption.

        unify_find_funct_ptr.
        rename fd1 into f.
        destruct f.
        exploit H4.
        reflexivity. eauto. eauto.
        eauto. eauto. eauto.
        intros.
        break_and.
        unfold ends_in_not_label_from_after_code in *.
        simpl in *.
        clear H4.
        repeat P1 clr (0 <= 0).
        assert (zlen c1 = zlen c7) by omega.
        rewrite H26 in H47.
        Lemma cons_expand :
          forall {A} a (b : list A),
            a :: b = a :: nil ++ b.
          auto.
        Qed.
        rewrite (cons_expand ilbl c2) in H47.
        rewrite (cons_expand ilbl c8) in H47.
        copy @list_eq_middle_therefore_eq.
        specialize (H23 _ c1 (ilbl :: nil) c2 c7 c8).
        app H23 H47.
        clear H23. clear H24. break_and.
        subst.

        copy (@list_eq_middle_therefore_eq instruction).
        app H23 H36. break_and. subst. clear H23. clear H24.

        eapply is_label_instr_labeled_jump in H12; eauto.
        clear H10.

        assert (Int.unsigned (Int.repr z) = z). {
          erewrite unsigned_repr_PC; eauto.
        } idtac.

        rewrite H10 in *.
        rewrite H32 in Heqo.
        assert (ofs' = 0 \/ ofs' > 0) by omega.
        break_or.
        replace (zlen c3 + 0 - 1) with (zlen c3 - 1) in Heqo by omega.
        apex in_range_find_instr Heqo. break_and.
        rewrite find_instr_append_tail with (c := nil) in Heqo by omega.
        rewrite app_nil_r in Heqo.
        app H20 Heqo. inv_false.
        unfold label_in_code.
        eexists; split; eassumption.
        replace (zlen c3 + ofs' - 1) with (zlen c3 + (ofs' - 1)) in Heqo by omega.
        rewrite find_instr_append_head in Heqo by omega.
        rewrite find_instr_append_tail with (c := nil) in Heqo by omega.
        rewrite app_nil_r in Heqo.

        exploit H6.
        2: eauto.
        eauto.
        eauto.
        intros. omega.

  (*       assert (zlen c5 = zlen c7) by omega. *)
  (*       rewrite H25 in H46. *)
  (*       copy @list_eq_middle_therefore_eq. *)
  (*       specialize (H8 _ c5 (ilbl :: nil) c6 c7 c8). *)
  (*       app H8 H46. *)
  (*       clear H8. *)
  (*       clear H13. *)
  (*       destruct H46. *)
  (*       subst c7. subst c8. *)
  (*       clear H2. *)

  (*       rewrite Hfh in Heqo. clear Hfh. *)
  (*       name find_instr_append_tail Hft. *)
  (*       rewrite (Hft c c2 nil) in Heqo. *)
  (*       rewrite app_nil_r in Heqo. *)
  (*       clear Hft.   *)
  (*       2: omega. *)
  (*       2: omega.         *)
  (*       assert (labeled_jump ilbl l0). { *)
  (*         destruct ilbl; simpl; try inv H12; try tauto.           *)
  (*       } *)
  (*       clear H10. clear x0. *)
  (*       rename H2 into Hjmp. *)
  (*       app H6 Hjmp. *)
  (*       clear H2. *)
  (*       Focus 2. *)
  (*       instantiate (1 := ofs). *)
  (*       rewrite <- find_instr_append_head with (a := c1) by omega. *)
  (*       P rwrtb_n (zlen c1 + ofs). *)
  (*       clear H37. clear H2. *)
  (*       P rwrt_n (zlen c5 + 0). *)
  (*       replace (c1 ++ c) with ((c1 ++ c) ++ nil). *)
  (*       Focus 2. *)
  (*       rewrite app_nil_r. reflexivity.         *)
  (*       rewrite find_instr_append_tail with (c := c2).         *)
  (*       Focus 2. *)
  (*       rewrite zlen_app. *)
  (*       copy (zlen_nonneg _ c). *)
  (*       copy (zlen_nonneg _ c1). *)
  (*       copy (zlen_nonneg _ c5). *)
  (*       omega. *)
  (*       rewrite app_ass. *)
  (*       P rwrtb_n (c1 ++ c ++ c2).    *)
  (*       P rwrt_n (c5 ++ (ilbl :: nil) ++ c6). *)
  (*       rewrite find_instr_append_head by omega. *)
  (*       simpl. *)
  (*       reflexivity. *)

  (*       omega. *)

      + (*straightline-ish*)
        inv H8.
        simpl.
        unfold nextinstr.
        repeat collapse_match. preg_simpl.
        simpl.

        inv H3. preg_simpl_hyp H13.
        find_rewrite. simpl in H13. inv H13.
        collapse_match.

        app step_md H18.
        app step_gp H7.
        repeat break_and.
        eapply nat_of_Z_lt; try omega.
        rewrite H19.
        repeat unify_find_funct_ptr.
        inv H2. unify_stuff. omega.

        cut (Int.unsigned i0 > Int.unsigned i); intros; try omega.

        assert (in_code_range (Genv.globalenv prog) b i). {
          unfold in_code_range.
          unfold fundef in *.
          rewrite H25.

          rewrite H26. repeat rewrite zlen_app. rewrite zlen_cons.
          replace (zlen (@nil instruction)) with 0 by (simpl; auto).
          rewrite H19. name (zlen_nonneg _ c1) zlnc1.
          name (zlen_nonneg _ c2) zlnc2.
          omega.

        } idtac.

        app psur_add_one H17; try solve [econstructor]. rewrite H17 in H15.
        inv H15.

        unfold Int.add.
        rewrite Int.unsigned_one.
        erewrite unsigned_repr_PC; eauto. omega.
        left. rewrite H26.
        replace (Int.unsigned i + 1 - 1) with (zlen c1 + 0) by omega.

        rewrite find_instr_append_head by omega.
        simpl. reflexivity.

        eapply in_range_PC.
        eassumption. unfold ge.
        apply H25. rewrite H26.
        rewrite H19. rewrite find_instr_append_head by omega.
        simpl. reflexivity.

  - exploit find_instr_in.
    intros.
    destruct H11.
    app H11 H9.
    clear H12.
    app H H10.
    tauto.
  - copy no_trace_trace.
    exploit find_instr_in.
    intros.
    destruct H12.
    clear H13.
    app H12 H9.
    app H11 H10.
    exploit H5.
    eauto.
    intros.
          destruct instr; simpl in *; tauto.

Qed.

Lemma z_nat_lt :
  forall z z',
    z >= 0 -> z' >= 0 ->
    (nat_of_Z z < nat_of_Z z')%nat ->
    z < z'.
Proof.
  intros.
  unfold nat_of_Z in H1.
  apply Z2Nat.inj_lt; try auto; omega.
Qed.

(* Lemma only_forward_in : *)
(*   forall c, *)
(*     only_forward_jumps c -> *)
(*     forall z prog rs m t rs' m', *)
(*       (no_PC_overflow_prog prog /\ *)
(*        not_after_label (Genv.globalenv prog) (State rs m) z c) -> *)
(*       in_code z c (Genv.globalenv prog) (State rs m) -> *)
(*       step_bits (Genv.globalenv prog) (State rs m) t (State rs' m') -> *)
(*       forall b i i' bits bits', *)
(*         rs PC = Values.Vint bits -> *)
(*         rs' PC = Values.Vint bits' -> *)
(*         psur bits = (b,i) -> *)
(*         psur bits' = (b,i') -> *)
(*         Int.unsigned i < Int.unsigned i'. *)
(* Proof. *)
(*   intros.  *)

(* TODO: what is needed here? *)
(* Used only for creating rewrites. Look at later *)

Lemma only_forward_PC_incr :
    forall c,
    only_forward_jumps c ->
    forall z prog rs m t rs' m' ofs ofs' md md',
      (no_PC_overflow_prog prog /\
       not_after_label_in_code (Genv.globalenv prog) (State_bits rs m md) z c) ->
      step_bits (Genv.globalenv prog) (State_bits rs m md) t (State_bits rs' m' md') ->
      at_code z c ofs (Genv.globalenv prog) (State_bits rs m md) ->
      at_code z c ofs' (Genv.globalenv prog) (State_bits rs' m' md') ->
      forall b i i' bits bits',
        rs PC = Values.Vint bits ->
        rs' PC = Values.Vint bits' ->
        psur md bits = Some (b,i) ->
        psur md' bits' = Some (b,i') ->
        Int.unsigned i < Int.unsigned i'.
Proof.
  intros.
  app measure_decr_fw_j H1.
  unfold measure_fun in H1.
  rewrite H4 in H1.
  rewrite H5 in H1.
  rewrite H6 in H1.
  rewrite H7 in H1.

  (* name (zlen_nonneg _ c1) zlnc1. *)
  name (zlen_nonneg _ c) zlnc.
  inv H2.
  inv H3.
  unify_stuff.
  app z_nat_lt H1; try omega.
Qed.

Lemma no_trace_step_at :
  forall z c ge st t st' ofs,
    no_trace_code c ->
    at_code z c ofs ge st ->
    step_bits ge st t st' ->
    t = E0.
Proof.
  intros.

  unfold no_trace_code in H.
  inv H0. inv H3.
  invs; eauto;
  try unify_PC;
  try unify_psur;
  try unify_find_funct_ptr.

  peel_code. app H H13. simpl in *. inv_false.
  peel_code. app H H15. simpl in *. inv_false.
Qed.

Lemma no_trace_step_in :
  forall z c ge st t st',
    no_trace_code c ->
    in_code z c ge st ->
    step_bits ge st t st' ->
    t = E0.
Proof.
  intros.
  inv H0. app no_trace_step_at H3.
Qed.

Lemma no_trace_star_step_in :
  forall c,
    no_trace_code c ->
    forall z ge st t st',
      star (step_in z c) ge st t st' ->
      t = E0.
Proof.
  intros. induction H0. reflexivity.
  inv H0.
  app no_trace_step_in H5. subst t1. reflexivity.
Qed.

Lemma no_trace_step_through :
  forall z c ge st t st',
    no_trace_code c ->
    at_code z c 0 ge st ->
    step_through z c ge st t st' ->
    t = E0.
Proof.
  intros. inv H1.
  app no_trace_step_at H3.

  name H5 Hstar.
  rewrite st_in_eq in H5. break_and.
  app no_trace_step_at H4. subst t1.
  app no_trace_star_step_in H1. subst t2.
  app star_step_in_in' Hstar.
  app no_trace_step_in Hstar.
Qed.

Lemma only_forward_jumps_same_block :
  forall rs m t rs' m' z c bits b i bits' b' i' p ofs md md',
    only_forward_jumps c ->
    rs PC = Values.Vint bits ->
    psur md bits = Some (b,i) ->
    step_bits (Genv.globalenv p) (State_bits rs m md) t (State_bits rs' m' md') ->
    at_code z c ofs (Genv.globalenv p) (State_bits rs m md) ->
    rs' PC = Values.Vint bits' ->
    psur md' bits' = Some (b',i') ->
    no_PC_overflow_prog p ->
    b' = b.
Proof.
  intros. unfold only_forward_jumps in H.
  repeat break_and.
  inv H3. unify_PC. unify_psur.
  unfold no_calls in *.
  unfold no_trace_code in *.
  invs; try unify_PC; try unify_psur; try unify_find_funct_ptr;
  match goal with
    | [ H : fn_code _ = _, H2 : find_instr ?X _ = _, H3 : ?X = _ |- _ ] =>
      rewrite H in H2; rewrite H3 in H2;
      rewrite find_instr_append_head in H2 by omega;
      rewrite find_instr_append_tail with (c := nil) in H2 by omega;
      rewrite app_nil_r in H2;
      name H2 Hfind_instr;
      name H2 Hfi
  end;
  app H Hfind_instr;
  app H7 Hfi.

  app step_md H2.
  NP _app step_gp step_bits.

  repeat break_and.

  assert (straightline i0 \/ (exists l, labeled_jump i0 l)).  {
  name (instr_class i0) Hclass.
  repeat break_or; try congruence;
  eauto.
  app H7 H3.
  NP _app no_trace_trace trace_internal. congruence.
  } idtac.

  destruct f.

  NP _app step_PC_same_block step_bits.
  break_and. repeat unify_PC. repeat unify_psur. reflexivity.
  simpl in *.
  match goal with
    | [ H : ?X = _ , H2 : ?Y = _ |- find_instr ?X ?Y = _ ] => rewrite H; rewrite H2
  end.
  rewrite find_instr_append_head by omega.
  rewrite find_instr_append_tail with (c := nil) by omega.
  rewrite app_nil_r. assumption.
  intro. destruct i0; repeat break_or; simpl in *; try inv_false.

  unfold is_call_return in *; unfold no_trace in *; inv_false.
  unfold is_call_return in *; unfold no_trace in *; inv_false.
Qed.

Lemma only_forward_jumps_same_block_star :
  forall p st st' z c t,
    no_PC_overflow_prog p ->
    star (step_in z c) (Genv.globalenv p) st t st' ->
    forall rs m rs' m' md md',
      st = State_bits rs m md ->
      st' = State_bits rs' m' md' ->
      only_forward_jumps c ->
      forall bits b i bits' b' i',
        rs PC = Values.Vint bits ->
        psur md bits = Some (b,i) ->
        rs' PC = Values.Vint bits' ->
        psur md' bits' = Some (b',i') ->
        b' = b.
Proof.
  induction 2; intros.
  * subst. find_inversion. unify_PC.
    unify_psur. reflexivity.
  * destruct s1. destruct s2. destruct s3.
    repeat match goal with
               | [ H : State _ _ = State _ _ |- _ ] => inv H
           end.

    specialize (IHstar _ _ _ _ _ _  eq_refl eq_refl H5).
    name H Hstep_in.
    inv H0. inv H3. inv H11. inv H4.
    inv H2.
    exploit IHstar; try eauto.
    intros. subst.
    inv H10.
    app only_forward_jumps_same_block H12.
Qed.


Require Import List Map Envs AllInRel Exp AppExpFree RenamedApart.
Require Import IL Annotation AutoIndTac AnnotationLattice.
Require Import Liveness.Liveness LabelsDefined.
Require Import SpillSound DoSpill DoSpillRm SpillUtil ReconstrLive.
Require Import ReconstrLiveSmall ReconstrLiveSound InVD AnnP.
Require Import BoundedIn SlotLiftArgs SlotLiftParams.

Set Implicit Arguments.

(** * RegisterBound *)

Lemma bounded_in_incl VD G G' k Lv ZL s (an :  (ann ⦃var⦄))
  : VD ∩ G' ⊆ VD ∩ G
    -> ann_P (bounded_in VD k) (reconstr_live Lv ZL G s an)
    -> ann_P (bounded_in VD k) (reconstr_live Lv ZL G' s an).
Proof.
  intros Gincl base.
  assert (bounded_in VD k G') as biG'.
  {
    apply ann_P_get in base.
    unfold bounded_in in base.
    unfold bounded_in.
    rewrite subset_cardinal with (s':=VD ∩ (getAnn (reconstr_live Lv ZL G s an))); eauto.
    rewrite reconstr_live_G_eq.
    rewrite Gincl.
    clear; cset_tac.
  }
  unfold bounded_in.
  unfold bounded_in in base.
  unfold bounded_in in biG'.
  destruct s, an;
    simpl;
    try destruct a;
    simpl; try eassumption;
      invc base;
      econstructor; try eassumption;
      clear biG';
      erewrite subset_cardinal; try eassumption;
        repeat rewrite union_meet_distr_l;
        rewrite Gincl; try reflexivity.
Qed.

Lemma register_bound_loads
      (k : nat)
      (ZL : list params)
      (Lv : list ⦃var⦄)
      (VD R : ⦃var⦄)
      (s : stmt)
      (slot : var -> var)
      (xs : list var)
      (an : ann ⦃var⦄)
      (x : var)
  : disj VD (map slot VD)
    -> R ⊆ VD
    -> singleton x ⊆ R
    -> of_list xs ⊆ R
    -> bounded_in VD k R
    -> VD ∩ getAnn (reconstr_live Lv ZL ∅ s an) ⊆ R
    -> (forall (x' : var),
          singleton x' ⊆ R
          -> of_list xs ⊆ R
          -> VD ∩ getAnn (reconstr_live Lv ZL ∅ s an) ⊆ R
          -> bounded_in VD k R
          -> ann_P (bounded_in VD k)
                  (reconstr_live Lv ZL (singleton x') s an)
      )
    -> ann_P (bounded_in VD k)
            (reconstr_live Lv ZL
                           (singleton x)
                           (write_moves xs (slot ⊝ xs) s)
                           (add_anns ∅ (length xs) an)
            ).
Proof.
  intros disj_VD R_VD x_R xs_R
         bound_R H  base.
  unfold bounded_in in bound_R.
  general induction xs;
    simpl in *; eauto.
  rewrite add_anns_S.
  rewrite add_union_singleton in xs_R.
  apply union_incl_split2 in xs_R as [a_R xs_R].
  econstructor.
  - unfold bounded_in.
    rewrite reconstr_live_write_loads; [ | | eauto];
      [ | rewrite xs_R, R_VD; clear; cset_tac].
    rewrite subset_cardinal with (s':=VD ∩ R); eauto.
    apply incl_meet_split; [clear; cset_tac | ].
    setoid_rewrite union_comm at 3.
    rewrite union_minus_incl.
    repeat rewrite union_meet_distr_l.
    repeat apply union_incl_split; eauto.
    + rewrite incl_minus.
      rewrite H.
      clear; cset_tac.
    + rewrite disj_empty_cut; eauto.
      * clear; cset_tac.
      * rewrite xs_R, R_VD; clear; cset_tac.
    + rewrite <- map_singleton; eauto.
      rewrite disj_empty_cut; eauto.
      * clear; cset_tac.
      * rewrite a_R, R_VD; clear; cset_tac.
    + rewrite <- x_R.
      clear; cset_tac.
  - eapply IHxs with (R:=R); eauto.
    intros x' x'_R' xs_R' al_R' bound_R'.
    eapply base; eauto.
    rewrite add_union_singleton, a_R, xs_R.
    clear; cset_tac.
Qed.

Lemma register_bound_spills
      (k : nat)
      (ZL : list params)
      (Lv : list ⦃var⦄)
      (VD R G : ⦃var⦄)
      (s : stmt)
      (slot : var -> var)
      (xs : list var)
      (an : ann ⦃var⦄)
  :
    disj VD (map slot VD)
    -> R ⊆ VD
    -> of_list xs ⊆ R
    -> bounded_in VD k R
    -> VD ∩ G ⊆ R
    -> VD ∩ getAnn (reconstr_live Lv ZL ∅ s an) ⊆ R
    -> ann_P (bounded_in VD k)
            (reconstr_live Lv ZL G s an)
    -> ann_P (bounded_in VD k)
            (reconstr_live Lv ZL
                           G
                           (write_moves (slot ⊝ xs) xs s)
                           (add_anns ∅ (length xs) an)
                 ).
Proof.
  intros disj_VD R'_VD xs_R'
         bound_G G_rkl H base.
  unfold bounded_in in bound_G.
  general induction xs;
    simpl in *; eauto.
  rewrite add_anns_S.
  rewrite add_union_singleton in xs_R'.
  apply union_incl_split2 in xs_R' as [a_R' xs_R'].
  econstructor.
  - unfold bounded_in.
    rewrite reconstr_live_write_spills; eauto;
      [ | rewrite xs_R', R'_VD; clear; cset_tac].
    rewrite subset_cardinal with (s':=VD ∩ R); eauto.
    apply incl_meet_split; [clear; cset_tac | ].
    setoid_rewrite union_comm at 3.
    rewrite union_minus_incl.
    repeat rewrite union_meet_distr_l.
    repeat apply union_incl_split; eauto.
    + rewrite incl_minus.
      rewrite H.
      clear; cset_tac.
    + rewrite xs_R'.
      clear; cset_tac.
    + rewrite a_R'.
      clear; cset_tac.
  - eapply IHxs with (R:=R) ; eauto.
    rewrite <- map_singleton; eauto.
    rewrite disj_empty_cut; eauto.
    + clear; cset_tac.
    + rewrite a_R', R'_VD.
      reflexivity.
    + eapply bounded_in_incl; eauto.
      rewrite <- map_singleton; eauto.
      rewrite disj_empty_cut; eauto.
      * clear; cset_tac.
      * rewrite a_R', R'_VD.
        reflexivity.
Qed.

Lemma meet_minus_assoc (X : Type) `{OrderedType X} (s t u : ⦃X⦄)
  : (s ∩ t) \ u [=] s ∩ (t \ u) .
Proof.
  cset_tac.
Qed.

Lemma register_bound_s k ZL Lv VD R G s slot xs ys (an : ann ⦃var⦄)
  : disj VD (map slot VD)
    -> R ⊆ VD
    -> of_list xs ⊆ R
    -> of_list ys ⊆ VD
    -> cardinal R <= k
    -> bounded_in VD k (getAnn (reconstr_live Lv ZL ∅ s an) ∪ of_list ys)
    -> VD ∩ G ⊆ R
    -> VD ∩ getAnn (reconstr_live Lv ZL ∅ s an) ⊆ R ∪ of_list ys
    -> (forall (G' R' : ⦃var⦄),
          VD ∩ G' ⊆ R'
          -> of_list ys ⊆ R'
          -> VD ∩ getAnn (reconstr_live Lv ZL ∅ s an) ⊆ R'
          -> cardinal R' <= k
          -> ann_P (bounded_in VD k)
                  (reconstr_live Lv ZL G' s an)
      )
    -> ann_P (bounded_in VD k)
            (reconstr_live Lv ZL
                           G
                           (write_moves (slot ⊝ xs) xs
                                         (write_moves ys (slot ⊝ ys) s)
                           )
                           (add_anns ∅ (length xs + length ys) an)
            ).
Proof.
  intros disj_VD R_VD xs_R ys_VD bound_R2 bound_al_L G_R al_R base.
  assert (bounded_in VD k R) as bound_R.
  {
    clear - bound_R2.
    unfold bounded_in.
    rewrite subset_cardinal; eauto.
    cset_tac.
  }
  rewrite add_anns_add.
  destruct ys as [|v ?].
  - simpl in *.
    apply register_bound_spills with (R:=R); eauto.
      rewrite add_anns_zero.
    + rewrite al_R; clear; cset_tac.
    + eapply base with (R':=R); eauto.
      * clear; cset_tac.
      * rewrite al_R; clear; cset_tac.
  - eapply register_bound_spills with (R:=R); eauto.
      {
        rewrite reconstr_live_write_loads; eauto.
        repeat rewrite union_meet_distr_l.
        repeat apply union_incl_split.
        - rewrite <- meet_minus_assoc.
          rewrite al_R.
          clear; cset_tac.
        - rewrite disj_empty_cut; eauto.
          clear; cset_tac.
        - clear; cset_tac.
      }
      simpl in *.
      rewrite add_union_singleton in ys_VD.
      apply union_incl_split2 in ys_VD as [v_VD ys_VD].
      rewrite add_anns_S.
      econstructor.
    + unfold bounded_in.
      rewrite reconstr_live_write_loads; eauto.
      repeat rewrite union_meet_distr_l.
      rewrite <- meet_minus_assoc.
      repeat rewrite union_meet_distr_l.
      rewrite <- meet_minus_assoc.
      rewrite al_R.
      assert (forall (x : var) (s t u v : ⦃var⦄),
                 ((s ∪ {x; t}) \ t ∪ (v ∩ u) ∪ (v ∩ singleton x) ) \ singleton x
               ⊆ ((s ∪ (v ∩ u))))
        as seteq by (clear; cset_tac).
      rewrite seteq.
      rewrite subset_cardinal with (s':=VD ∩ R); eauto.
      repeat apply union_incl_split; eauto.
      * clear - R_VD; cset_tac.
      * rewrite disj_empty_cut; eauto.
        clear; cset_tac.
      * rewrite <- map_singleton; eauto.
        rewrite disj_empty_cut; eauto.
        clear; cset_tac.
      * rewrite G_R.
        clear - R_VD; cset_tac.
    + eapply register_bound_loads
      with (R:=VD ∩ getAnn (reconstr_live Lv ZL ∅ s an)
                  ∪ {v; of_list ys}); eauto.
      * rewrite add_union_singleton, v_VD, ys_VD.
        clear; cset_tac.
      * clear; cset_tac.
      * clear; cset_tac.
      * unfold bounded_in.
        assert (forall (s t u : ⦃var⦄),
                   s ∩ (s ∩ t ∪ u) ⊆ s ∩ (t ∪ u))
          as setsub by (clear; cset_tac).
        rewrite setsub.
        assumption.

      * intros.
        eapply base; eauto.
        -- rewrite H.
           clear; cset_tac.
        -- clear; cset_tac.
        -- unfold bounded_in in H2.
           rewrite subset_cardinal; eauto.
           apply union_incl_split.
           ++ clear; cset_tac.
           ++ rewrite union_meet_distr_l.
              apply incl_union_right.
              apply incl_meet_split; eauto.
              rewrite add_union_singleton, v_VD, ys_VD.
              clear; cset_tac.
Qed.

Lemma slot_lift_args_RMapp_incl (slot : var -> var) (Y : args) RM RMapp Z
  : (forall (n : nat) (y : op), get Y n y -> isVar y)
    -> (list_union (Ops.freeVars ⊝ Y) ⊆ fst RMapp ∪ snd RMapp)
    -> list_union (Ops.freeVars ⊝ slot_lift_args slot RM RMapp Y Z)
                 ⊆ fst RMapp ∪ map slot (snd RMapp).
Proof.
  general induction Y; destruct Z; simpl in *; only 1,2,3: eauto with cset.
  revert H0.
  exploit H as IV; eauto using get. invc IV. simpl.
  repeat cases; simpl; norm_lunion; intro;
    rewrite IHY; eauto using get; intros; clear IHY H.
  - assert (v ∈ fst RMapp ∪ snd RMapp). cset_tac.
    unfold choose_y; simpl; repeat cases; simpl.
    + revert COND1. clear_all. cset_tac.
    + revert COND1 COND2. clear_all. cset_tac.
    + revert COND1. clear_all. cset_tac.
    + revert H NOTCOND. clear_all. cset_tac.
    + revert COND1. clear_all. cset_tac.
    + exfalso. cset_tac.
    + revert COND0 COND2. clear_all. cset_tac.
    + revert COND0. clear_all. cset_tac.
    + revert COND0. clear_all. cset_tac.
    + revert COND1. clear_all. cset_tac.
    + exfalso. revert H NOTCOND0 NOTCOND1. cset_tac.
    + revert NOTCOND0 H. clear_all. cset_tac.
  - rewrite <- H0. cset_tac.
  - assert (v ∈ fst RMapp ∪ snd RMapp). cset_tac.
    unfold choose_y; simpl; repeat cases; simpl.
    + revert COND1. clear_all. cset_tac.
    + revert NOTCOND0 H. clear_all. cset_tac.
  - rewrite <- H0. cset_tac.
  - assert (v ∈ fst RMapp ∪ snd RMapp). cset_tac.
    unfold choose_y; simpl; repeat cases; simpl.
    + revert COND0. clear_all. cset_tac.
    + revert NOTCOND1 H. clear_all. cset_tac.
    + revert COND. clear_all. cset_tac.
    + revert NOTCOND2 H. clear_all. cset_tac.
  - rewrite <- H0. cset_tac.
Qed.

Lemma register_bounded k (slot : var -> var) ZL G Λ R M VD s Lv sl al ra
  : cardinal R <= k
    -> injective_on VD slot
    -> disj VD (map slot VD)
    -> R ⊆ VD
    -> M ⊆ VD
    -> fst (getAnn ra) ∪ snd (getAnn ra) ⊆ VD
    -> app_expfree s
    -> renamedApart s ra
    -> spill_sound k ZL Λ (R,M) s sl
    -> spill_live VD sl al
    -> live_sound Imperative ZL Lv s al
    -> PIR2 Equal (merge ⊝ Λ) Lv
    -> (forall (Z : params) n,
          get ZL n Z
          -> of_list Z ⊆ VD)
    -> (forall (n : nat) Z blv,
          get ZL n Z ->
          get Lv n blv ->
          of_list Z [<=] blv)
    -> VD ∩ G ⊆ R
    -> ann_P (bounded_in VD k)
            (reconstr_live_do_spill slot Λ ZL G s sl).
Proof.
  intros card_R inj_VD disj_VD R_VD M_VD ra_VD
         aeFree rena spillSnd spilli lvSnd
         H16 Z_VD Z_LV G_R.
  unfold reconstr_live_do_spill.
  general induction lvSnd;
    invc aeFree;
    inv rena;
    inv spilli;
    inv spillSnd;
    eapply renamedApart_incl in rena; eauto;
      simpl in *; eauto;
        unfold count;
        simpl;
        do 2 rewrite <- elements_length.

  - eapply register_bound_s with (VD:=VD) (R:=R); simpl; eauto.
    + rewrite of_list_elements, H19.
      reflexivity.
    + rewrite of_list_elements, H20, H19, R_VD, M_VD.
      clear; cset_tac.
    + unfold bounded_in.
      rewrite of_list_elements.
      rewrite reconstr_live_small with (VD:=VD) (R:={x; (R\K ∪ L) \ Kx}) (M:=Sp ∪ M); eauto.
      * rewrite subset_cardinal with (s':=R \K ∪ L); eauto.
        assert (forall (x : var) (s t : ⦃var⦄),
                   ({x; s} ∪ t ∪ singleton x) \ singleton x
                                              ⊆ s ∪ t)
          as setsub by (clear; cset_tac).
        rewrite setsub.
        repeat rewrite union_meet_distr_l.
        repeat apply union_incl_split.
        -- clear; cset_tac.
        -- rewrite disj_empty_cut; eauto.
           ++ clear; cset_tac.
           ++ rewrite H19, R_VD, M_VD.
              clear; cset_tac.
        -- rewrite H22. clear; cset_tac.
        -- clear; cset_tac.
        -- clear; cset_tac.
      * rewrite H20, H19, R_VD, M_VD.
        eapply x_VD in H10; eauto.
        revert H10; clear; cset_tac.
      * rewrite H19, M_VD, R_VD.
        clear; cset_tac.
      * rewrite rena, <- ra_VD.
        eauto.
    + rewrite of_list_elements.
      rewrite reconstr_live_small with (VD:=VD) (R:={x; (R\K ∪ L) \ Kx}) (M:=Sp ∪ M); eauto.
      * assert (forall (x : var) (s t : ⦃var⦄),
                   ({x; s} ∪ t ∪ singleton x) \ singleton x
                                              ⊆ s ∪ t)
          as setsub by (clear; cset_tac).
        rewrite setsub.
        repeat rewrite union_meet_distr_l.
        repeat apply union_incl_split.
        -- clear; cset_tac.
        -- rewrite disj_empty_cut; eauto.
           ++ clear; cset_tac.
           ++ rewrite H19, R_VD, M_VD.
              clear; cset_tac.
        -- rewrite H22. clear; cset_tac.
        -- clear; cset_tac.
      * rewrite H20, H19, R_VD, M_VD.
        eapply x_VD in H10; eauto.
        revert H10; clear; cset_tac.
      * rewrite H19, M_VD, R_VD.
        clear; cset_tac.
      * rewrite rena, <- ra_VD.
        eauto.
    + intros G' R' G'_R' L_R' al_R' bound_R'.
      rewrite of_list_elements in L_R'.
      econstructor.
      * unfold bounded_in.
        rewrite subset_cardinal with (s':=R'); eauto.
        -- rewrite union_meet_distr_l.
           rewrite G'_R'.
           rewrite empty_neutral_union_r in al_R'.
           rewrite al_R'.
           clear; cset_tac.
      * eapply IHlvSnd with (R:={x; (R\K ∪ L) \ Kx})
                            (M:=Sp ∪ M); try eassumption.
        -- eapply Rx_VD with (VD:=VD) (M:=M); eauto.
           eapply x_VD; eauto.
        -- eauto using M'_VD.
        -- rewrite rena, <- ra_VD; eauto.
        -- clear; cset_tac.
  - destruct rena as [rena1 rena2].
    eapply register_bound_s with (VD:=VD) (R:=R); simpl; eauto.
    + rewrite of_list_elements; assumption.
    + rewrite of_list_elements, H25, H24, R_VD, M_VD.
      clear; cset_tac.
    + unfold bounded_in.
      rewrite of_list_elements.
      rewrite subset_cardinal; eauto.
      rewrite reconstr_live_small with (VD:=VD) (R:=R\K ∪ L) (M:=Sp ∪ M); eauto.
      * rewrite reconstr_live_small with (VD:=VD) (R:=R\K ∪ L) (M:=Sp ∪ M); eauto.
        -- repeat rewrite union_meet_distr_l.
           clear - H24 H25 H26 R_VD M_VD disj_VD.
           assert (VD ∩ map slot (Sp ∪ M) ⊆ R \ K ∪ L) as goal37.
           {
             rewrite disj_empty_cut; eauto.
             - clear; cset_tac.
             - rewrite H24, R_VD, M_VD; cset_tac.
           }
           repeat apply union_incl_split; eauto; try rewrite H26;
            clear; cset_tac.
        -- rewrite H25, H24, R_VD, M_VD. clear; cset_tac.
        -- rewrite H24, R_VD, M_VD; clear; cset_tac.
        -- rewrite rena2, <- ra_VD; eauto.
      * rewrite H25, H24, R_VD, M_VD. clear; cset_tac.
      * rewrite H24, R_VD, M_VD; clear; cset_tac.
      * rewrite rena1, <- ra_VD; eauto.
    + rewrite of_list_elements.
      rewrite reconstr_live_small with (VD:=VD) (R:=R\K ∪ L) (M:=Sp ∪ M); eauto.
      * rewrite reconstr_live_small with (VD:=VD) (R:=R\K ∪ L) (M:=Sp ∪ M); eauto.
        -- repeat rewrite union_meet_distr_l.
           clear - H24 H25 H26 R_VD M_VD disj_VD.
           assert (VD ∩ map slot (Sp ∪ M) ⊆ R ∪ L) as goal37.
           {
             rewrite disj_empty_cut; eauto.
             - clear; cset_tac.
             - rewrite H24, R_VD, M_VD; cset_tac.
           }
           repeat apply union_incl_split; eauto;
             try rewrite H26; clear; cset_tac.
        -- rewrite H25, H24, R_VD, M_VD. clear; cset_tac.
        -- rewrite H24, R_VD, M_VD; clear; cset_tac.
        -- rewrite rena2, <- ra_VD; eauto.
      * rewrite H25, H24, R_VD, M_VD. clear; cset_tac.
      * rewrite H24, R_VD, M_VD; clear; cset_tac.
      * rewrite rena1, <- ra_VD; eauto.
    + intros G' R' G'_R' L_R' al_R' bound_R'.
      rewrite of_list_elements in L_R'.
      econstructor.
      * unfold bounded_in.
        rewrite subset_cardinal with (s':=R'); eauto.
        -- rewrite union_meet_distr_l.
           rewrite G'_R'.
           rewrite empty_neutral_union_r in al_R'.
           rewrite al_R'.
           clear; cset_tac.
      * eapply IHlvSnd1 with (R:=R\K ∪ L)
                              (M:=Sp ∪ M); eauto.
        -- eapply R'_VD with (VD:=VD) (M:=M); eauto.
        -- eapply M'_VD with (VD:=VD) (M:=M) (R:=R); eauto.
        -- rewrite rena1, <- ra_VD; eauto.
        -- clear; cset_tac.
      * eapply IHlvSnd2 with (R:=R\K ∪ L)
                               (M:=Sp ∪ M); eauto.
        -- eapply R'_VD with (VD:=VD) (M:=M); eauto.
        -- eapply M'_VD with (VD:=VD) (M:=M) (R:=R); eauto.
        -- rewrite rena2, <- ra_VD; eauto.
        -- clear; cset_tac.

  - eapply register_bound_s with (VD:=VD) (R:=R); simpl; eauto.
    + rewrite of_list_elements; assumption.
    + rewrite of_list_elements, H13, H12, R_VD, M_VD.
      clear; cset_tac.
    + erewrite nth_zip; eauto.
      unfold bounded_in.
      rewrite subset_cardinal; eauto.
      erewrite !get_nth; eauto using map_get_1. simpl.
      rewrite slot_lift_args_RMapp_incl; simpl; eauto; [|rewrite H22; reflexivity].
      rewrite of_list_elements.
      eapply PIR2_nth in H16; eauto; dcr. inv_get. unfold merge in H8. simpl in *.
      rewrite of_list_slot_lift_params; [|rewrite Z_LV; eauto; rewrite H8; reflexivity].
      simpl in *.
      rewrite H9 in *; clear H9 D'.
      rewrite H23.
      assert (M'VD:M' [<=] VD). {
        rewrite H24, H12, R_VD, M_VD. eauto with cset.
      }
      assert (M_fVD:M_f ⊆ VD). {
        rewrite Mf_VD with (R:=R) (M:=M) (VD:=VD); eauto.
      }
      rewrite empty_neutral_union_r.
      repeat rewrite union_meet_distr_l.
      rewrite (@disj_empty_cut VD); eauto.
      unfold slot_merge. simpl.
      rewrite minus_dist_union.
      repeat rewrite union_meet_distr_l.
      rewrite (@incl_minus _ _ (map slot M_f)).
      rewrite (@disj_empty_cut VD); eauto.
      rewrite empty_neutral_union_r.
      assert (of_list Z ∩ R_f ⊆ of_list Z \ (M_f \ R_f) ∪ map slot (of_list Z \ (R_f \ M_f))). {
        clear_all. cset_tac.
      }
      rewrite <- H4.
      revert H20. clear_all. cset_tac.
    + erewrite nth_zip; eauto.
      rewrite slot_lift_args_RMapp_incl; eauto; simpl; [|rewrite H22; reflexivity].
      erewrite !get_nth; eauto using map_get_1.
      rewrite of_list_elements. unfold slot_merge; simpl.
      rewrite slp_union_minus_incl; eauto; simpl.
      assert (M'VD:M' [<=] VD). {
        rewrite H24, H12, R_VD, M_VD. eauto with cset.
      }
      assert (M_fVD:M_f ⊆ VD). {
        rewrite Mf_VD with (R:=R) (M:=M) (VD:=VD); eauto.
      }
      * rewrite H20, H23.
        rewrite empty_neutral_union_r.
        repeat rewrite union_meet_distr_l.
        rewrite (@disj_empty_cut VD); eauto.
        rewrite minus_incl with (t:=map slot (of_list Z0)).
        rewrite (@disj_empty_cut VD); eauto.
        clear_all. cset_tac.
      * rewrite Rf_VD with (R:=R) (M:=M) (VD:=VD) (L:=L); eauto.
      * rewrite Mf_VD with (R:=R) (M:=M) (VD:=VD); eauto.
    + intros G' R'' G'_R' L_R' al_R' bound_R'.
      econstructor.
      unfold bounded_in.
      rewrite subset_cardinal; eauto.
      rewrite union_meet_distr_l.
      rewrite empty_neutral_union_r in al_R'.
      rewrite al_R', G'_R'.
      clear; cset_tac.
  - eapply register_bound_s with (VD:=VD) (R:=R); simpl; eauto.
    + rewrite of_list_elements; assumption.
    + rewrite of_list_elements, H9, H8, R_VD, M_VD.
      clear; cset_tac.
    + unfold bounded_in.
      rewrite of_list_elements.
      rewrite subset_cardinal; eauto.
      rewrite H10.
      clear; cset_tac.
    + rewrite H10, of_list_elements.
      clear; cset_tac.
    + intros G' R' G'_R' L_R' al_R' bound_R'.
      rewrite empty_neutral_union_r in al_R'.
      econstructor.
      unfold bounded_in.
      rewrite subset_cardinal; eauto.
      rewrite union_meet_distr_l, G'_R', al_R'.
      clear; cset_tac.

  - destruct rena as [renaF rena2].
    eapply register_bound_s with (VD:=VD) (R:=R); simpl; eauto.
    + rewrite of_list_elements; assumption.
    + rewrite of_list_elements, H29, H28, R_VD, M_VD; clear; cset_tac.
    + unfold bounded_in.
      rewrite fst_zip_pair; eauto with len.
      rewrite slot_lift_params_app; eauto with len.
      rewrite getAnn_map_setTopAnn.
      rewrite Take.take_eq_ge;
        [|unfold slot_merge; len_simpl; rewrite <- H31, <- H32; omega].
      rewrite slot_merge_app.
      rewrite subset_cardinal; eauto.
      rewrite reconstr_live_small with (VD:=VD) (R:=R\K∪L) (M:=Sp ∪ M); eauto.
      * rewrite of_list_elements, !empty_neutral_union_r.
        repeat rewrite union_meet_distr_l.
        repeat apply union_incl_split.
        -- clear; cset_tac.
        -- clear; cset_tac.
        -- rewrite disj_empty_cut; eauto.
           ++ clear; cset_tac.
           ++ rewrite H28, R_VD, M_VD; clear; cset_tac.
        -- clear; cset_tac.
      * eapply R'_VD with (VD:=VD) (L:=L) (M:=M); eauto.
      * rewrite H28, R_VD, M_VD; clear; cset_tac.
      * rewrite rena2, <- ra_VD; eauto.
      * eapply getAnn_als_EQ_merge_rms; eauto.
      * intros.
        eapply get_ofl_VD; eauto.
    + rewrite fst_zip_pair; eauto with len.
      rewrite slot_lift_params_app; eauto with len.
      rewrite getAnn_map_setTopAnn.
      rewrite Take.take_eq_ge;
        [|unfold slot_merge; len_simpl; rewrite <- H31, <- H32; omega].
      rewrite slot_merge_app.
      rewrite reconstr_live_small with (VD:=VD) (R:=R\K∪L) (M:=Sp ∪ M); eauto.
      * rewrite of_list_elements, !empty_neutral_union_r.
        repeat rewrite union_meet_distr_l.
        repeat apply union_incl_split.
        -- clear; cset_tac.
        -- clear; cset_tac.
        -- rewrite disj_empty_cut; eauto.
           ++ clear; cset_tac.
           ++ rewrite H28, R_VD, M_VD; clear; cset_tac.
      * eapply R'_VD with (VD:=VD) (L:=L) (M:=M); eauto.
      * rewrite H28, R_VD, M_VD; clear; cset_tac.
      * rewrite rena2, <- ra_VD; eauto.
      * eapply getAnn_als_EQ_merge_rms; eauto.
      * intros.
        eapply get_ofl_VD; eauto.
    + intros G' R' G'_R' L_R' al_R' bound_R'.
      rewrite fst_zip_pair; eauto with len.
      rewrite slot_lift_params_app; eauto with len.
      rewrite getAnn_map_setTopAnn.
      rewrite Take.take_eq_ge;
        [|unfold slot_merge; len_simpl; rewrite <- H31, <- H32; omega].
      rewrite slot_merge_app.

      rewrite fst_zip_pair in al_R'; eauto with len.
      rewrite slot_lift_params_app in al_R'; eauto with len.
      rewrite getAnn_map_setTopAnn in al_R'.
      rewrite Take.take_eq_ge in al_R';
        [|unfold slot_merge; len_simpl; rewrite <- H31, <- H32; omega].
      rewrite slot_merge_app in al_R'.

      econstructor.
      * unfold bounded_in.
        rewrite subset_cardinal; eauto.
        rewrite union_meet_distr_l.
        rewrite empty_neutral_union_r in al_R'.
        rewrite G'_R', al_R'.
        clear; cset_tac.
      * intros; inv_get.
        rewrite <- reconstr_live_setTopAnn.
        exploit H10 as funConstr; eauto.
        exploit renaF as renaF'; eauto.
        exploit H34 as spillSnd'; eauto.
        exploit H20 as rm_VD; eauto.
        destruct rm_VD as [f_x3_VD s_x3_VD]; eauto.
        rewrite pair_eta with (p:=x3) in spillSnd'.
        destruct funConstr as [funConstr _].
        apply incl_from_union_eq in funConstr as funConstr1.
        rewrite union_comm in funConstr.
        apply incl_from_union_eq in funConstr as funConstr2.
        simpl.
        eapply H1 with (R:=fst x3) (M:=snd x3); eauto.
        -- rewrite renaF', <- ra_VD; eauto.
        -- eapply getAnn_als_EQ_merge_rms; eauto.
        -- intros.
           eapply get_ofl_VD; eauto.
        -- intros.
           eapply get_app_cases in H4 as [?|[? ?]]; inv_get.
           edestruct H2; eauto. len_simpl.
           eapply get_app_ge in H14. len_simpl.
           rewrite <- H in *.
           eapply Z_LV; eauto. len_simpl. rewrite <- H. eauto.
        -- setoid_rewrite pair_eta with (p:=x3) at 1.
           rewrite pair_eta with (p:=x3) in H23.
           eapply al_sub_RfMf in H23; eauto.
           rewrite ofl_slp_sub_rm; eauto.
           ++ rewrite union_meet_distr_l.
              apply union_incl_split.
              ** clear; cset_tac.
              ** rewrite disj_empty_cut; eauto.
                 clear; cset_tac.
           ++ exploit H2 as H2'; eauto.
      * eapply IHlvSnd with (R:=R\K ∪ L) (M:=Sp ∪ M); eauto.
        -- eapply R'_VD with (VD:=VD) (L:=L) (M:=M); eauto.
        -- rewrite H28, R_VD, M_VD; eauto.
           clear; cset_tac.
        -- rewrite rena2, <- ra_VD; eauto.
        -- apply getAnn_als_EQ_merge_rms; eauto.
        -- intros.
           eapply get_ofl_VD; eauto.
        -- intros.
           eapply get_app_cases in H4 as [?|[? ?]]; inv_get.
           edestruct H2; eauto. len_simpl.
           eapply get_app_ge in H5. len_simpl.
           rewrite <- H in *.
           eapply Z_LV; eauto. len_simpl. rewrite <- H. eauto.
        -- clear; cset_tac.
Qed.


Require Import Bedrock.Platform.Cito.CompileStmtSpec.
Require Import Bedrock.StringSet.
Require Import Bedrock.Platform.Cito.FreeVars.
Require Import Bedrock.Platform.Cito.SynReqFactsUtil.

Local Infix ";;" := Syntax.Seq (right associativity, at level 95).

Require Bedrock.Platform.Cito.CompileExpr.

Lemma syn_req_Assign_e : forall vars temp_size x e k, syn_req vars temp_size (Syntax.Assign x e ;; k) -> CompileExpr.syn_req vars temp_size e 0.
  unfold syn_req, CompileExpr.syn_req, in_scope; simpl; intuition.
  apply Subset_union_left in H; intuition.
  apply Subset_union_left in H0; intuition.
  eauto using Max.max_lub_l.
Qed.


Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 2073 lines to 358 lines, then from 359 lines to 218 lines, then from 107 lines to 92 lines *)
(* coqc version trunk (October 2014) compiled on Oct 11 2014 1:13:41 with OCaml 4.01.0
   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d65496f09c4b68fa318783e53f9cd6d5c18e1eb7) *)
Require Coq.Lists.List.

Import Coq.Lists.List.

Set Implicit Arguments.
Global Set Asymmetric Patterns.

Section machine.
  Variables pc state : Type.

  Inductive propX (i := pc) (j := state) : list Type -> Type :=
  | Inj : forall G, Prop -> propX G
  | ExistsX : forall G A, propX (A :: G) -> propX G.

  Arguments Inj [G].

  Definition PropX := propX nil.
  Fixpoint last (G : list Type) : Type.
    exact (match G with
             | nil => unit
             | T :: nil => T
             | _ :: G' => last G'
           end).
  Defined.
  Fixpoint eatLast (G : list Type) : list Type.
    exact (match G with
             | nil => nil
             | _ :: nil => nil
             | x :: G' => x :: eatLast G'
           end).
  Defined.

  Fixpoint subst G (p : propX G) : (last G -> PropX) -> propX (eatLast G) :=
    match p with
      | Inj _ P => fun _ => Inj P
      | ExistsX G A p1 => fun p' =>
                            match G return propX (A :: G) -> propX (eatLast (A :: G)) -> propX (eatLast G) with
                              | nil => fun p1 _ => ExistsX p1
                              | _ :: _ => fun _ rc => ExistsX rc
                            end p1 (subst p1 (match G return (last G -> PropX) -> last (A :: G) -> PropX with
                                                | nil => fun _ _ => Inj True
                                                | _ => fun p' => p'
                                              end p'))
    end.

  Definition spec := state -> PropX.
  Definition codeSpec := pc -> option spec.

  Inductive valid (specs : codeSpec) (G : list PropX) : PropX -> Prop := Env : forall P, In P G -> valid specs G P.
  Definition interp specs := valid specs nil.
End machine.
Notation "'ExX' : A , P" := (ExistsX (A := A) P) (at level 89) : PropX_scope.
Bind Scope PropX_scope with PropX propX.
Variables pc state : Type.

Inductive subs : list Type -> Type :=
| SNil : subs nil
| SCons : forall T Ts, (last (T :: Ts) -> PropX pc state) -> subs (eatLast (T :: Ts)) -> subs (T :: Ts).

Fixpoint SPush G T (s : subs G) (f : T -> PropX pc state) : subs (T :: G) :=
  match s in subs G return subs (T :: G) with
    | SNil => SCons _ nil f SNil
    | SCons T' Ts f' s' => SCons T (T' :: Ts) f' (SPush s' f)
  end.

Fixpoint Substs G (s : subs G) : propX pc state G -> PropX pc state :=
  match s in subs G return propX pc state G -> PropX pc state with
    | SNil => fun p => p
    | SCons _ _ f s' => fun p => Substs s' (subst p f)
  end.
Variable specs : codeSpec pc state.

Lemma simplify_fwd_ExistsX : forall G A s (p : propX pc state (A :: G)),
                               interp specs (Substs s (ExX  : A, p))
                               -> exists a, interp specs (Substs (SPush s a) p).
admit.
Defined.

Goal    forall (G : list Type) (A : Type) (p : propX pc state (@cons Type A G))
               (s : subs G)
               (_ : @interp pc state specs (@Substs G s (@ExistsX pc state G A p)))
               (P : forall _ : subs (@cons Type A G), Prop)
               (_ : forall (s0 : subs (@cons Type A G))
                           (_ : @interp pc state specs (@Substs (@cons Type A G) s0 p)),
                      P s0),
          @ex (forall _ : A, PropX pc state)
              (fun a : forall _ : A, PropX pc state => P (@SPush G A s a)).
  intros ? ? ? ? H ? H'.
  apply simplify_fwd_ExistsX in H.
  firstorder.
Qed.
 (* Toplevel input, characters 15-19:
Error: Illegal application:
The term "cons" of type "forall A : Type, A -> list A -> list A"
cannot be applied to the terms
 "Type" : "Type"
 "T" : "Type"
 "G0" : "list Type"
The 2nd term has type "Type@{Top.53}" which should be coercible to
 "Type@{Top.12}".
 *)


Require Export DEX_ElemLemmas.

Import DEX_BigStepWithTypes.DEX_BigStepWithTypes DEX_BigStep.DEX_Dom DEX_Prog.

Section p.

Variable kobs: L.t.
Variable p:DEX_ExtendedProgram.
Variable se : DEX_PC -> L.t.
Variable reg : DEX_PC -> DEX_PC -> Prop.
Variable m : DEX_Method.
Variable lookupswitch_hyp : well_formed_lookupswitch m.

Ltac soap2_intra_normal_aux Hreg_in H Hreg r lvl Hget_ori Hvalue_opt_in k k':=
  specialize Hreg_in with r;
  inversion Hreg_in as [k k' Hget Hget' Hleq Hleq'| Hvalue_opt_in];
  try (apply H in Hreg; apply leql_join_each in Hreg; inversion Hreg as [Hleql1 Hleql1'];
    apply not_leql_trans with (k2:=lvl) in Hleq; auto);
  try (apply H in Hreg; apply not_leql_trans with (k2:=lvl) in Hleq; auto);
  try (rewrite Hget in Hget_ori; inversion Hget_ori; subst; auto).

(* High Branching *)
Lemma soap2_intra_normal :
 forall sgn pc pc2 pc2' i r1 rt1 r1' rt1' r2 r2' rt2 rt2' ,
   instructionAt m pc = Some i ->
   NormalStep se reg m sgn i (pc,r1) rt1 (pc2,r2) rt2 ->
   NormalStep se reg m sgn i (pc,r1') rt1' (pc2',r2') rt2' ->
   pc2 <> pc2' ->
   st_in kobs rt1 rt1' (pc,r1) (pc,r1') ->

    forall j, reg pc j -> ~ L.leql (se j) kobs.
Proof.
  intros sgn pc pc2 pc2' i r1 rt1 r1' rt1' r2 r2' rt2 rt2' Hins Hstep Hstep' Hpc Hst_in j Hreg.
  destruct i; simpl in Hins, Hstep, Hstep', Hst_in;
  inversion_clear Hstep in Hins Hstep' Hpc Hst_in;
  inversion_clear Hstep' in Hpc Hst_in; subst;
  apply inv_st_in in Hst_in;
  DiscrimateEq; try (elim Hpc; reflexivity); try (contradiction).
  (* PackedSwitch *)
  inversion Hst_in as [Heqset Hreg_in].
    soap2_intra_normal_aux Hreg_in H4 Hreg rt (se j) H0 Hvalue_opt_in k1 k1'.
    (* both are low *)
    rewrite <- H in Hvalue_opt_in; rewrite <- H5 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst.
    assert (n = n0) by omega; subst.
    rewrite H3 in H9. inversion H9; subst; apply False_ind; auto.
  inversion Hst_in as [Heqset Hreg_in].
    soap2_intra_normal_aux Hreg_in H4 Hreg rt (se j) H0 Hvalue_opt_in k1 k1'.
    (* both are low *)
    rewrite <- H in Hvalue_opt_in; rewrite <- H6 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst. apply False_ind; omega.
  inversion Hst_in as [Heqset Hreg_in].
    soap2_intra_normal_aux Hreg_in H3 Hreg rt (se j) H1 Hvalue_opt_in k1 k1'.
    (* both are low *)
    rewrite <- H0 in Hvalue_opt_in; rewrite <- H4 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst. apply False_ind; omega.
  (* SparseSwitch *)
  inversion Hst_in as [Heqset Hreg_in].
    soap2_intra_normal_aux Hreg_in H2 Hreg rt (se j) H0 Hvalue_opt_in k1 k1'.
    (* both are low *)
    rewrite <- H in Hvalue_opt_in; rewrite <- H3 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst.
      unfold well_formed_lookupswitch in lookupswitch_hyp.
      specialize lookupswitch_hyp with (pc:=pc) (reg:=rt) (l:=l) (size:=size) (i:=Int.toZ i0) (1:=Hins) (2:=H1) (3:=H5).
      subst. apply False_ind; auto.
  inversion Hst_in as [Heqset Hreg_in].
    soap2_intra_normal_aux Hreg_in H2 Hreg rt (se j) H0 Hvalue_opt_in k1 k1'.
    (* both are low *)
    rewrite <- H in Hvalue_opt_in; rewrite <- H4 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst.
      specialize H6 with (i':=Int.toZ i0) (o':=o) (1:=H1).
      apply False_ind; auto.
  inversion Hst_in as [Heqset Hreg_in].
    soap2_intra_normal_aux Hreg_in H3 Hreg rt (se j) H1 Hvalue_opt_in k1 k1'.
    (* both are low *)
    rewrite <- H0 in Hvalue_opt_in; rewrite <- H4 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst.
      specialize H2 with (i':=Int.toZ i0) (o':=o) (1:=H6).
      apply False_ind; omega.
  (* If_icmp *)
  inversion Hst_in as [Heqset Hreg_in].
    (* ra *)
    assert (Hreg_in':=Hreg_in).
    soap2_intra_normal_aux Hreg_in H8 Hreg ra (se j) H5 Hvalue_opt_in k k'.
    (* rb *)
    soap2_intra_normal_aux Hreg_in' H8 Hreg rb (se j) H6 Hvalue_opt_in' k k'.
    (* both are low *)
    rewrite <- H3 in Hvalue_opt_in; rewrite <- H4 in Hvalue_opt_in';
    rewrite <- H14 in Hvalue_opt_in; rewrite <- H15 in Hvalue_opt_in'.
    inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
    inversion Hvalue_opt_in' as [v2 v2' Hvalue_in' | Hnone'];
    inversion Hvalue_in; inversion Hvalue_in'.
    subst; contradiction.
  inversion Hst_in as [Heqset Hreg_in].
    (* ra *)
    assert (Hreg_in':=Hreg_in).
    soap2_intra_normal_aux Hreg_in H9 Hreg ra (se j) H6 Hvalue_opt_in k k'.
    (* rb *)
    soap2_intra_normal_aux Hreg_in' H9 Hreg rb (se j) H7 Hvalue_opt_in' k k'.
    (* both are low *)
    rewrite <- H4 in Hvalue_opt_in; rewrite <- H5 in Hvalue_opt_in';
    rewrite <- H14 in Hvalue_opt_in; rewrite <- H15 in Hvalue_opt_in'.
    inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
    inversion Hvalue_opt_in' as [v2 v2' Hvalue_in' | Hnone'];
    inversion Hvalue_in; inversion Hvalue_in'.
    subst; contradiction.
  (* If_z *)
  inversion Hst_in as [Heq_set Hreg_in].
    soap2_intra_normal_aux Hreg_in H4 Hreg r (se j) H2 Hvalue_opt_in k1 k1'.
    rewrite <- H1 in Hvalue_opt_in; rewrite <- H8 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst; contradiction.
  inversion Hst_in as [Heq_set Hreg_in].
    soap2_intra_normal_aux Hreg_in H5 Hreg r (se j) H3 Hvalue_opt_in k1 k1'.
    rewrite <- H2 in Hvalue_opt_in; rewrite <- H8 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst; contradiction.
Qed.

End p.


Require Import Util IL Even DecSolve Indexwise MoreList NoParams VarP.

Definition isReg x := Even.even_pos_fast x.

Definition regbnd k (x:positive) := isReg x -> (x <= k)%positive.

Instance regbnd_computable k x : Computable (regbnd x k).
Proof.
  unfold regbnd. eauto with typeclass_instances.
Qed.

Inductive simplOp : op -> Prop :=
| SCon v : simplOp (Con v)
| SVar x : simplOp (Var x)
| SNot x (RGa:isReg x) :  simplOp (UnOp UnOpNot (Var x))
| SNeg x (RGa:isReg x) :  simplOp (UnOp UnOpNeg (Var x))
| SBinOp bop x y (RGa:isReg x) (RGb:isReg y) : simplOp (BinOp bop (Var x) (Var y))
| SBinOpV1 bop x y (RGa:isReg x) (notDiv:bop <> BinOpDiv) : simplOp (BinOp bop (Var x) (Con y))
| SBinOpV2 bop x y (RGb:isReg y) (notDiv:bop <> BinOpDiv) : simplOp (BinOp bop (Con x) (Var y))
.

Instance simplOp_computable o : Computable (simplOp o).
Proof.
  destruct o; try dec_solve.
  destruct u, o; try dec_solve; decide (isReg p); dec_solve.
  destruct o1, o2; try dec_solve;
    try decide (isReg p); try decide (isReg p0); try dec_solve;
      decide (b = BinOpDiv); try dec_solve.
Qed.

Definition simplExp e := match e with
                        | Operation e' => simplOp e'
                        | _ => False
                        end.

Instance simplExp_computable e : Computable (simplExp e).
Proof.
  destruct e; simpl; eauto with typeclass_instances.
Qed.

Inductive simplLet x : op -> Prop :=
| SimpleOp e (RG:isReg x) (SO:simplOp e) : simplLet x e
| SimpleStore y (RG: isReg y) (MM:~isReg x) : simplLet x (Var y).

Instance simplLet_computable x o : Computable (simplLet x o).
Proof.
  decide (isReg x).
  - decide (simplOp o); dec_solve.
  - destruct o; try dec_solve.
    decide (isReg p); dec_solve.
Qed.

Definition isComparision (bop:binop) :=
  match bop with
  | BinOpLt => true
  | BinOpEq => true
  | BinOpGe => true
  | BinOpGt => true
  | _ => false
  end.

Inductive simplCond : op -> Prop :=
| SimplCondVar x (RG:isReg x)
  : simplCond (Var x)
| SimplCondLt x y (RG1:isReg x) (RG2:isReg y) op
              (OP:isComparision op)
  : simplCond (BinOp op (Var x) (Var y))
| SimplCondLt1 x y (RG1:isReg x) op
               (OP:isComparision op)
  : simplCond (BinOp op (Var x) (Con y))
| SimplCondLt2 x y (RG2:isReg y) op
               (OP:isComparision op)
  : simplCond (BinOp op (Con x) (Var y)).

Instance simplCond_computable o : Computable (simplCond o).
Proof.
  destruct o; try dec_solve.
  - decide (isReg p); dec_solve.
  - decide (isComparision b); try dec_solve.
    destruct o1, o2; try decide (isReg p); try decide (isReg p0); try dec_solve.
Qed.

Inductive isLinearizable : stmt->Prop :=
| IsLinLet x e s
    (LinIH:isLinearizable s)
    (SimplLet:simplLet x e)
    : isLinearizable (stmtLet x (Operation e) s)
| IsLinIf e s t
          (SimplCond:simplCond e)
          (LinIH1:isLinearizable s)
          (LinIH2:isLinearizable t)
  : isLinearizable (stmtIf e s t)
| IsLinApp l Y :
   isLinearizable (stmtApp l Y)
| IsLinExp e
           (SimplReg:simplOp e)
  : isLinearizable (stmtReturn e)
| IsLinCall F t
  : (forall n Zs, get F n Zs -> isLinearizable (snd Zs))
    -> isLinearizable t
    -> isLinearizable (stmtFun F t).

Instance isLinearizable_computable s : Computable (isLinearizable s).
Proof.
  sind s; destruct s.
  - destruct e; try dec_solve.
    decide (simplLet x e); try dec_solve.
    destruct (IH s); try dec_solve.
  - decide (simplCond e); try dec_solve.
    destruct (IH s1); eauto; try dec_solve;
      destruct (IH s2); eauto; try dec_solve.
  - left; eauto using isLinearizable.
  - decide (simplOp e); try dec_solve.
  - destruct (IH s); eauto; try dec_solve.
    assert (Computable (forall n Zs, get F n Zs -> isLinearizable (snd Zs))). {
      eapply indexwise_P_dec. intros. eapply IH; eauto.
    }
    destruct H; dec_solve.
Qed.

Definition isLinearizableStmt s := B[isLinearizable s].

Require Import Status.

Definition toLinearPreconditions k s : status unit :=
  if [noParams s] then
    if [isLinearizable s] then
      if [ var_P (regbnd k) s ] then
        Success tt
      else
        Error "Register bound not OK"
    else
      Error "Program is not linearizable"
  else
    Error "There are parameters left in the program".


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import VST.msl.base.
Require Import VST.msl.sepalg.
Require Import VST.msl.psepalg.
Require Import VST.msl.eq_dec.
Require Import VST.msl.shares.

(** The prototypical example of a psepalg is the positive shares, which
    are just the lifted basic shares. *)
Definition pshare : Type := lifted Share.Join_ba.
#[global] Instance Join_pshare: Join pshare := @Join_lift _ _.
#[global] Instance Perm_pshare : Perm_alg pshare := Perm_lift Share.pa.
#[global] Instance Canc_pshare : Canc_alg pshare := @Canc_lift _ _ Share.ca.
#[global] Instance Disj_pshare : Disj_alg pshare := @Disj_lift _ _ Share.da.
#[global] Instance Pos_pshare : Pos_alg pshare := @Pos_lift _ _.

Definition pshare_sh : pshare -> share := @lifted_obj share Share.Join_ba.
Coercion pshare_sh : pshare >-> share.

Lemma pshare_eq_dec: forall sh1 sh2: pshare, {sh1=sh2}+{sh1<>sh2}.
Proof.
  intros.
  destruct sh1; destruct sh2.
  destruct (eq_dec x x0); [left|right].
  subst x0.
  rewrite (proof_irr n n0); auto.
  intro.
  inv H.
  contradiction n1; auto.
Qed.

#[global] Instance EqDec_pshare : EqDec pshare := pshare_eq_dec.

Definition pfullshare : pshare :=
  mk_lifted fullshare top_share_nonunit.

Lemma pfullshare_pfull : full pfullshare.
Proof with auto.
  unfold pshare.
  apply lifted_full. auto with typeclass_instances.
  apply fullshare_full.
Qed.

Lemma join_sub_pfullshare: forall (p: pshare),
  @join_sub share Share.Join_ba pfullshare p ->
  p = pfullshare.
Proof.
  intros. apply join_sub_fullshare in H. apply lifted_eq. trivial.
Qed.

Lemma pjoin_sub_pfullshare: forall (p : pshare),
  join_sub pfullshare p -> False.
Proof.
  intros.
  generalize pfullshare_pfull; intro.
  rewrite pfull_pmaximal in H0.
  generalize (H0 _ H); intro.
  destruct H. subst p.
  apply join_comm in H.
  contradiction (no_units x pfullshare).
Qed.

Lemma pshare_join_full_false1 : forall (p:pshare),
   joins pfullshare p -> False.
Proof.
  intros.
  destruct H. inv H. simpl in *. unfold fullshare in H0.
  rewrite Share.glb_commute in H0. rewrite Share.glb_top in H0.
  destruct p; simpl in *. subst. contradiction (n Share.bot). auto.
Qed.

Lemma pshare_join_full_false2 : forall (p:pshare),
   joins p pfullshare -> False.
Proof.
  intros. apply joins_comm in H. apply pshare_join_full_false1 with p; auto.
Qed.

Lemma pshare_join_full_false3: forall (p1: pshare) sh3,
  join (lifted_obj p1) Share.top sh3 -> False.
Proof.
  intros.
  destruct p1. unfold lifted_obj, pfullshare, mk_lifted, proj1_sig in H.
  destruct H. rewrite Share.glb_top in H. subst. contradiction (n Share.bot); auto.
Qed.

Lemma pshare_join_full_false4: forall (p1: pshare) sh3,
  join Share.top (lifted_obj p1) sh3 -> False.
Proof.
  intros.
  eapply pshare_join_full_false3. apply join_comm in H. eauto.
Qed.

Lemma pshare_pjoin_full_false3: forall (p1: pshare) pp sh3,
   join p1 (mk_lifted Share.top pp) sh3 -> False.
Proof.
  intros. destruct sh3.
  do 2 red in H. simpl lifted_obj in *.
 apply pshare_join_full_false3 in H. trivial.
Qed.

Lemma pshare_pjoin_full_false4: forall (p1: pshare) pp sh3,
   join (mk_lifted Share.top pp) p1 sh3 -> False.
Proof.
  intros. destruct sh3.
  do 2 red in H. simpl lifted_obj in *.
  apply pshare_join_full_false4 in H. trivial.
Qed.

Ltac pfullshare_join :=
  exfalso;
  solve [ eapply pshare_join_full_false1; eauto
    | eapply pshare_join_full_false2; eauto
    | eapply pshare_join_full_false3; eauto
    | eapply pshare_join_full_false4; eauto
    | eapply pshare_pjoin_full_false3; eauto
    | eapply pshare_pjoin_full_false4; eauto
  ].

Program Definition split_pshare (sh: pshare) : pshare * pshare :=
  (mk_lifted (fst (Share.split sh)) _, mk_lifted (snd (Share.split sh)) _).
Next Obligation.
Proof.
  intros.
  case_eq (Share.split (proj1_sig sh)); simpl.
  intros.
  generalize (split_nontrivial' _ _ _ H); intro.
  intros ? ?. apply unit_identity in H1. destruct sh; simpl in H0.
  assert (identity x0) by auto. contradiction (n x0).
  apply identity_unit_equiv in H2; auto.
Qed.
Next Obligation.
Proof.
  intros.
  case_eq (Share.split (proj1_sig sh)); simpl.
  intros.
  generalize (split_nontrivial' _ _ _ H); intro.
  intros ? ?. apply unit_identity in H1. destruct sh; simpl in H0.
  assert (identity x0) by auto. contradiction (n x0).
  apply identity_unit_equiv in H2; auto.
Qed.

Lemma psplit_split: forall psh psha pshb,
  (split_pshare psh = (psha, pshb)) =
  (Share.split (lifted_obj psh) = (lifted_obj psha, lifted_obj pshb)).
Proof.
  unfold split_pshare, lifted_obj.
  intros. apply prop_ext. split; intro.
  inversion H.
  apply injective_projections; auto.
  apply injective_projections; apply lifted_eq; simpl; rewrite H; auto.
Qed.

Lemma psplit_pjoin: forall psh psha pshb,
  split_pshare psh = (psha, pshb) ->
   join psha pshb psh.
Proof.
  intros.
  rewrite psplit_split in H.
  apply split_join in H.
  trivial.
Qed.

Lemma pshare_split_neq1: forall psh psh1 psh2, split_pshare psh = (psh1, psh2) -> psh1 <> psh.
Proof.
  intros.
  apply psplit_pjoin in H.
  intro contra. subst psh1.
  apply  join_comm in H.
  apply pjoin_unit in H. trivial.
Qed.

Lemma pshare_split_neq2: forall psh psh1 psh2, split_pshare psh = (psh1, psh2) -> psh2 <> psh.
Proof.
  intros.
  apply psplit_pjoin in H.
  intro contra. subst psh2.
  apply pjoin_unit in H. trivial.
Qed.

Definition pLhalf : pshare := fst (split_pshare pfullshare).
Definition pRhalf : pshare := snd (split_pshare pfullshare).

Lemma pleftright :  join pLhalf pRhalf pfullshare.
Proof.
  apply psplit_pjoin.
  trivial.
Qed.

Lemma pshare_nonunit: forall sh: pshare, nonunit (pshare_sh sh).
Proof. repeat intro. destruct sh; simpl in *. apply n in H. auto.
Qed.

Lemma pshare_not_identity: forall sh: pshare, ~ identity (pshare_sh sh).
Proof. intros. apply nonunit_nonidentity. apply pshare_nonunit.
Qed.