(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This file describes a subset of the C type system. This subset includes
pointer, array, struct, and union types, but omits qualifiers as volatile and
const. Also variable length arrays are omitted from the formalization. *)
From stdpp Require Import fin_maps stringmap mapset.
From Coq Require Import String.
Require Import prelude stringmap.
Require Export type_classes integer_coding.

(** * Tags *)
(** We consider an (unordered) environment to maps tags (struct and union
names) to lists of types corresponding to the fields of structs and unions.
We use the same namespace for structs and unions. *)
Definition tag := string.
Definition tagmap := stringmap.
Notation tagset := (mapset tagmap).

#[global] Instance tag_eq_dec: EqDecision tag.
Proof. solve_decision. Defined.
#[global] Instance tagmap_dec `{EqDecision A}: EqDecision (tagmap A).
Proof. solve_decision. Defined.
#[global] Instance tagmap_empty {A} : Empty (tagmap A) := @empty (stringmap A) _.
#[global] Instance tagmap_lookup {A} : Lookup tag A (tagmap A) :=
  @lookup _ _ (stringmap A) _.
#[global] Instance tagmap_partial_alter {A} : PartialAlter tag A (tagmap A) :=
  @partial_alter _ _ (stringmap A) _.
#[global] Instance tagmap_to_list {A} : FinMapToList tag A (tagmap A) :=
  @map_to_list _ _ (tagmap A) _.
#[global] Instance tagmap_omap: OMap tagmap := @omap stringmap _.
#[global] Instance tagmap_merge : Merge tagmap := @merge stringmap _.
#[global] Instance tagmap_fmap: FMap tagmap := @fmap stringmap _.
#[global] Instance: FinMap tag tagmap := _.
#[global] Instance tagmap_dom {A} : Dom (tagmap A) tagset := mapset_dom.
#[global] Instance: FinMapDom tag tagmap tagset := mapset_dom_spec.

Typeclasses Opaque tag tagmap.

(** * Function names *)
(** Function names have a separate namespace from structs/unions. *)
Definition funname := string.
Definition funmap := stringmap.
Notation funset := (mapset funmap).

#[global] Instance funname_eq_dec: EqDecision funname.
Proof. solve_decision. Defined.
#[global] Instance funmap_dec {A} `{EqDecision A}: EqDecision (funmap A).
Proof. solve_decision. Defined.
#[global] Instance funmap_empty {A} : Empty (funmap A) := @empty (stringmap A) _.
#[global] Instance funmap_lookup {A} : Lookup funname A (funmap A) :=
  @lookup _ _ (stringmap A) _.
#[global] Instance funmap_partial_alter {A} : PartialAlter funname A (funmap A) :=
  @partial_alter _ _ (stringmap A) _.
#[global] Instance funmap_to_list {A} : FinMapToList funname A (funmap A) :=
  @map_to_list _ _ (funmap A) _.
#[global] Instance funmap_omap: OMap funmap := @omap stringmap _.
#[global] Instance funmap_merge : Merge funmap := @merge stringmap _.
#[global] Instance funmap_fmap: FMap funmap := @fmap stringmap _.
#[global] Instance: FinMap funname funmap := _.
#[global] Instance funmap_dom {A} : Dom (funmap A) funset := mapset_dom.
#[global] Instance: FinMapDom funname funmap funset := mapset_dom_spec.

Typeclasses Opaque funname funmap.

(** * Types *)
(** Types are defined mutually inductively. The type [type] represents the
types of full C types (arrays, structs, unions), and [base_type] describes the
types of values that can occur at the leafs of a full value (integers,
pointers). Structs and unions include a name that refers to their fields in the
environment. *)
Inductive compound_kind := Struct_kind | Union_kind.

Inductive type (K : iType) : iType :=
  | TBase :> base_type K → type K
  | TArray : type K → nat → type K
  | TCompound : compound_kind → tag → type K
with ptr_type (K : iType) : iType :=
  | TType : type K → ptr_type K
  | TAny : ptr_type K
  | TFun : list (type K) → type K → ptr_type K
with base_type (K : iType) : iType :=
  | TVoid : base_type K
  | TInt : int_type K → base_type K
  | TPtr : ptr_type K → base_type K.

Declare Scope ctype_scope.
Declare Scope cptr_type_scope.
Declare Scope cbase_type_scope.
Delimit Scope ctype_scope with T.
Delimit Scope cptr_type_scope with PT.
Delimit Scope cbase_type_scope with BT.
Bind Scope ctype_scope with type.
Bind Scope cptr_type_scope with ptr_type.
Bind Scope cbase_type_scope with base_type.
Local Open Scope ctype_scope.

Arguments TBase {_} _%BT.
Arguments TArray {_} _ _.
Arguments TCompound {_} _ _%string.
Arguments TType {_} _%T.
Arguments TAny {_}.
Arguments TFun {_} _%T _%T.
Arguments TVoid {_}.
Arguments TInt {_} _%IT.
Arguments TPtr {_} _%PT.

Notation "'baseT' τ" := (TBase τ) (at level 10) : ctype_scope.
Notation "'baseT' τ" := (TType (TBase τ)) (at level 10) : cptr_type_scope.
Notation "τ .[ n ]" := (TArray τ n)
  (at level 25, left associativity, format "τ .[ n ]") : ctype_scope.
Notation "τ .[ n ]" := (TType (TArray τ n))
  (at level 25, left associativity, format "τ .[ n ]") : cptr_type_scope.
Notation "'compoundT{' c } s" := (TCompound c s)
  (at level 10, format "'compoundT{' c }  s") : ctype_scope.
Notation "'compoundT{' c } s" := (TType (TCompound c s))
  (at level 10, format "'compoundT{' c }  s") : cptr_type_scope.
Notation "'structT' s" := (TCompound Struct_kind s) (at level 10) : ctype_scope.
Notation "'structT' s" := (TType (TCompound Struct_kind s))
  (at level 10) : cptr_type_scope.
Notation "'unionT' s" := (TCompound Union_kind s) (at level 10) : ctype_scope.
Notation "'unionT' s" := (TType (TCompound Union_kind s))
  (at level 10) : cptr_type_scope.
Notation "'voidT'" := TVoid : cbase_type_scope.
Notation "'voidT'" := (TBase TVoid) : ctype_scope.
Notation "'intT' τ" := (TInt τ) (at level 10) : cbase_type_scope.
Notation "'intT' τ" := (TBase (TInt τ)) (at level 10) : ctype_scope.
Notation "'intT' τ" := (TType (TBase (TInt τ))) (at level 10) : cptr_type_scope.
Notation "'charT{' K }" := (TInt (charT{K})) : cbase_type_scope.
Notation "'charT'" := (TInt charT) : cbase_type_scope.
Notation "'charT{' K }" := (TBase (charT{K})) : ctype_scope.
Notation "'charT'" := (TBase charT) : ctype_scope.
Notation "'charT{' K }" := (TType (charT{K})) : cptr_type_scope.
Notation "'charT'" := (TType charT) : cptr_type_scope.
Notation "'ucharT'" := (TInt ucharT) : cbase_type_scope.
Notation "'ucharT'" := (TBase ucharT) : ctype_scope.
Notation "'ucharT'" := (TType (TBase ucharT)) : cptr_type_scope.
Notation "'scharT'" := (TInt scharT) : cbase_type_scope.
Notation "'scharT'" := (TBase scharT) : ctype_scope.
Notation "'scharT'" := (TType (TBase scharT)) : cptr_type_scope.
Notation "'uintT'" := (TInt uintT) : cbase_type_scope.
Notation "'uintT'" := (TBase uintT) : ctype_scope.
Notation "'uintT'" := (TType (TBase uintT)) : cptr_type_scope.
Notation "'sintT'" := (TInt sintT) : cbase_type_scope.
Notation "'sintT'" := (TBase sintT) : ctype_scope.
Notation "'sintT'" := (TType (TBase sintT)) : cptr_type_scope.
Notation "'uptrT'" := (TInt uptrT) : cbase_type_scope.
Notation "'uptrT'" := (TBase uptrT) : ctype_scope.
Notation "'uptrT'" := (TType (TBase uptrT)) : cptr_type_scope.
Notation "'sptrT'" := (TInt sptrT) : cbase_type_scope.
Notation "'sptrT'" := (TBase sptrT) : ctype_scope.
Notation "'sptrT'" := (TType (TBase sptrT)) : cptr_type_scope.
Notation "τp .*" := (TPtr τp) (at level 25, format "τp .*") : cbase_type_scope.
Notation "τp .*" := (TBase (τp.*)) (at level 25, format "τp .*") : ctype_scope.
Notation "τp .*" := (TType (TBase (τp.*)))
  (at level 25, format "τp .*") : cptr_type_scope.
Notation "τs ~> τ" := (TFun τs τ) (at level 40) : ctype_scope.

#[global] Instance compound_kind_eq_dec: EqDecision compound_kind.
Proof. solve_decision. Defined.
Section dec.
Context `{EqDecision K}.
Fixpoint type_eq_dec' (τ1 τ2 : type K) : Decision (τ1 = τ2)
with ptr_type_eq_dec' (τp1 τp2 : ptr_type K) : Decision (τp1 = τp2)
with base_type_eq_dec' (τb1 τb2 : base_type K) : Decision (τb1 = τb2).
Proof.
 refine
  match τ1, τ2 with
  | baseT τb1, baseT τb2 => cast_if (decide (τb1 = τb2))
  | τ1.[n1], τ2.[n2] =>
     cast_if_and (decide (n1 = n2)) (decide (τ1 = τ2))
  | compoundT{c1} s1, compoundT{c2} s2 =>
     cast_if_and (decide (c1 = c2)) (decide (s1 = s2))
  | _, _ => right _
  end; try solve_decision; abstract congruence.
 refine
  match τp1, τp2 with
  | TType τ1, TType τ2 => cast_if (decide (τ1 = τ2))
  | TAny, TAny => left _
  | τs1 ~> τ1, τs2 ~> τ2 =>
     cast_if_and (decide (τ1 = τ2)) (decide (τs1 = τs2))
  | _, _ => right _
  end; try solve_decision; abstract congruence.
 refine
  match τb1, τb2 with
  | voidT, voidT => left _
  | intT τi1, intT τi2 => cast_if (decide (τi1 = τi2))
  | τp1.*, τp2.* => cast_if (decide (τp1 = τp2))
  | _, _ => right _
  end%BT; try solve_decision; abstract congruence.
Defined.
#[global] Instance type_eq_dec: EqDecision (type K) := type_eq_dec'.
#[global] Instance ptr_type_eq_dec: EqDecision (ptr_type K) := ptr_type_eq_dec'.
#[global] Instance base_type_eq_dec: EqDecision (base_type K) := base_type_eq_dec'.
End dec.

#[global] Instance maybe_TInt {K} : Maybe (@TInt K) := λ τb,
  match τb with intT τi => Some τi | _ => None end%BT.
#[global] Instance maybe_TPtr {K} : Maybe (@TPtr K) := λ τb,
  match τb with τp.* => Some τp | _ => None end%BT.
#[global] Instance maybe_TBase {K} : Maybe (@TBase K) := λ τ,
  match τ with baseT τb => Some τb | _ => None end.
#[global] Instance maybe_TArray {K} : Maybe2 (@TArray K) := λ τ,
  match τ with τ.[n] => Some (τ,n) | _ => None end.
#[global] Instance maybe_TCompound {K} : Maybe2 (@TCompound K) := λ τ,
  match τ with compoundT{c} t => Some (c,t) | _ => None end.
#[global] Instance maybe_TType {K} : Maybe (@TType K) := λ τ,
  match τ with TType τ => Some τ | _ => None end.
#[global] Instance maybe_TFun {K} : Maybe2 (@TFun K) := λ τ,
  match τ with τs ~> τ => Some (τs,τ) | _ => None end.

(** * Environments *)
Record env (K : iType) : iType := mk_env {
  env_t : tagmap (list (type K));
  env_f : funmap (list (type K) * type K)
}.
Add Printing Constructor env.
Arguments mk_env {_} _ _.
Arguments env_t {_} _.
Arguments env_f {_} _.

#[global] Instance env_subseteq {K} : SubsetEq (env K) := λ Γ1 Γ2,
  env_t Γ1 ⊆ env_t Γ2 ∧ env_f Γ1 ⊆ env_f Γ2.
#[global] Instance env_empty {K} : Empty (env K) := mk_env ∅ ∅.
#[global] Instance env_lookup_compound {K} :
  Lookup tag (list (type K)) (env K) := λ t Γ, env_t Γ !! t.
#[global] Instance env_lookup_fun {K} :
  Lookup funname (list (type K) * type K) (env K) := λ f Γ, env_f Γ !! f.
#[global] Instance env_insert_compound {K} :
    Insert tag (list (type K)) (env K) := λ t τs Γ,
  mk_env (<[t:=τs]>(env_t Γ)) (env_f Γ).
#[global] Instance env_insert_fun {K} :
    Insert funname (list (type K) * type K) (env K) := λ f τsτ Γ,
  mk_env (env_t Γ) (<[f:=τsτ]>(env_f Γ)).
#[global] Instance env_delete_compound {K} :
  Delete tag (env K) := λ t Γ, mk_env (delete t (env_t Γ)) (env_f Γ).
#[global] Instance env_delete_fun {K} :
  Delete funname (env K) := λ f Γ, mk_env (env_t Γ) (delete f (env_f Γ)).

(** * Well-formed types *)
(** Not all pseudo-types are valid C types; in particular circular unions and
structs (like [struct t { struct t x; }]) are not excluded. The predicate
[type_valid Γ] describes that a type is valid with respect to [Γ]. That means,
recursive occurrences of unions and structs are always guarded by a pointer.
The predicate [env_valid] describes that an environment is valid. *)
Section types.
  Context {K : iType} `{EqDecision K}.
  Implicit Types Γ Σ : env K.
  Implicit Types τ : type K.
  Implicit Types τp : ptr_type K.
  Implicit Types τs : list (type K).
  Implicit Types τps : list (ptr_type K).
  Implicit Types τb : base_type K.
  Implicit Types τi : int_type K.
  Implicit Types t : tag.
  Implicit Types f : funname.

  Inductive type_valid' Γ : type K → Prop :=
    | TBase_valid' τb : base_type_valid' Γ τb → type_valid' Γ (baseT τb)
    | TArray_valid' τ n : type_valid' Γ τ → n ≠ 0 → type_valid' Γ (τ.[n])
    | TCompound_valid' c t : is_Some (Γ !! t) → type_valid' Γ (compoundT{c} t)
  with ptr_type_valid' Γ : ptr_type K → Prop :=
    | TAny_ptr_valid' : ptr_type_valid' Γ TAny
    | TBase_ptr_valid' τb :
       base_type_valid' Γ τb → ptr_type_valid' Γ (baseT τb)
    | TArray_ptr_valid' τ n :
       type_valid' Γ τ → n ≠ 0 → ptr_type_valid' Γ (τ.[n])
    | TCompound_ptr_valid' c t : ptr_type_valid' Γ (compoundT{c} t)
    | TFun_ptr_valid' τs τ :
       Forall (ptr_type_valid' Γ) (TType <$> τs) → ptr_type_valid' Γ (TType τ) →
       ptr_type_valid' Γ (τs ~> τ)
  with base_type_valid' Γ : base_type K → Prop :=
    | TVoid_valid' : base_type_valid' Γ voidT
    | TInt_valid' τi : base_type_valid' Γ (intT τi)
    | TPtr_valid' τp : ptr_type_valid' Γ τp → base_type_valid' Γ (τp.*).
  Global Instance type_valid : Valid (env K) (type K) := type_valid'.
  Global Instance ptr_type_valid :
    Valid (env K) (ptr_type K) := ptr_type_valid'.
  Global Instance base_type_valid :
    Valid (env K) (base_type K) := base_type_valid'.

  Lemma TBase_valid Γ τb : ✓{Γ} τb → ✓{Γ} (baseT τb).
  Proof. by constructor. Qed.
  Lemma TArray_valid Γ τ n : ✓{Γ} τ → n ≠ 0 → ✓{Γ} (τ.[n]).
  Proof. by constructor. Qed.
  Lemma TCompound_valid Γ c t : is_Some (Γ !! t) → ✓{Γ} (compoundT{c} t).
  Proof. by constructor. Qed.

  Lemma TAny_ptr_valid Γ : ✓{Γ} TAny.
  Proof. constructor. Qed.
  Lemma TBase_ptr_valid Γ τb : ✓{Γ} τb → ✓{Γ} (baseT τb)%PT.
  Proof. by constructor. Qed.
  Lemma TArray_ptr_valid Γ τ n : ✓{Γ} τ → n ≠ 0 → ✓{Γ} (τ.[n])%PT.
  Proof. by constructor. Qed.
  Lemma TCompound_ptr_valid Γ c t : ✓{Γ} (compoundT{c} t)%PT.
  Proof. by constructor. Qed.
  Lemma TFun_ptr_valid Γ τs τ :
    ✓{Γ}* (TType <$> τs) → ✓{Γ} (TType τ) → ✓{Γ} (τs ~> τ).
  Proof. by constructor. Qed.

  Lemma TVoid_valid Γ : ✓{Γ} voidT%BT.
  Proof. by constructor. Qed.
  Lemma TInt_valid Γ τi : ✓{Γ} (intT τi)%BT.
  Proof. by constructor. Qed.
  Lemma TPtr_valid Γ τp : ✓{Γ} τp → ✓{Γ} (τp.*)%BT.
  Proof. by constructor. Qed.

  Lemma TBase_valid_inv Γ τb : ✓{Γ} (baseT τb) → ✓{Γ} τb.
  Proof. by inversion_clear 1. Qed.
  Lemma TArray_valid_inv Γ τ n : ✓{Γ} (τ.[n]) → ✓{Γ} τ ∧ n ≠ 0.
  Proof. by inversion_clear 1. Qed.
  Lemma TArray_valid_inv_type Γ τ n : ✓{Γ} (τ.[n]) → ✓{Γ} τ.
  Proof. by inversion_clear 1. Qed.
  Lemma TArray_valid_inv_size Γ τ n : ✓{Γ} (τ.[n]) → n ≠ 0.
  Proof. by inversion_clear 1. Qed.
  Lemma TArray_ptr_valid_inv_size Γ τ n : ✓{Γ} (TType (τ.[n])) → n ≠ 0.
  Proof. by inversion_clear 1. Qed.
  Lemma TCompound_valid_inv Γ c t : ✓{Γ} (compoundT{c} t) → is_Some (Γ !! t).
  Proof. by inversion_clear 1. Qed.
  Lemma TBase_ptr_valid_inv Γ τb : ✓{Γ} (baseT τb)%PT → ✓{Γ} τb.
  Proof. by inversion_clear 1. Qed.
  Lemma TArray_ptr_valid_inv_type Γ τ n : ✓{Γ} (τ.[n])%PT → ✓{Γ} τ.
  Proof. by inversion_clear 1. Qed.
  Lemma TFun_valid_inv Γ τs τ :
    ✓{Γ} (τs ~> τ) → ✓{Γ}* (TType <$> τs) ∧ ✓{Γ} (TType τ).
  Proof. by inversion 1. Qed.
  Lemma TFun_valid_inv_args Γ τs τ : ✓{Γ} (τs ~> τ) → ✓{Γ}* (TType <$> τs).
  Proof. by inversion 1. Qed.
  Lemma TFun_valid_inv_ret Γ τs τ : ✓{Γ} (τs ~> τ) → ✓{Γ} (TType τ).
  Proof. by inversion 1. Qed.
  Lemma TPtr_valid_inv Γ τp : ✓{Γ} (τp.*)%BT → ✓{Γ} τp.
  Proof. by inversion_clear 1. Qed.

  Fixpoint type_valid_dec Γ τ : Decision (✓{Γ} τ)
  with ptr_type_valid_dec Γ τp : Decision (✓{Γ} τp)
  with ptr_type_valid_dec_aux Γ τ : Decision (✓{Γ} (TType τ))
  with base_type_valid_dec Γ τb : Decision (✓{Γ} τb).
  Proof.
   refine
    match τ with
    | baseT τb => cast_if (decide (✓{Γ} τb))
    | τ.[n] => cast_if_and (decide (n ≠ 0)) (decide (✓{Γ} τ))
    | compoundT{c} t => cast_if (decide (is_Some (Γ !! t)))
    end; clear type_valid_dec ptr_type_valid_dec ptr_type_valid_dec_aux
      base_type_valid_dec; abstract first [by constructor | by inversion 1].
   refine
    match τp with
    | TAny => left _
    | TType τ => cast_if (decide (✓{Γ} (TType τ)))
    | τs ~> τ => cast_if_and
       (decide (Forall (ptr_type_valid Γ ∘ TType) τs)) (decide (✓{Γ} (TType τ)))
    end; clear type_valid_dec ptr_type_valid_dec base_type_valid_dec
      ptr_type_valid_dec_aux; abstract (repeat match goal with
        | H : _ |- _ => rewrite <-Forall_fmap in H
        end; first [done|by constructor | by inversion 1]).
   refine
    match τ with
    | baseT τb => cast_if (decide (✓{Γ} τb))
    | τ.[n] => cast_if_and (decide (n ≠ 0)) (decide (✓{Γ} τ))
    | compoundT{_} _ => left _
    end; clear type_valid_dec ptr_type_valid_dec base_type_valid_dec
      ptr_type_valid_dec_aux; abstract first [by constructor | by inversion 1].
   refine
    match τb with
    | τp.* => cast_if (decide (✓{Γ} τp)) | _ => left _
    end%BT; clear type_valid_dec ptr_type_valid_dec base_type_valid_dec
      ptr_type_valid_dec_aux; abstract first [by repeat constructor | by inversion 1].
  Defined.
  #[global] Existing Instance type_valid_dec.
  #[global] Existing Instance base_type_valid_dec.
  #[global] Existing Instance ptr_type_valid_dec.

  Lemma type_valid_inv Γ (P : Prop) τ :
    ✓{Γ} τ →
    match τ with
    | baseT τ => (✓{Γ} τ → P) → P
    | τ.[n] => (✓{Γ} τ → n ≠ 0 → P) → P
    | compoundT{c} t => (is_Some (Γ !! t) → P) → P
    end.
  Proof. destruct 1; eauto. Qed.
  Lemma type_valid_ptr_type_valid Γ τ : ✓{Γ} τ → ✓{Γ} (TType τ).
  Proof. by destruct 1; constructor. Qed.
  Lemma types_valid_ptr_types_valid Γ τs : ✓{Γ}* τs → ✓{Γ}* (TType <$> τs).
  Proof. induction 1; csimpl; eauto using type_valid_ptr_type_valid. Qed.

  Inductive type_complete (Γ : env K) : type K → Prop :=
    | TBase_complete τb : type_complete Γ (baseT τb)
    | TArray_complete τ n : type_complete Γ (τ.[n])
    | TCompound_complete c t :
       is_Some (Γ !! t) → type_complete Γ (compoundT{c} t).
  Global Instance type_complete_dec Γ τ : Decision (type_complete Γ τ).
  Proof.
   refine
    match τ with
    | compoundT{_} t => cast_if (decide (is_Some (Γ !! t))) | _ => left _
    end; abstract first [by constructor|by inversion 1].
  Defined.
  Lemma type_valid_complete Γ τ : ✓{Γ} τ → type_complete Γ τ.
  Proof. by destruct 1; constructor. Qed.
  Lemma type_complete_valid Γ τ : ✓{Γ} (TType τ) → type_complete Γ τ → ✓{Γ} τ.
  Proof. by do 2 inversion 1; constructor. Qed.
  Lemma types_complete_valid Γ τs :
    ✓{Γ}* (TType <$> τs) → Forall (type_complete Γ) τs → ✓{Γ}* τs.
  Proof. induction 2; decompose_Forall; eauto using type_complete_valid. Qed.

  Global Instance: PartialOrder (⊆@{env K}).
  Proof.
    split; [split|].
    * done.
    * intros ??? [??] [??]; split; etransitivity; eauto.
    * by intros [??] [??] [??] [??]; f_equal; eapply map_subseteq_po.
  Qed.
  Lemma env_wf : wf (⊂@{env K}).
  Proof.
    intros [Γc Γf]; revert Γf. induction (map_wf Γc) as [Γc _ IH]; intros Γf.
    induction (map_wf Γf) as [Γf _ IHf]; constructor; intros [Γc' Γf'] HΓ.
    cut (Γc' ⊂ Γc ∨ Γc' = Γc ∧ Γf' ⊂ Γf); [intros [?|[-> ?]]; eauto|].
    destruct HΓ as [[??] HΓ];
      destruct (map_subseteq_inv_L Γc' Γc); simplify_equality'; auto.
    right; repeat split; auto. by contradict HΓ.
  Qed.
  Lemma lookup_compound_weaken Γ1 Γ2 t τs :
    Γ1 !! t = Some τs → Γ1 ⊆ Γ2 → Γ2 !! t = Some τs.
  Proof. by intros ? [??]; apply (lookup_weaken (env_t Γ1)). Qed.
  Lemma lookup_fun_weaken Γ1 Γ2 f τs τ :
    Γ1 !! f = Some (τs,τ) → Γ1 ⊆ Γ2 → Γ2 !! f = Some (τs,τ).
  Proof. by intros ? [??]; apply (lookup_weaken (env_f Γ1)). Qed.
  Lemma lookup_compound_weaken_is_Some Γ1 Γ2 t :
    is_Some (Γ1 !! t) → Γ1 ⊆ Γ2 → is_Some (Γ2 !! t).
  Proof. intros [τs ?] ?; exists τs; eauto using lookup_compound_weaken. Qed.
  Lemma lookup_insert_compound Γ t τs : <[t:=τs]>Γ !! t = Some τs.
  Proof. apply lookup_insert. Qed.
  Lemma lookup_insert_compound_ne Γ t t' τs :
    t ≠ t' → <[t:=τs]>Γ !! t' = Γ !! t'.
  Proof. apply (lookup_insert_ne (env_t Γ)). Qed.
  Lemma lookup_fun_compound Γ f τs τ : <[f:=(τs,τ)]>Γ !! f = Some (τs,τ).
  Proof. apply lookup_insert. Qed.
  Lemma lookup_fun_compound_ne Γ f f' τs τ :
    f ≠ f' → <[f:=(τs,τ)]>Γ !! f' = Γ !! f'.
  Proof. apply (lookup_insert_ne (env_f Γ)). Qed.
  Lemma insert_fun_id Γ f τsτ : Γ !! f = Some τsτ → <[f:=τsτ]>Γ = Γ.
  Proof.
    destruct Γ; intros; unfold insert, env_insert_fun; f_equal'.
    by apply insert_id.
  Qed.
  Lemma delete_compound_subseteq_compat Γ1 Γ2 t :
    Γ1 ⊆ Γ2 → delete t Γ1 ⊆ delete t Γ2.
  Proof. intros []; split. by apply delete_mono. done. Qed.
  Lemma delete_compound_subseteq Γ t : is_Some (Γ !! t) → delete t Γ ⊆ Γ.
  Proof. split. apply delete_subseteq. done. Qed.
  Lemma delete_compound_subset Γ t : is_Some (Γ !! t) → delete t Γ ⊂ Γ.
  Proof.
    split; [by apply delete_compound_subseteq|].
    intros [??]. by destruct (delete_subset (env_t Γ) t).
  Qed.
  Lemma delete_compound_subset_alt Γ t τs : Γ !! t = Some τs → delete t Γ ⊂ Γ.
  Proof. eauto using delete_compound_subset. Qed.
  Lemma insert_compound_subseteq Γ t τs : Γ !! t = None → Γ ⊆ <[t:=τs]> Γ.
  Proof. split. by apply insert_subseteq. done. Qed.
  Lemma insert_fun_subseteq Γ f τs τ : Γ !! f = None → Γ ⊆ <[f:=(τs,τ)]> Γ.
  Proof. split. done. by apply insert_subseteq. Qed.

  Lemma type_valid_weaken_help Γ1 Γ2 τ :
    ✓{Γ1} τ → env_t Γ1 ⊆ env_t Γ2 → ✓{Γ2} τ
  with ptr_type_valid_weaken_help Γ1 Γ2 τp :
    ✓{Γ1} τp → env_t Γ1 ⊆ env_t Γ2 → ✓{Γ2} τp
  with base_type_valid_weaken_help Γ1 Γ2 τb :
    ✓{Γ1} τb → env_t Γ1 ⊆ env_t Γ2 → ✓{Γ2} τb.
  Proof.
    * unfold valid, base_type_valid, type_valid in *.
      destruct 1; constructor; eauto.
      eapply (lookup_weaken_is_Some (env_t _)); eauto.
    * unfold valid, base_type_valid, type_valid, ptr_type_valid in *.
      destruct 1; econstructor; eauto using Forall_impl.
    * unfold valid, base_type_valid, ptr_type_valid, type_valid in *.
      destruct 1; econstructor; eauto.
  Qed.
  Lemma type_valid_weaken Γ1 Γ2 τ : ✓{Γ1} τ → Γ1 ⊆ Γ2 → ✓{Γ2} τ.
  Proof. intros ? [??]; eapply type_valid_weaken_help; eauto. Qed.
  Lemma ptr_type_valid_weaken Γ1 Γ2 τp : ✓{Γ1} τp → Γ1 ⊆ Γ2 → ✓{Γ2} τp.
  Proof. intros ? [??]; eapply ptr_type_valid_weaken_help; eauto. Qed.
  Lemma base_type_valid_weaken Γ1 Γ2 τb : ✓{Γ1} τb → Γ1 ⊆ Γ2 → ✓{Γ2} τb.
  Proof. intros ? [??]; eapply base_type_valid_weaken_help; eauto. Qed.
  Lemma type_valid_strict_weaken Γ Σ τ  : ✓{Γ} τ → Γ ⊂ Σ → ✓{Σ} τ.
  Proof. intros. eapply type_valid_weaken, strict_include; eauto. Qed.
  Lemma types_valid_weaken Γ Σ τs : ✓{Γ}* τs → Γ ⊆ Σ → ✓{Σ}* τs.
  Proof. eauto using Forall_impl, type_valid_weaken. Qed.
  Lemma ptr_types_valid_weaken Γ Σ τps : ✓{Γ}* τps → Γ ⊆ Σ → ✓{Σ}* τps.
  Proof. eauto using Forall_impl, ptr_type_valid_weaken. Qed.
  Lemma types_valid_strict_weaken Γ Σ τs : ✓{Γ}* τs → Γ ⊂ Σ → ✓{Σ}* τs.
  Proof. eauto using Forall_impl, type_valid_strict_weaken. Qed.
  Lemma type_complete_weaken Γ Σ τ : type_complete Γ τ → Γ ⊆ Σ → type_complete Σ τ.
  Proof.
    intros [] [??]; constructor; eauto.
    eapply (lookup_weaken_is_Some (env_t _)); eauto.
  Qed.
  Lemma types_complete_weaken Γ Σ τs :
    Forall (type_complete Γ) τs → Γ ⊆ Σ → Forall (type_complete Σ) τs.
  Proof. induction 1; eauto using type_complete_weaken. Qed.

  Inductive env_valid : Valid () (env K) :=
    | env_empty_valid : ✓ ∅
    | env_insert_compound_valid Γ t τs :
       ✓ Γ → ✓{Γ}* τs → τs ≠ [] → Γ !! t = None → ✓ (<[t:=τs]>Γ)
    | env_insert_fun_valid Γ f τs τ :
       ✓ Γ → ✓{Γ}* (TType <$> τs) → ✓{Γ} (TType τ) →
       Γ !! f = None → ✓ (<[f:=(τs,τ)]>Γ).
  #[global] Existing Instance env_valid.

  Lemma env_valid_delete Γ t τs :
    ✓ Γ → Γ !! t = Some τs → ∃ Γ', Γ' ⊆ delete t Γ ∧ ✓{Γ'}* τs ∧ τs ≠ [] ∧ ✓ Γ'.
  Proof.
    intros HΓ Ht. induction HΓ
      as [|Γ t' τs' HΓ IH Hτs' Hlen|Γ f τs' τ' ? IH]; [done| |].
    { destruct (decide (t = t')) as [->|].
      { rewrite lookup_insert_compound in Ht. simplify_equality'.
        by exists Γ; repeat split; simpl; rewrite ?delete_insert by done. }
      rewrite lookup_insert_compound_ne in Ht by done.
      destruct IH as (Γ'&?&?&?&?); auto; exists Γ'; split_and ?; auto.
      transitivity (delete t Γ);
        auto using delete_compound_subseteq_compat, insert_compound_subseteq. }
    destruct (IH Ht) as (Γ'&?&?&?&?). exists Γ'; split_and ?; auto.
    transitivity (delete t Γ);
      auto using delete_compound_subseteq_compat, insert_fun_subseteq.
  Qed.
  Lemma env_valid_lookup_subset Γ t τs :
    ✓ Γ → Γ !! t = Some τs → ∃ Γ', Γ' ⊂ Γ ∧ ✓{Γ'}* τs ∧ τs ≠ [] ∧ ✓ Γ'.
  Proof.
    intros. destruct (env_valid_delete Γ t τs) as (Γ'&?&?&?&?); auto.
    exists Γ'; split_and ?; auto.
    eapply strict_transitive_r; eauto using delete_compound_subset.
  Qed.
  Lemma env_valid_lookup Γ t τs : ✓ Γ → Γ !! t = Some τs → ✓{Γ}* τs.
  Proof.
    intros. destruct (env_valid_lookup_subset Γ t τs) as (?&?&?&?);
      eauto using types_valid_strict_weaken.
  Qed.
  Lemma env_valid_lookup_lookup Γ t τs i τ :
    ✓ Γ → Γ !! t = Some τs → τs !! i = Some τ → ✓{Γ} τ.
  Proof.
    intros ? Ht Hi. eapply Forall_lookup_1, Hi; eauto using env_valid_lookup.
  Qed.
  Lemma env_valid_lookup_singleton Γ t τ : ✓ Γ → Γ !! t = Some [τ] → ✓{Γ} τ.
  Proof. intros. by apply (env_valid_lookup_lookup Γ t [τ] 0 τ). Qed.
  Lemma env_valid_fun_valid Γ f τs τ :
    ✓ Γ → Γ !! f = Some (τs,τ) → ✓{Γ}* (TType <$> τs) ∧ ✓{Γ} (TType τ).
  Proof.
    intros HΓ Hf. induction HΓ as [| |Γ f' τs' τ' ? IH]; [done| |].
    { naive_solver eauto using ptr_type_valid_weaken,
        ptr_types_valid_weaken, insert_compound_subseteq. }
    destruct (decide (f = f')) as [->|];
      rewrite ?lookup_fun_compound, ?lookup_fun_compound_ne in Hf by done;
      naive_solver eauto using ptr_type_valid_weaken,
        ptr_types_valid_weaken, insert_fun_subseteq.
  Qed.
  Lemma env_valid_args_valid Γ f τs τ :
    ✓ Γ → Γ !! f = Some (τs,τ) → ✓{Γ}* (TType <$> τs).
  Proof. eapply env_valid_fun_valid. Qed.
  Lemma env_valid_ret_valid Γ f τs τ :
    ✓ Γ → Γ !! f = Some (τs,τ) → ✓{Γ} (TType τ).
  Proof. eapply env_valid_fun_valid. Qed.
End types.

(** A very inefficient decision procedure for wellformedness of environments.
It checks wellformedness by trying all permutations of the environment. This
decision procedure is not intended to be used for computation. *)
Section env_valid_dec.
  Context {K : iType}.

  Definition env_f_valid (Γ : env K) : Prop :=
    map_Forall (λ _ τsτ,
      ✓{Γ}* (TType <$> τsτ.1) ∧ ✓{Γ} (TType (τsτ.2))) (env_f Γ).
  Inductive env_c_valid : list (tag * list (type K)) → Prop :=
    | env_nil_valid : env_c_valid []
    | env_cons_valid Γc t τs :
       env_c_valid Γc → ✓{mk_env (list_to_map Γc) ∅}* τs →
       τs ≠ [] → t ∉ (Γc.*1) → env_c_valid ((t,τs) :: Γc).
  Lemma env_c_valid_nodup Γc : env_c_valid Γc → NoDup (Γc.*1).
  Proof. by induction 1; csimpl; constructor. Qed.
  Global Instance env_c_valid_dec : ∀ Γc, Decision (env_c_valid Γc).
  Proof.
   refine (
    fix go Γc :=
    match Γc return Decision (env_c_valid Γc) with
    | [] => left _
    | (s,τs) :: Γc => cast_if_and4
       (decide (✓{mk_env (list_to_map Γc) ∅}* τs))
       (decide (τs ≠ [])) (decide (s ∉ Γc.*1)) (go Γc)
    end); clear go; first [by constructor |by inversion 1].
  Defined.
  Lemma env_c_valid_correct Γ :
    ✓ Γ ↔ env_f_valid Γ ∧ ∃ Γc, map_to_list (env_t Γ) ≡ₚ Γc ∧ env_c_valid Γc.
  Proof.
    split.
    * intros HΓ; split.
      { intros ? [??]; split;
          eauto using env_valid_args_valid, env_valid_ret_valid. }
      induction HΓ as [|Γ t τs ? (Γc&HΓ&?)|Γ f τs τ ? (Γc&HΓ&?)]; simpl; eauto.
      { eexists []. rewrite map_to_list_empty; by repeat constructor. }
      exists ((t,τs) :: Γc); split; [by rewrite map_to_list_insert, HΓ by done|].
      constructor; auto.
      { erewrite <-list_to_map_flip by eauto.
        eauto using Forall_impl, type_valid_weaken_help. }
      by erewrite not_elem_of_list_to_map, <-list_to_map_flip by eauto.
    * destruct Γ as [Γc Γf]; simpl; intros (HΓf&Γc'&HΓc&HΓc').
      assert (✓ (mk_env Γc ∅)).
      { erewrite (list_to_map_flip Γc) by eauto; clear Γc HΓc HΓf.
        induction HΓc' as [|Γc t τs ? IH]; simpl; [by constructor|].
        change (✓ (<[t:=τs]> (mk_env (list_to_map Γc) ∅))); constructor; auto.
        by apply not_elem_of_list_to_map. }
      clear Γc' HΓc HΓc'. revert HΓf. unfold env_f_valid; simpl.
      generalize Γf at 1 2; intros Γf'; revert Γf.
      refine (map_Forall_ind _ _ _ _); [done|].
      intros Γf f [τs τ] ? [] ??; simpl in *.
      change (✓ (<[f:=(τs,τ)]> (mk_env Γc Γf)));
        constructor; eauto using Forall_impl, ptr_type_valid_weaken_help.
  Qed.
  Lemma env_c_valid_correct_alt Γ :
    ✓ Γ ↔
      env_f_valid Γ ∧ Exists env_c_valid (permutations (map_to_list (env_t Γ))).
  Proof.
    rewrite env_c_valid_correct, Exists_exists.
    by setoid_rewrite permutations_Permutation.
  Qed.
  Global Instance env_valid_dec (Γ : env K) : Decision (✓ Γ).
  Proof.
   refine (cast_if (decide (env_f_valid Γ ∧
     Exists env_c_valid (permutations (map_to_list (env_t Γ))))));
     by rewrite env_c_valid_correct_alt.
  Defined.
End env_valid_dec.

(** A nice induction principle for wellformed types. *)
Section type_env_ind.
  Context {K : iType} `{EqDecision K}.
  Context (Γ : env K) (HΓ : ✓ Γ).

  Context (P : type K → Prop).
  Context (Pbase : ∀ τb, ✓{Γ} τb → P (baseT τb)).
  Context (Parray : ∀ τ n, ✓{Γ} τ → P τ → n ≠ 0 → P (τ.[n])).
  Context (Pcompound : ∀ c t τs,
    Γ !! t = Some τs → ✓{Γ}* τs → Forall P τs →
    τs ≠ [] → P (compoundT{c} t)).

  Lemma type_env_ind: ∀ τ, ✓{Γ} τ → P τ.
  Proof.
    cut (∀ Γ' τ, Γ' ⊆ Γ → ✓ Γ' → ✓{Γ'} τ → P τ).
    { intros help τ. by apply help. }
    induction Γ' as [Γ' IH] using (well_founded_induction env_wf).
    intros τ HΣΓ HΣ Hτ. induction Hτ as [τb Hτb|τ n Hτ|c t Ht].
    * by apply Pbase, (base_type_valid_weaken Γ').
    * apply Parray; eauto. by apply (type_valid_weaken Γ').
    * inversion Ht as [τs Hτs].
      destruct (env_valid_lookup_subset Γ' t τs) as (Γ''&?&Hτs'&Hlen&?); auto.
      assert (Γ'' ⊂ Γ) by eauto using (strict_transitive_l (R:=(⊆@{env K}))).
      apply Pcompound with τs; eauto using lookup_compound_weaken.
      + apply Forall_impl with (✓{Γ''}); auto.
        intros. eapply type_valid_strict_weaken; eauto.
      + clear Hτs Hlen. induction Hτs'; constructor; auto.
        apply (IH Γ''); eauto using (strict_include (R:=(⊆):relation (env _))).
  Qed.
End type_env_ind.

(** A nice iteration principle for well-formed types. *)
Section type_iter.
  Context {K : iType} `{EqDecision K}.
  Context {A : Type} (R : relation A) `{!Equivalence R}.
  Local Infix "≡" := R.
  Implicit Type τ : type K.
  Implicit Type Γ Σ : env K.

  Section definition.
    Context (fb : base_type K → A)
      (fa : type K → nat → A → A)
      (fc: compound_kind → tag → list (type K) → (type K → A) → A).

    Definition type_iter_inner
        (g : tag → list (type K) * (type K → A)) : type K → A :=
      fix go τ :=
      match τ with
      | baseT τb => fb τb
      | τ.[n] => fa τ n (go τ)
      | compoundT{c} t => let (τs,h) := g t in fc c t τs h
      end.
    Definition type_iter_accF (Γ : env K) (go : ∀ Σ, Σ ⊂ Γ → type K → A)
        (t : tag) : list (type K) * (type K → A) :=
      match Some_dec (Γ !! t) with
      | inleft (τs↾Hτs) => (τs, go (delete t Γ)
          (delete_compound_subset_alt _ _ _ Hτs))
      | inright _ => ([], λ _, fb voidT) (**i dummy *)
      end.
    Definition type_iter_acc : ∀ Γ : env K, Acc (⊂) Γ → type K → A :=
      Fix_F _ (λ Γ go, type_iter_inner (type_iter_accF Γ go)).
    Definition type_iter (Γ : env K) : type K → A :=
      type_iter_acc _ (wf_guard 32 env_wf Γ).
  End definition.

  Lemma type_iter_acc_weaken fb1 fb2 fa1 fa2 fc1 fc2 Γ Γ1 Γ2 acc1 acc2 τ :
    ✓ Γ →
    (∀ τb, ✓{Γ} τb → fb1 τb ≡ fb2 τb) →
    (∀ τ n x y, ✓{Γ} τ → x ≡ y → fa1 τ n x ≡ fa2 τ n y) →
    (∀ rec1 rec2 c t τs,
      Γ !! t = Some τs → ✓{Γ}* τs → Forall (λ τ, rec1 τ ≡ rec2 τ) τs →
      fc1 c t τs rec1 ≡ fc2 c t τs rec2) →
    ✓{Γ} τ → Γ ⊆ Γ1 → Γ ⊆ Γ2 →
    type_iter_acc fb1 fa1 fc1 Γ1 acc1 τ ≡ type_iter_acc fb2 fa2 fc2 Γ2 acc2 τ.
  Proof.
    intros HΓ Hbase Harray. revert Γ1 Γ2 acc1 acc2 τ HΓ.
    induction Γ as [Γ IH] using (well_founded_induction env_wf).
    intros Γ1 Γ2 [acc1] [acc2] τ HΓ Hcompound Hτ HΓ1 HΓ2. simpl.
    induction Hτ as [τ Hτ|τ n Hτ|c t [τs Ht]]; simpl; try reflexivity; auto.
    assert (Γ1 !! t = Some τs) by eauto using lookup_compound_weaken.
    assert (Γ2 !! t = Some τs) by eauto using lookup_compound_weaken.
    unfold type_iter_accF.
    destruct (Some_dec (Γ1 !! t)) as [[τs1 Ht1]|?],
      (Some_dec (Γ2 !! t)) as [[τs2 Ht2]|?]; simplify_equality'.
    generalize (acc1 _ (delete_compound_subset_alt Γ1 t τs1 Ht1)),
      (acc2 _ (delete_compound_subset_alt Γ2 t τs1 Ht2)); intros acc1' acc2'.
    destruct (env_valid_delete Γ t τs1) as (Γ'&?&Hτs&Hlen&?); trivial.
    assert (Γ' ⊆ Γ).
    { transitivity (delete t Γ); eauto using delete_compound_subseteq. }
    apply Hcompound; eauto using types_valid_weaken.
    assert (is_Some (Γ !! t)) by eauto. clear Ht Ht1 Ht2 Hlen acc1 acc2.
    induction Hτs as [|τ τs]; constructor; auto. apply (IH Γ').
    * eauto using (strict_transitive_r (R:=(⊆@{env K}))),
        delete_compound_subset, lookup_compound_weaken_is_Some.
    * eauto using base_type_valid_weaken.
    * eauto using type_valid_weaken.
    * done.
    * eauto using lookup_compound_weaken, types_valid_weaken.
    * done.
    * transitivity (delete t Γ); eauto using delete_compound_subseteq_compat.
    * transitivity (delete t Γ); eauto using delete_compound_subseteq_compat.
  Qed.
  Lemma type_iter_weaken fb1 fb2 fa1 fa2 fc1 fc2 Γ Σ τ :
    ✓ Γ →
    (∀ τb, ✓{Γ} τb → fb1 τb ≡ fb2 τb) →
    (∀ τ n x y, ✓{Γ} τ → x ≡ y → fa1 τ n x ≡ fa2 τ n y) →
    (∀ rec1 rec2 c t τs,
      Γ !! t = Some τs → ✓{Γ}* τs → Forall (λ τ, rec1 τ ≡ rec2 τ) τs →
      fc1 c t τs rec1 ≡ fc2 c t τs rec2) →
    ✓{Γ} τ → Γ ⊆ Σ →
    type_iter fb1 fa1 fc1 Γ τ ≡ type_iter fb2 fa2 fc2 Σ τ.
  Proof. intros. by apply (type_iter_acc_weaken _ _ _ _ _ _ Γ). Qed.

  Lemma type_iter_base fb fa fc Γ τb : type_iter fb fa fc Γ (baseT τb) = fb τb.
  Proof. done. Qed.
  Lemma type_iter_array fb fa fc Γ τ n :
    type_iter fb fa fc Γ (τ.[n]) = fa τ n (type_iter fb fa fc Γ τ).
  Proof. unfold type_iter. by destruct (wf_guard _ env_wf Γ). Qed.
  Lemma type_iter_compound fb fa fc Γ c t τs :
    ✓ Γ → (∀ τ n x y, ✓{Γ} τ → x ≡ y → fa τ n x ≡ fa τ n y) →
    (∀ rec1 rec2 c t τs,
      Γ !! t = Some τs → ✓{Γ}* τs → Forall (λ τ, rec1 τ ≡ rec2 τ) τs →
      fc c t τs rec1 ≡ fc c t τs rec2) →
    Γ !! t = Some τs →
    type_iter fb fa fc Γ (compoundT{c} t) ≡ fc c t τs (type_iter fb fa fc Γ).
  Proof.
    intros ? Harray Hcompound Ht. unfold type_iter at 1.
    destruct (wf_guard _ env_wf Γ) as [accΓ]. simpl.
    unfold type_iter_accF.
    destruct (Some_dec (Γ !! t)) as [[τs' Ht']|?]; [|congruence].
    generalize (accΓ _ (delete_compound_subset_alt Γ t τs' Ht')). intros accΓ'.
    simplify_map_eq.
    destruct (env_valid_delete Γ t τs) as (Γ'&?&Hτs&Hlen&?); trivial.
    assert (Γ' ⊆ Γ).
    { transitivity (delete t Γ); eauto using delete_compound_subseteq. }
    apply Hcompound; eauto using types_valid_weaken.
    clear Ht Hlen. induction Hτs; constructor; auto.
    by apply (type_iter_acc_weaken _ _ _ _ _ _ Γ');
      eauto using lookup_compound_weaken, type_valid_weaken, types_valid_weaken.
  Qed.
  Lemma type_iter_compound_None fb fa fc Γ c t :
    Γ !! t = None →
    type_iter fb fa fc Γ (compoundT{c} t) = fc c t [] (λ _, fb voidT%BT).
  Proof.
    intros Ht. unfold type_iter.
    destruct (wf_guard _ env_wf Γ) as [accΓ]; simpl.
    unfold type_iter_accF. destruct (Some_dec _) as [[??]|?]; congruence.
  Qed.
End type_iter.


Require Import Coqlib.
Require Import Maps.
Require Import LibTactics.

Require Import Integers.
Open Scope Z_scope.
Import ListNotations.

Set Asymmetric Patterns.

Require Import state.
Require Import language.

Set Implicit Arguments.
Unset Strict Implicit.

Require Import logic.

Require Import lemmas.
Require Import lemmas_ins.

Require Import Coq.Logic.FunctionalExtensionality.

Require Import integer_lemma.

Require Import sep_lemma.
Require Import reg_lemma.
Require Import derived_rule.

Require Import tm_dly_lemma.

Require Import code.
Require Import ctxswitch_spec.

Require Import lemma1.

Open Scope nat.
Open Scope code_scope.
Open Scope mem_scope.

(*+ Lemmas +*)
Lemma neq_rev_still :
  forall {A : Type} (a b : A),
    a <> b ->
    b <> a.
Proof.
  intros.
  intro.
  symmetry in H0.
  tryfalse.
Qed.

Lemma rotate_hold_post_id_neq_oid :
  forall oid id vi i,
    $ 0 <=ᵤᵢ oid <=ᵤᵢ $ 7 -> $ 0 <=ᵤᵢ id <=ᵤᵢ $ 7 -> $ 0 <=ᵤᵢ vi <=ᵤᵢ $ 7 ->
    rotate oid id vi i -> post_cwp id <> vi ->
    post_cwp id <> oid.
Proof.
  intros.
  inversion H2; subst.
  eapply post_1_neq; eauto.

  inversion H4; subst.
  eapply post_2_neq; eauto.

  inversion H7; subst.
  eapply post_3_neq; eauto.

  inversion H10; subst.
  eapply post_4_neq; eauto.

  inversion H13; subst.
  eapply post_5_neq; eauto.

  clear H2 H4 H7 H10 H13.
  inversion H16; subst.
  eapply post_6_neq; eauto.

  inversion H2; subst.
  eapply post_7_eq; eauto.

  inversion H10; subst.
  {
    clear - H H1 H13 H4 H17 H14 H11 H8 H5 H3.
    eapply post_cwp_step_limit_8 with (id := id0) (vi := vi) in H; eauto.
    do 7 (destruct H as [a | H]; [subst; tryfalse | idtac]).
    subst; tryfalse.
  }
  {
    intro.
    clear - H1 H22 H13 H4 H17 H14 H11 H8 H5 H3 H21.
    eapply post_cwp_step_limit_8 with (id := id) (vi := vi) in H1; eauto.
    do 7 (destruct H1 as [a | H1]; [subst; tryfalse | idtac]).
    subst; tryfalse.
  }
Qed.

(*+ Lemma for stack frame relation +*)

Lemma stack_frame_match_fm_save :
  forall fm F oid id cl clfp1 clfp2 cstk,
    $ 0 <=ᵤᵢ oid <=ᵤᵢ $ 7 -> $ 0 <=ᵤᵢ id <=ᵤᵢ $ 7 -> ostk_lfp_rl cstk cl clfp1 clfp2 ->
    stack_frame_match oid clfp1 (F ++ fm :: nil) id -> length F = 13 ->
    stack_frame_save (F ++ fm :: nil) (cl, clfp1 ++ clfp2)
                     cstk oid (post_cwp id).
Proof.
  intros.
  destruct cstk.
  unfolds ostk_lfp_rl.
  simpljoin1.
  unfold stack_frame_save.
  split; eauto.
  do 14 (try destruct F; simpl in H3; tryfalse).
  simpl in H2.

  inversion H2; subst.
  {
    destruct x; tryfalse.
    simpl.
    eapply frame_save_end; eauto.
  }

  destruct x; tryfalse.
  destruct p.
  inversion H11; subst.
  {
    simpl.
    eapply frame_save_cons; eauto.
    eapply post_cons_neq_still; eauto.
    destruct x; simpl in H4; tryfalse.
    simpl.
    eapply frame_save_end; eauto.
  }

  destruct x; simpl in H4; tryfalse.
  destruct p.
  inversion H13; subst.
  {
    destruct x; simpl in H4; tryfalse.
    simpl.
    do 2 (eapply frame_save_cons; [solve_post_neq | idtac]).
    eapply frame_save_end; eauto.
  }

  destruct x; simpl in H4; tryfalse.
  destruct p.
  inversion H15; subst.
  {
    simpl.
    do 2 (eapply frame_save_cons; [solve_post_neq | idtac]).
    eapply post_cons_neq_still_rev; eauto.
    eapply frame_save_cons; [solve_post_neq | idtac].
    destruct x; simpl in H4; tryfalse.
    simpl.
    eapply frame_save_end; eauto.
  }

  destruct x; simpl in H4; tryfalse.
  destruct p.
  inversion H17; subst.
  {
    simpl.
    destruct x; simpl in H4; tryfalse.
    do 3 (eapply frame_save_cons; [solve_post_neq | idtac];
          try eapply post_cons_neq_still_rev; eauto).
    eapply post_cons_neq_still_rev; eauto.
    eapply frame_save_cons; [solve_post_neq | idtac].
    eapply frame_save_end; eauto.
  }

  destruct x; simpl in H4; tryfalse.
  destruct p.
  inversion H19; subst.
  {
    destruct x; simpl in H4; tryfalse.
    do 4 (eapply frame_save_cons; [solve_post_neq | idtac];
          do 2 (try eapply post_cons_neq_still_rev; eauto)).
    eapply post_cons_neq_still_rev; eauto.
    eapply frame_save_cons; [solve_post_neq | idtac];
      do 2 (try eapply post_cons_neq_still_rev; eauto).
    eapply frame_save_end; eauto.
  }

  destruct x; simpl in H4; tryfalse.
  destruct p.
  inversion H21; subst.
  {
    destruct x; simpl in H4; tryfalse.
    simpl.
    do 6 (try eapply frame_save_cons; [solve_post_neq | idtac];
          repeat (eapply post_cons_neq_still_rev; eauto)).
    eapply frame_save_end; eauto.
  }

  destruct x; simpl in H4; tryfalse.
  destruct p.
  inversion H23; subst.
  {
    destruct x; simpl in H4; tryfalse.
    simpl.
    do 7 (try eapply frame_save_cons; [solve_post_neq | idtac];
          repeat (eapply post_cons_neq_still_rev; eauto)).
    eapply frame_save_end; eauto.
  }
Qed.

Lemma stk_fm_match_stk_len_lt_13 :
  forall oid clfp F id,
    $ 0 <=ᵤᵢ oid <=ᵤᵢ $ 7 -> $ 0 <=ᵤᵢ id <=ᵤᵢ $ 7 ->
    stack_frame_match oid clfp F id -> length F = 14 ->
    length clfp < 8.
Proof.
  intros.
  do 15 (destruct F; simpl in H2; tryfalse).

  inversion H1; subst; simpl; try omega.
  inversion H10; subst; simpl; try omega.
  inversion H12; subst; simpl; try omega.
  inversion H14; subst; simpl; try omega.
  inversion H16; subst; simpl; try omega.
  inversion H18; subst; simpl; try omega.
  inversion H20; subst; simpl; try omega.
  inversion H22; subst; simpl; try omega.
Qed.

Inductive frame_restore1 : Word -> FrameList -> Word -> FrameList -> Prop :=
| restore_end1 : forall F id, frame_restore1 id F id F
| restore_cons1 :
    forall F F' id vi fm1 fm2,
      id <> vi ->
      $ 0 <=ᵤᵢ id <=ᵤᵢ $ 7 -> frame_restore1 (post_cwp id) (F' ++ fm1 :: fm2 :: nil) vi F ->
      frame_restore1 id (fm1 :: fm2 :: F') vi F.

Lemma frame_restore_restore1_eq :
  forall F F' id vi,
    length F = 16 -> length F' = 16 ->
    $ 0 <=ᵤᵢ id <=ᵤᵢ $ 7 -> $ 0 <=ᵤᵢ vi <=ᵤᵢ $ 7 ->
    frame_restore id F vi F' ->
    frame_restore1 id F vi F'.
Proof.
  intros.
  do 17 (try destruct F; simpl in H; tryfalse).
  do 17 (try destruct F'; simpl in H0; tryfalse).
  clear H H0.

  (** step0 *)
  inversion H3; subst.
  {
    eapply restore_end1; eauto.
  }

  (** step1 *)
  clear H3.
  assert (length F' = 14).
  {
    assert (length (F' ++ fm1 :: fm2 :: nil) = 16).
    rewrite H; simpl; eauto.
    rewrite app_length in H3.
    simpls; omega.
  }
  do 15 (try destruct F'; simpl in H3; tryfalse).
  simpl in H.
  inversion H; subst.
  clear H H3.
  inversion H8; subst.
  {
    simpl.
    eapply restore_cons1; eauto.
    eapply restore_end1; eauto.
  }

  (** step2 *)
  clear H8.
  assert (length F' = 14).
  {
    assert (length (F' ++ fm1 :: fm2 :: nil) = 16).
    rewrite H; simpl; eauto.
    rewrite app_length in H6.
    simpls; omega.
  }
  do 15 (try destruct F'; simpl in H6; tryfalse).
  simpl in H.
  inversion H; subst.
  clear H H6.
  inversion H10; subst.
  {
    do 2 (eapply restore_cons1; try solve_post_neq;
          repeat (eapply post_cons_neq_still_rev; eauto)).
    eapply restore_end1; eauto.
  }

  (** step3 *)
  clear H10.
  assert (length F' = 14).
  {
    assert (length (F' ++ fm1 :: fm2 :: nil) = 16).
    rewrite H; simpl; eauto.
    rewrite app_length in H8.
    simpls; omega.
  }
  do 15 (try destruct F'; simpl in H8; tryfalse).
  simpl in H.
  inversion H; subst.
  clear H H8.
  inversion H12; subst.
  {
    do 3 (eapply restore_cons1; try solve_post_neq;
          repeat (eapply post_cons_neq_still_rev; eauto)).
    eapply restore_end1; eauto.
  }

  (** step4 *)
  clear H12.
  assert (length F' = 14).
  {
    assert (length (F' ++ fm1 :: fm2 :: nil) = 16).
    rewrite H; simpl; eauto.
    rewrite app_length in H10.
    simpls; omega.
  }
  do 15 (try destruct F'; simpl in H10; tryfalse).
  simpl in H.
  inversion H; subst.
  clear H H10.
  inversion H14; subst.
  {
    do 4 (eapply restore_cons1; try solve_post_neq;
          repeat (eapply post_cons_neq_still_rev; eauto)).
    eapply restore_end1; eauto.
  }

  (** step5 *)
  clear H14.
  assert (length F' = 14).
  {
    assert (length (F' ++ fm1 :: fm2 :: nil) = 16).
    rewrite H; simpl; eauto.
    rewrite app_length in H12.
    simpls; omega.
  }
  do 15 (try destruct F'; simpl in H12; tryfalse).
  simpl in H.
  inversion H; subst.
  clear H H12.
  inversion H16; subst.
  {
    do 5 (eapply restore_cons1; try solve_post_neq;
          repeat (eapply post_cons_neq_still_rev; eauto)).
    eapply restore_end1; eauto.
  }

  (** step 6 *)
  clear H16.
  assert (length F' = 14).
  {
    assert (length (F' ++ fm1 :: fm2 :: nil) = 16).
    rewrite H; simpl; eauto.
    rewrite app_length in H14.
    simpls; omega.
  }
  do 15 (try destruct F'; simpl in H14; tryfalse).
  simpl in H.
  inversion H; subst.
  clear H H14.
  inversion H18; subst.
  {
    do 6 (eapply restore_cons1; try solve_post_neq;
          repeat (eapply post_cons_neq_still_rev; eauto)).
    eapply restore_end1; eauto.
  }

  (** step 7 *)
  clear H18.
  assert (length F' = 14).
  {
    assert (length (F' ++ fm1 :: fm2 :: nil) = 16).
    rewrite H; simpl; eauto.
    rewrite app_length in H16.
    simpls; omega.
  }
  do 15 (try destruct F'; simpl in H16; tryfalse).
  simpl in H.
  inversion H; subst.
  clear H H16.
  inversion H20; subst.
  {
    do 7 (eapply restore_cons1; try solve_post_neq;
          repeat (eapply post_cons_neq_still_rev; eauto)).
    eapply restore_end1; eauto.
  }

  (** step 8 *)
  clear H20.
  assert (length F' = 14).
  {
    assert (length (F' ++ fm1 :: fm2 :: nil) = 16).
    rewrite H; simpl; eauto.
    rewrite app_length in H18.
    simpls; omega.
  }
  do 15 (try destruct F'; simpl in H18; tryfalse).
  simpl in H.
  inversion H; subst.
  clear H H18.
  inversion H22; subst.
  {
    clear - H0 H1.
    rewrite post_8_eq in H0; tryfalse.
    eauto.
  }
  clear - H1 H19 H18 H16 H14 H12 H10 H8 H6 H3.
  eapply post_cwp_step_limit_8 in H1; eauto.
  do 7 (destruct H1 as [a | H1]; [subst; tryfalse | idtac]).
  subst; tryfalse.
Qed.

Ltac post_nth_neq :=
  eapply neq_rev_still; try eapply post_1_neq; try eapply post_2_neq;
  try eapply post_3_neq; try eapply post_4_neq; try eapply post_5_neq;
  try eapply post_6_neq; try eapply post_7_eq; solve_post_inrange.

Lemma stk_fm_match_cons_tail_stable :
  forall F F' oid id lfp fmo fmo' fml fml' fmi fmi' fm1 fm2,
    post_cwp id <> oid -> $ 0 <=ᵤᵢ oid <=ᵤᵢ $ 7 -> $ 0 <=ᵤᵢ id <=ᵤᵢ $ 7 ->
    length F = 13 -> length F' = 11 ->
    stack_frame_match oid lfp (F ++ fmo :: nil) id ->
    frame_restore oid (fmo :: fml :: fmi :: F) id
                  (fmo' :: fml' :: fmi' :: fm1 :: fm2 :: F') ->
    stack_frame_match oid (lfp ++ (fm1, fm2) :: nil) (F ++ fmo :: nil) (post_cwp id).
Proof.
  introv Hpost_cwp_neq.
  intros.
  do 14 (destruct F; simpl in H1; tryfalse).
  do 12 (destruct F'; simpl in H2; tryfalse).
  clear H1 H2.

  simpl in H3.
  eapply frame_restore_restore1_eq in H4; eauto.

  (** step0 *)
  inversion H3; subst.
  {
    inversion H4; subst; tryfalse.
    simpl.
    eapply match_cons; eauto; try solve_post_neq.
    eapply match_end; eauto.
  }

  (** step1 *)
  clear H3.
  inversion H4; subst; tryfalse.
  clear H4.
  inversion H10; subst.
  {
    inversion H12; subst; tryfalse.
    simpl.
    do 2 (eapply match_cons; eauto; try post_nth_neq).
    eapply match_end; eauto.
  }

  (** step2 *)
  clear H10.
  inversion H12; subst; tryfalse.
  clear H12.
  inversion H13; subst.
  {
    simpl in H15.
    inversion H15; subst; tryfalse.
    simpl.
    do 3 (eapply match_cons; eauto; try post_nth_neq).
    eapply match_end; eauto.
  }

  (** step3 *)
  clear H13.
  inversion H15; subst; tryfalse.
  clear H15.
  inversion H16; subst.
  {
    simpl in H18.
    inversion H18; subst; tryfalse.
    simpl.
    do 4 (eapply match_cons; eauto; try post_nth_neq).
    eapply match_end; eauto.
  }

  (** step4 *)
  clear H16.
  inversion H18; subst; tryfalse.
  clear H18.
  inversion H19; subst.
  {
    simpl in H21.
    inversion H21; subst; tryfalse.
    simpl.
    do 5 (eapply match_cons; eauto; try post_nth_neq).
    eapply match_end; eauto.
  }

  (** step5 *)
  clear H19.
  inversion H21; subst; tryfalse.
  clear H21.
  inversion H22; subst.
  {
    simpl in H24.
    inversion H24; subst; tryfalse.
    simpl.
    do 6 (eapply match_cons; eauto; try post_nth_neq).
    eapply match_end; eauto.
  }

  (** step6 *)
  clear H22.
  inversion H24; subst; tryfalse.
  clear H24.
  inversion H25; subst.
  {
    simpl in H27.
    inversion H27; subst; tryfalse.
    simpl.
    do 7 (eapply match_cons; eauto; try post_nth_neq).
    eapply match_end; eauto.
  }

  (** step7 *)
  clear H25.
  inversion H27; subst; tryfalse.
  clear H27.
  inversion H28; subst.
  {
    simpl in H30.
    inversion H30; subst; tryfalse.
    simpl.
    rewrite post_8_eq in Hpost_cwp_neq; eauto.
    tryfalse.
  }
Qed.

Lemma stk_fm_contraint_fm_app_stable :
  forall l id F lfp vi F',
    stack_frame_constraint' l id F lfp vi ->
    stack_frame_constraint' l id (F ++ F') lfp vi.
Proof.
  intros.
  generalize dependent F'.
  induction H; intros.
  -
    eapply frame_invalid; eauto.
  -
    eapply frame_valid; eauto.
Qed.

(*+ Lemmas for Space +*)
Lemma stack'_split :
  forall lfp1 lfp2 l s p,
    length lfp1 < 100 ->
    s |= stack' l (lfp1 ++ lfp2) ** p ->
    s |= stack' l lfp1 ** stack' (l -ᵢ ($ (64 * Z.of_nat (length lfp1)))) lfp2 ** p.
Proof.
  intro lfp1.
  induction lfp1; intros.
  -
    simpl stack' in H0.
    simpl stack'.
    eapply astar_emp_intro_l; eauto.
    rewrite Int.sub_zero_l; eauto.
  -
    destruct a.
    simpl stack' in H0.
    simpl stack' at 1.
    eapply astar_assoc_elim in H0.
    eapply astar_assoc_intro.
    sep_cancel1 1 1.
    eapply IHlfp1 in H1; eauto.
    sep_cancel1 1 1.
    simpl length.
    rewrite Nat2Z.inj_succ.
    unfold Z.succ.
    do 2 rewrite Int.sub_add_opp in H0.
    rewrite Int.sub_add_opp.
    rewrite Int.add_assoc in H0.
    rewrite <- Int.neg_add_distr in H0.
    remember (length lfp1) as lenlfp1.
    assert (($ 64) +ᵢ ($ (64 * Z.of_nat lenlfp1)) = $ (64 * (Z.of_nat lenlfp1 + 1))).
    {
      rewrite Int.add_unsigned.
      assert (Int.unsigned $ 64 = 64%Z).
      eauto.
      rewrite H1; eauto.
      rewrite Int.unsigned_repr; eauto.
      assert ((64 * (Z.of_nat lenlfp1 + 1) = 64 + 64 * Z.of_nat lenlfp1)%Z).
      omega.
      rewrite H2.
      eauto.
      subst lenlfp1.
      clear - H.
      simpl in H.
      unfold Int.max_unsigned, Int.modulus.
      unfold two_power_nat.
      simpl shift_nat.
      omega.
    }
    rewrite H1 in H0.
    eauto.
    simpl in H.
    omega.
Qed.

Lemma stack'_cons_tail :
  forall lfp l s p fm1 fm2,
    length lfp < 100 ->
    s |= stack' l lfp ** stack_frame (l -ᵢ ($ (64 * Z.of_nat (length lfp)))) fm1 fm2 ** p ->
    s |= stack' l (lfp ++ (fm1, fm2) :: nil) ** p.
Proof.
  intro lfp.
  induction lfp; intros.
  -
    simpl stack' in *.
    simpl length in *.
    eapply astar_assoc_intro; eauto.
    assert ((64 * Z.of_nat 0 = 0)%Z).
    simpl. eauto.
    rewrite H1 in H0.
    rewrite Int.sub_zero_l in H0.
    sep_cancel1 2 1.
    eauto.
  -
    destruct a.
    simpl length in H0.
    simpl stack' in *.
    eapply astar_assoc_elim in H0.
    eapply astar_assoc_intro; eauto.
    sep_cancel1 1 1.
    eapply IHlfp; eauto.
    simpl in H; omega.
    rewrite Nat2Z.inj_succ in H1.
    unfold Z.succ in H1.
    sep_cancel1 1 1.
    rewrite Int.sub_add_opp in H0.
    do 2 rewrite Int.sub_add_opp.
    rewrite Int.add_assoc.
    rewrite <- Int.neg_add_distr.
    assert (($ 64) +ᵢ ($ (64 * Z.of_nat (length lfp))) =
            $ (64 * (Z.of_nat (length lfp) + 1))).
    {
      rewrite Int.add_unsigned; eauto.
      assert (Int.unsigned $ 64 = 64%Z).
      eauto.
      rewrite H1.
      rewrite Int.unsigned_repr; eauto.
      assert ((64 * (Z.of_nat (length lfp) + 1) = 64 + 64 * Z.of_nat (length lfp))%Z).
      omega.
      rewrite H2.
      eauto.
      unfolds Int.max_unsigned, Int.modulus, two_power_nat.
      simpl shift_nat.
      simpl in H.
      omega.
    }
    rewrite H1.
    eauto.
Qed.

(*+ Proof +*)
Theorem Ta0SaveUsedWindowsProof :
  forall vl,
    spec |- {{ ta0_save_usedwindows_pre vl }}
             ta0_save_usedwindows
           {{ ta0_save_usedwindows_post vl }}.
Proof.
  intros.
  unfold ta0_save_usedwindows_pre.
  unfold ta0_save_usedwindows_post.
  hoare_ex_intro_pre.
  renames x'0 to fmg', x'2 to fmo', x'4 to fml', x'6 to fmi'.
  renames x'8 to id, x'12 to vi, x'10 to F', x'11 to vy.
  renames x'24 to vz, x'25 to vn, x'15 to ct, x'21 to nt, x'13 to ll.
  renames x'16 to cctx, x'20 to cstk, x'17 to cl, x'18 to clfp1, x'19 to clfp2.
  renames x'22 to nctx, x'23 to nstk.
  renames x'7 to oid, x'1 to fmo, x'3 to fml, x'5 to fmi, x'9 to F, x'14 to i.

  eapply Pure_intro_rule.
  introv Hlgvl.
  hoare_lift_pre 15.
  eapply Pure_intro_rule.
  introv Hnctx.
  hoare_lift_pre 15.
  eapply Pure_intro_rule.
  introv Hstk_fm_match.
  hoare_lift_pre 15.
  eapply Pure_intro_rule.
  introv Hfm_restore.
  hoare_lift_pre 15.
  eapply Pure_intro_rule.
  introv Hstk_fm_constraint.
  hoare_lift_pre 15.
  eapply Pure_intro_rule.
  introv Hg4.
  destruct Hg4 as [Hg4 [Hrot [Hoid_range [Hg4_vl Hg7] ] ] ].
  hoare_lift_pre 15.
  eapply Pure_intro_rule.
  introv Hctx_win_save.

  unfold ta0_save_usedwindows.

  destruct fmg', fmo', fml', fmi'.

  (** sll g4 1 g5 *)
  hoare_lift_pre 2.
  eapply backward_rule.
  introv Hs.
  eapply Regs_Global_combine_GenRegs in Hs; eauto.
  eapply seq_rule; eauto.
  TimReduce_simpl.
  eapply sll_rule_reg; eauto.
  simpl; eauto.
  rewrite in_range1; eauto.
  simpl upd_genreg.
  rewrite get_range_0_4_stable; eauto.

  (** srl g4 (OS_WINDOWS - 1) g4 *)
  unfold OS_WINDOWS.
  assert (Heq7 : ($ 8) -ᵢ ($ 1) = ($ 7)).
  eauto.
  rewrite Heq7; eauto.
  eapply seq_rule; eauto.
  TimReduce_simpl.
  eapply srl_rule_reg; eauto.
  simpl; eauto.
  rewrite in_range7; eauto.
  simpl upd_genreg.

  simpl in Hg4.
  inversion Hg4; subst.
  rewrite get_range_0_4_stable; eauto.

  (** or g4 g5 g4 *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply or_rule_reg; eauto.
  simpl; eauto.
  simpl upd_genreg.

  (** andcc g4 g7 g0 *)
  hoare_lift_pre 4.
  hoare_lift_pre 5.
  hoare_lift_pre 3.
  eapply seq_rule; eauto.
  TimReduce_simpl.
  eapply andcc_rule_reg; eauto.
  simpl; eauto.
  simpl upd_genreg.
  simpl get_genreg_val; eauto.

  (** bne Ta0_Task_Switch_NewContext; nop *)
  simpl in Hg7.
  destruct Hg7 as [Hg7 Hct_not_null].
  inversion Hg7; subst.
  eapply hoare_pure_gen' with (pu := $ 0 <=ᵤᵢ id <=ᵤᵢ $ 7 /\ $ 0 <=ᵤᵢ vi <=ᵤᵢ $ 7).
  {
    introv Hs.
    simpl_sep_liftn_in Hs 4.
    unfold FrameState in Hs.
    asrt_to_line_in Hs 3.
    simpl_sep_liftn_in Hs 4.
    eapply sep_pure_l_elim in Hs; eauto.
    simpljoin1; eauto.
  }
  eapply Pure_intro_rule.
  introv Hid_inrange.
  destruct Hid_inrange as [Hid_inrange Hvi_inrange].

  assert (Hiszero : iszero ((i >>ᵢ ($ 7)) |ᵢ (i <<ᵢ ($ 1))) &ᵢ (($ 1) <<ᵢ vi) =
          iszero (get_range 0 7 (i >>ᵢ ($ 7)) |ᵢ (i <<ᵢ ($ 1))) &ᵢ (($ 1) <<ᵢ vi)).
  {
    rewrite in_range_0_7_and; eauto.
  }
  rewrite Hiszero.
  rewrite g4_val_get_range_0_7_equal with (id := id); eauto.

  eapply Bne_rule; eauto.
  {
    eval_spec.
  }
  {
    TimReduce_simpl.
    eapply nop_rule; eauto.
  }
  {
    TimReduce_simpl.
    introv Hs.
    sep_cancel1 3 1.
    simpl; eauto.
  }

  Focus 3.
  introv Hnxt_invalid.
  unfold iszero in Hnxt_invalid.
  destruct (Int.eq_dec (($ 1) <<ᵢ (post_cwp id)) &ᵢ (($ 1) <<ᵢ vi) $ 0); tryfalse.
  clear Hnxt_invalid.
  renames n to Hnxt_invalid.
  eapply and_not_zero_eq in Hnxt_invalid; eauto.

  split.

    introv Hs.
    unfold ta0_task_switch_newcontext_pre.
    sep_ex_intro.
    asrt_to_line 14.
    eapply sep_pure_l_intro; eauto.
    simpl_sep_liftn 2.
    eapply GenRegs_split_Regs_Global.
    sep_cancel1 1 1.
    sep_cancel1 3 1.
    sep_cancel1 3 1.
    sep_cancel1 1 2.
    do 5 sep_cancel1 1 1.
    sep_cancel1 3 1.
    sep_cancel1 3 1.
    eapply sep_pure_l_intro; eauto.
    eapply sep_pure_l_intro; eauto.

    introv Hs.
    destruct Hctx_win_save as [Hctx_win_save [Hctx_pt_stk Hostk_lfp] ].
    unfold ta0_task_switch_newcontext_post in Hs.
    sep_ex_elim_in Hs.
    asrt_to_line_in Hs 13.
    eapply sep_pure_l_elim in Hs.
    destruct Hs as [Hlgvl1 Hs].
    symmetry in Hlgvl1.
    inversion Hlgvl1; subst.
    sep_ex_intro.
    eapply sep_pure_l_intro; eauto.
    do 10 sep_cancel1 1 1.
    sep_cancel1 4 1.
    sep_cancel1 4 1.
    eapply sep_pure_l_intro; eauto.
    do 2 sep_cancel1 1 1.
    clear - Hostk_lfp.
    unfolds ostk_lfp_rl.
    destruct cstk.
    simpljoin1.
    simpls; eauto.
    sep_cancel1 1 1.
    sep_cancel1 1 1.
    eapply sep_pure_l_intro; eauto.
    introv Hct.
    split; eauto.
    split; eauto.
    eapply stack_frame_match_fm_save; eauto.
    simpljoin1; eauto.
    simpljoin1; eauto.
    eapply astar_emp_elim_r; eauto.
    eapply in_range_0_7_post_cwp_still; eauto.

  introv Hnjp.
  clear Hiszero Heq7.
  assert (Hlen_clfp1 : length clfp1 < 8).
  {
    destruct Hstk_fm_match as [Hstk_fm_match Hlen_F].
    eapply stk_fm_match_stk_len_lt_13 with (id := id) (oid := oid); eauto.
    rewrite app_length; eauto.
    simpl; omega.
  }

  unfold iszero in Hnjp.
  destruct (Int.eq_dec (($ 1) <<ᵢ (post_cwp id)) &ᵢ (($ 1) <<ᵢ vi) $ 0); tryfalse.
  renames e to Hneq.
  eapply and_zero_not_eq in Hneq; eauto.
  inversion Hstk_fm_constraint; tryfalse; subst.
  match goal with
  | H1 : stack_frame_constraint' _ (post_cwp id) _ _ _,
         H2 : get_frame_nth _ 6 = Some (get_stk_addr _), H3 : _ = get_stk_cont _  |- _ =>
    renames H1 to Hstk_fm_constraint1, H2 to Hpt_stk, H3 to Hlfp
  end.
  simpl in Hlfp.
  subst clfp2.
  renames lfp to clfp2.
  simpl get_frame_nth in Hpt_stk.
  unfold get_stk_addr in Hpt_stk.
  unfold get_stk_addr in Hstk_fm_constraint1.
  assert (Hval_sp : w29 = cl -ᵢ ($ (64 * Z.of_nat (length clfp1)))).
  {
    inversion Hpt_stk; subst; eauto.
  }

  (** restore *)
  hoare_lift_pre 4.
  unfold FrameState at 1.
  eapply backward_rule.
  introv Hs.
  asrt_to_line_in Hs 3.
  simpl_sep_liftn_in Hs 4.
  eapply sep_pure_l_elim in Hs.
  destruct Hs as [_ Hs].
  eauto.
  hoare_lift_pre 3.
  eapply Pure_intro_rule.
  introv Hlen_F'.
  hoare_lift_pre 2.
  hoare_lift_pre 3.
  do 2 (destruct F'; simpl in Hlen_F'; tryfalse).
  eapply seq_rule.
  TimReduce_simpl.
  eapply restore_rule_reg; eauto.
  simpl; eauto.
  unfold win_masked.
  destruct (((($ 1) <<ᵢ (post_cwp id)) &ᵢ (($ 1) <<ᵢ vi)) !=ᵢ ($ 0)) eqn:Heqe; tryfalse; eauto.
  unfold negb in Heqe.
  destruct (((($ 1) <<ᵢ (post_cwp id)) &ᵢ (($ 1) <<ᵢ vi)) =ᵢ ($ 0)) eqn:Heqe1; tryfalse.
  eapply int_eq_false_neq in Heqe1; eauto.
  eapply and_not_zero_eq in Heqe1; tryfalse.
  eapply in_range_0_7_post_cwp_still; eauto.
  eauto.
  simpl upd_genreg.
  subst w29.

  hoare_lift_pre 12.
  unfold stack at 1.
  eapply backward_rule.
  introv Hs.
  eapply stack'_split in Hs.
  simpl_sep_liftn_in Hs 2.
  unfold stack' in Hs; fold stack' in Hs.
  eapply astar_assoc_elim in Hs; eauto.
  omega.

  destruct fml', fmi'.
  destruct f, f0.
  hoare_lift_pre 4.

  (** st l0 (sp + OS_CPU_STACK_FRSME_L0_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_l0; eauto.
  simpl update_frame.

  (** st l1 (sp + OS_CPU_STACK_FRSME_L1_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_l1; eauto.
  simpl update_frame.

  (** st l2 (sp + OS_CPU_STACK_FRSME_L2_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_l2; eauto.
  simpl update_frame.

  (** st l3 (sp + OS_CPU_STACK_FRSME_L3_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_l3; eauto.
  simpl update_frame.

  (** st l4 (sp + OS_CPU_STACK_FRSME_L4_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_l4; eauto.
  simpl update_frame.

  (** st l5 (sp + OS_CPU_STACK_FRSME_L5_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_l5; eauto.
  simpl update_frame.

  (** st l6 (sp + OS_CPU_STACK_FRSME_L6_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_l6; eauto.
  simpl update_frame.

  (** st l7 (sp + OS_CPU_STACK_FRSME_L7_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_l7; eauto.
  simpl update_frame.

  (** st i0 (sp + OS_CPU_STACK_FRSME_I0_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_i0; eauto.
  simpl update_frame.

  (** st i1 (sp + OS_CPU_STACK_FRSME_I1_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_i1; eauto.
  simpl update_frame.

  (** st i2 (sp + OS_CPU_STACK_FRSME_I2_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_i2; eauto.
  simpl update_frame.

  (** st i3 (sp + OS_CPU_STACK_FRSME_i3_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_i3; eauto.
  simpl update_frame.

  (** st i4 (sp + OS_CPU_STACK_FRSME_I4_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_i4; eauto.
  simpl update_frame.

  (** st i5 (sp + OS_CPU_STACK_FRSME_I5_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_i5; eauto.
  simpl update_frame.

  (** st i6 (sp + OS_CPU_STACK_FRSME_I6_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_i6; eauto.
  simpl update_frame.

  (** st i7 (sp + OS_CPU_STACK_FRSME_I7_OFFSET) *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply st_rule_save_stk_i7; eauto.
  simpl update_frame.

  hoare_lift_pre 5.
  hoare_lift_pre 6.
  eapply backward_rule.
  introv Hs.
  eapply FrameState_combine in Hs; eauto.
  clear - Hlen_F'.
  rewrite app_length; simpl; omega.
  split; eauto.
  eapply in_range_0_7_post_cwp_still; eauto.

  (** jmpl Ta0_save_usedwindows g0; nop *)
  eapply J1_rule; eauto.
  {
    TimReduce_simpl.
    introv Hs.
    simpl.
    unfold Ta0_save_usedwindows at 1 2.
    unfold Ta0_save_usedwindows at 1 2.
    rewrite in_range228; eauto.
  }
  {
    eval_spec.
  }
  {
    TimReduce_simpl.
    introv Hs.
    simpl_sep_liftn_in Hs 2.
    eapply GenRegs_split_one with (rr := g0) in Hs; eauto.
  }
  {
    TimReduce_simpl.
    eapply nop_rule; eauto.
    introv Hs.
    eapply GenRegs_upd_combine_one in Hs; eauto.
    remember (cl -ᵢ ($ (64 * Z.of_nat (length clfp1)))) as w29'.
    simpl upd_genreg in Hs.
    subst w29'.
    unfold ta0_save_usedwindows_pre.
    sep_ex_intro.
    asrt_to_line 20.
    eapply sep_pure_l_intro; eauto.
    simpl_sep_liftn 2.
    eapply GenRegs_split_Regs_Global.
    sep_cancel1 1 1.
    sep_cancel1 1 1.
    sep_cancel1 6 1.
    sep_cancel1 5 1.
    sep_cancel1 4 1.
    do 5 sep_cancel1 4 1.
    sep_cancel1 4 2.
    sep_cancel1 4 2.
    match goal with
    | H : _ |= _ |- _ => renames H to Hs
    end.

    assert (Harth : (cl -ᵢ ($ (64 * Z.of_nat (length clfp1)))) -ᵢ ($ 64) =
                      cl -ᵢ ($ (64 * Z.of_nat (length clfp1 + 1)))).
    {
      repeat (rewrite Int.sub_add_opp).
      rewrite Int.add_assoc.
      rewrite <- Int.neg_add_distr.
      assert (Htrivil : ($ (64 * Z.of_nat (length clfp1))) +ᵢ ($ 64) =
                        $ (64 * Z.of_nat (length clfp1 + 1))).
      rewrite Int.add_unsigned.
      assert (Heq64 : Int.unsigned $ 64 = 64%Z).
      eauto.
      rewrite Heq64.
      rewrite Int.unsigned_repr.
      assert (Htrivil_eq : length clfp1 + 1 = S (length clfp1)).
      omega.
      rewrite Htrivil_eq.
      rewrite Nat2Z.inj_succ.
      unfold Z.succ.
      rewrite <- Zred_factor4.
      eauto.
      clear - Hlen_clfp1.
      unfold Int.max_unsigned, Int.modulus, two_power_nat.
      simpl shift_nat.
      omega.
      rewrite Htrivil.
      eauto.
    }

    simpl_sep_liftn_in Hs 3.
    eapply stack'_cons_tail in Hs; eauto.
    eapply stack'_app in Hs; eauto.
    sep_cancel1 1 1.
    instantiate (1 := Aemp).
    eapply astar_emp_intro_r; eauto.

    eapply sep_pure_l_intro; eauto.

    eapply sep_pure_l_intro.
    {
      instantiate (1 := F).
      instantiate (1 := fmo).
      instantiate (1 := oid).
      destruct Hstk_fm_match as [Hstk_fm_match Hlen_F].
      split; eauto.
      eapply stk_fm_match_cons_tail_stable; eauto.
      eapply rotate_hold_post_id_neq_oid; eauto.
      omega.
    }

    eapply sep_pure_l_intro.
    {
      instantiate (1 := fmi).
      instantiate (1 := fml).
      do 3 rewrite trivial_assoc_ls.
      eapply restore_cons; eauto.
      eapply rotate_hold_post_id_neq_oid; eauto.
    }

    eapply sep_pure_l_intro.
    {
      rewrite app_length.
      simpl length.
      rewrite Harth in Hstk_fm_constraint1.
      unfold stack_frame_constraint.
      unfold get_stk_addr.
      unfold get_stk_cont.
      remember (cl -ᵢ ($ (64 * Z.of_nat (length clfp1 + 1)))) as offset.
      simpl in Hstk_fm_constraint1.
      do 3 rewrite trivial_assoc_ls.
      assert
        (Htrivial :
          (([[w44, w45, w46, w47, w48, w49, w50, w51]])
             :: (([[w52, w53, w54, w55, w56, w57, w58, w59]]) :: F') ++
             ([[w7, w8, w9, w10, w11, w12, w13, w14]]) ::
             ([[w15, w16, w17, w18, w19, w20, w21, w22]]) :: nil) =
          (([[w44, w45, w46, w47, w48, w49, w50, w51]])
            :: ([[w52, w53, w54, w55, w56, w57, w58, w59]]) :: F' ++
          ([[w7, w8, w9, w10, w11, w12, w13, w14]]) :: nil) ++
          ([[w15, w16, w17, w18, w19, w20, w21, w22]]) :: nil
        ).
      rewrite trivial_assoc_ls2.
      eauto.
      rewrite Htrivial.
      rewrite <- app_assoc.
      eapply stk_fm_contraint_fm_app_stable; eauto.
    }

    instantiate (1 := Aemp).
    eapply sep_pure_l_intro; eauto.
    simpl get_frame_nth.
    split; eauto.
    split.
    eapply rotate_cons; eauto.
    split; eauto.
    split.
    eapply g4_rot_stable with (oid := oid); eauto.
    split; eauto.

    eapply sep_pure_l_intro; eauto.
    split; eauto.
    simpljoin1; eauto.
    instantiate (1 := cstk).
    clear - Hctx_win_save.
    destruct Hctx_win_save as [_ Hctx_pt_stk].
    unfolds ctx_pt_stk.
    simpls.
    destruct Hctx_pt_stk as [ [Hstk_len_gt_zero Hpt] Hostk_lfp_rl ].
    split; eauto.
    try rewrite app_length in *.
    rewrite app_length.
    simpls.
    simpljoin1.
    split; eauto.
    omega.

    clear - Hostk_lfp_rl.
    unfolds ostk_lfp_rl.
    destruct cstk.
    simpljoin1.
    exists (x ++ ([[w3, w6, w29, w31, w32, w33, w34, w35]],
             [[w36, w37, w38, w39, w40, w41, w42, w43]]) :: nil).
    repeat (split; eauto).
    rewrite <- app_assoc.
    simpl; eauto.

    match goal with
    | H : length clfp1 = length _ |- _ =>
      renames H to Hlen_clfp1
    end.
    clear - Hlen_clfp1.
    repeat rewrite app_length.
    simpl.
    rewrite Hlen_clfp1; eauto.

    clear - Hlen_clfp1.
    rewrite app_length.
    simpl.
    assert (Htrivial : length clfp1 + 1 + 0 = S (length clfp1)).
    omega.
    rewrite Htrivial.
    rewrite Nat2Z.inj_succ.
    unfold Z.succ.
    omega.

    rewrite Harth.
    rewrite app_length.
    simpl length.
    assert (Htrivial : length clfp1 + 1 + 0 = length clfp1 + 1).
    eauto.
    rewrite Htrivial.
    eauto.
    omega.
  }
  {
    introv Hs.
    unfold ta0_save_usedwindows_post in Hs.
    sep_ex_elim_in Hs.
    asrt_to_line_in Hs 17.
    sep_ex_intro.
    do 17 sep_cancel1 1 1.
    eapply astar_emp_elim_r; eauto.
  }

  DlyFrameFree_elim.
  eapply in_range_0_7_post_cwp_still; eauto.
  DlyFrameFree_elim.
Qed.