Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.lib.relation_list.
Require Import CertiGraph.msl_ext.log_normalize.
Require Import CertiGraph.msl_ext.iter_sepcon.
Require Import CertiGraph.msl_ext.ramification_lemmas.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.reachable_computable.
Require Import CertiGraph.graph.reachable_ind.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.dag.
Require Import CertiGraph.graph.weak_mark_lemmas.
Require Import CertiGraph.msl_application.Graph.
Require Import Coq.Logic.Classical.

Local Open Scope logic.

Section PointwiseGraph_Mark.

Context {V E: Type}.
Context {GV GE Pred: Type}.
Context {SGBA: PointwiseGraphBasicAssum V E}.
Context {SGC: PointwiseGraphConstructor V E bool unit unit GV GE}.
Context {L_SGC: Local_PointwiseGraphConstructor V E bool unit unit GV GE}.
Context {SGP: PointwiseGraphPred V E GV GE Pred}.
Context {SGA: PointwiseGraphAssum SGP}.

#[global] Instance MGS: WeakMarkGraph.MarkGraphSetting bool.
Proof.
  apply (WeakMarkGraph.Build_MarkGraphSetting _ (eq true)).
  intros; destruct x; [left | right]; congruence.
Defined.

Notation Graph := (LabeledGraph V E bool unit unit).
Notation SGraph := (PointwiseGraph V E GV GE).

Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Definition mark1 x (G1: Graph) (G2: Graph) := WeakMarkGraph.mark1 x G1 G2.
Definition mark x (G1: Graph) (G2: Graph) := WeakMarkGraph.mark x G1 G2 /\ G1 ~=~ G2.

Definition mark_list xs g1 g2 := relation_list (map mark xs) g1 g2.

Lemma mark_invalid_refl: forall (g: Graph) root, ~ vvalid g root -> mark root g g.
Proof.
  intros.
  split.
  + apply WeakMarkGraph.mark_invalid_refl; auto.
  + reflexivity.
Qed.

Lemma mark_marked_root_refl: forall (g: Graph) root, WeakMarkGraph.marked g root -> mark root g g.
Proof.
  intros.
  split.
  + apply WeakMarkGraph.mark_marked_root_refl; auto.
  + reflexivity.
Qed.

Lemma mark_list_eq: forall root xs g1 g2,
  mark_list xs g1 g2 ->
  WeakMarkGraph.componded_mark_list root xs g1 g2 /\ g1 ~=~ g2.
Proof.
  intros.
  change (mark_list xs g1 g2) with
    (relation_list (map (fun x => relation_conjunction (WeakMarkGraph.mark x) (respectful_relation pg_lg structurally_identical)) xs) g1 g2) in H.
  eapply relation_list_conjunction in H.
  rewrite relation_conjunction_iff in H.
  split.
  + destruct H as [? _].
    eapply relation_list_inclusion; [| exact H].
    intros ? _.
    clear.
    intros g1 g2 ?.
    exists g2; [| apply WeakMarkGraph.eq_do_nothing; auto].
    exists g1; [apply WeakMarkGraph.eq_do_nothing; auto |].
    auto.
  + eapply si_list.
    exact (proj2 H).
Qed.

Lemma mark1_mark_list_mark: forall root l (g g': Graph),
  vvalid g root ->
  (WeakMarkGraph.unmarked g) root ->
  step_list g root l ->
  relation_list (mark1 root :: mark_list l :: nil) g g' ->
  mark root g g'.
Proof.
  intros.
  destruct_relation_list g0 in H2.
  eapply (mark_list_eq root) in H2.
  destruct H2; simpl in H2.
  split.
  + eapply WeakMarkGraph.mark1_componded_mark_list_mark; eauto.
    split_relation_list (g :: g0 :: g0 :: g' :: nil); auto;
    apply WeakMarkGraph.eq_do_nothing; auto.
  + destruct H3 as [? _].
    rewrite H3; auto.
Qed.

Lemma mark_partial_labeled_graph_equiv: forall x (g g': Graph),
  mark x g g' ->
  ((predicate_partial_labeledgraph g (Complement _ (reachable g x))) ~=~
  (predicate_partial_labeledgraph g' (Complement _ (reachable g x))))%LabeledGraph.
Proof.
  intros.
  split; [| split].
  + destruct H.
    simpl;
    rewrite <- H0.
    reflexivity.
  + destruct H as [[? ?] _].
    simpl in *; intros.
    specialize (H0 v).
    assert (~ g |= x ~o~> v satisfying (WeakMarkGraph.unmarked g)).
    1: {
      destruct H1.
      intro; apply H3.
      apply reachable_by_is_reachable in H4; auto.
    }
    clear - H0 H3.
    destruct (vlabel g v), (vlabel g' v).
    - auto.
    - rewrite H0; auto.
    - symmetry; tauto.
    - auto.
  + intros; simpl.
    destruct (elabel g e), (elabel g' e); auto.
Qed.

Lemma root_stable_ramify: forall (g: Graph) (x: V) (gx: GV),
  vgamma (Graph_PointwiseGraph g) x = gx ->
  vvalid g x ->
  @derives Pred _
    (reachable_vertices_at x g)
    (vertex_at x gx * (vertex_at x gx -* reachable_vertices_at x g)).
Proof. apply va_reachable_root_stable_ramify. Qed.

Lemma root_update_ramify: forall (g: Graph) (x: V) (lx: bool) (gx gx': GV),
  vvalid g x ->
  vgamma (Graph_PointwiseGraph g) x = gx ->
  vgamma (Graph_PointwiseGraph (labeledgraph_vgen g x lx)) x = gx' ->
  Included (Intersection V (reachable g x) (Complement V (eq x))) (vguard g) ->
  Included (Intersection V (reachable g x) (Complement V (eq x))) (vguard (labeledgraph_vgen g x lx)) ->
  @derives Pred _
    (reachable_vertices_at x g)
    (vertex_at x gx *
      (vertex_at x gx' -* reachable_vertices_at x (labeledgraph_vgen g x lx))).
Proof. apply va_reachable_root_update_ramify. Qed.

(* TODO: remove this lemma? *)
Lemma exp_mark1: forall (g: Graph) (x: V) (lx: bool),
  WeakMarkGraph.label_marked lx ->
  @derives Pred _ (reachable_vertices_at x (labeledgraph_vgen g x lx)) (EX g': Graph, !! (mark1 x g g') && reachable_vertices_at x g').
Proof.
  intros.
  apply (exp_right (labeledgraph_vgen g x lx)).
  apply andp_right; [apply prop_right | auto].
  apply WeakMarkGraph.vertex_update_mark1; auto.
Qed.

Lemma mark_neighbor_ramify: forall {A} (g1: Graph) (g2: A -> Graph) x y,
  (forall (g: Graph) x y, reachable g x y \/ ~ reachable g x y) ->
  vvalid g1 x ->
  step g1 x y ->
  Included (Intersection V (reachable g1 x) (Complement V (reachable g1 y)))
     (vguard g1) ->
  (forall a, mark y g1 (g2 a) -> Included (Intersection V (reachable g1 x) (Complement V (reachable g1 y))) (vguard (g2 a))) ->
  @derives Pred _
    (reachable_vertices_at x g1)
    (reachable_vertices_at y g1 *
      (ALL a: A, !! mark y g1 (g2 a) -->
        (reachable_vertices_at y (g2 a) -*
         reachable_vertices_at x (g2 a)))).
Proof.
  intros.
  assert (Included (reachable g1 y) (reachable g1 x)).
  1: {
    hnf; unfold Ensembles.In; intros.
    apply step_reachable with y; auto.
  }
  apply vertices_at_ramif_xQ. eexists. split; [|split].
  + apply Ensemble_join_Intersection_Complement; auto.
  + intros. destruct H5 as [_ ?].
    rewrite <- H5; clear H5.
    apply Ensemble_join_Intersection_Complement; auto.
  + intros.
    apply GSG_PartialGraphPreserve; auto.
    - unfold Included, Ensembles.In; intros.
      rewrite Intersection_spec in H6; destruct H6 as [? _].
      apply reachable_foot_valid in H6; auto.
    - destruct H5.
      rewrite H6; clear H6.
      unfold Included, Ensembles.In; intros.
      rewrite Intersection_spec in H6; destruct H6 as [? _].
      apply reachable_foot_valid in H6; auto.
    - apply mark_partial_labeled_graph_equiv in H5.
      eapply si_stronger_partial_labeledgraph_simple; [| eassumption].
      unfold Included, Ensembles.In; intros.
      rewrite Intersection_spec in H6.
      tauto.
Qed.

Lemma mark_list_mark_ramify: forall {A} (g1 g2: Graph) (g3: A -> Graph) x l y l',
  (forall (g: Graph) x y, reachable g x y \/ ~ reachable g x y) ->
  vvalid g1 x ->
  step_list g1 x (l ++ y :: l') ->
  relation_list (mark1 x :: mark_list l :: nil) g1 g2 ->
  Included (Intersection V (reachable g2 x) (Complement V (reachable g2 y)))
     (vguard g2) ->
  (forall a, mark y g2 (g3 a) -> Included (Intersection V (reachable g2 x) (Complement V (reachable g2 y))) (vguard (g3 a))) ->
  @derives Pred _
    (reachable_vertices_at x g2)
    (reachable_vertices_at y g2 *
      (ALL a: A, !! mark y g2 (g3 a) -->
        (reachable_vertices_at y (g3 a) -*
         reachable_vertices_at x (g3 a)))).
Proof.
  intros.
  destruct_relation_list g1' in H2.
  destruct H5 as [? _].
  apply (mark_list_eq x) in H2.
  destruct H2 as [_ ?].
  rewrite <- H5 in H2; clear g1' H5.
  apply mark_neighbor_ramify; auto.
  + destruct H2. rewrite <- (H2 x). auto.
  + rewrite <- (step_si g1); auto. hnf in H1. rewrite <- H1.
    rewrite in_app_iff. right. apply in_eq.
Qed.

End PointwiseGraph_Mark.


(*  DEC 2.0 language specification.
   Paolo Torrini
   Universite' de Lille - CRIStAL-CNRS
*)

Require Import List.
Require Import Equality.
Require Import Eqdep.
Require Import PeanoNat.
Require Import Omega.
Require Import Eqdep FunctionalExtensionality Tactics.

Require Import AuxLibI1.
Require Import TypSpecI1.
Require Import ModTypI1.
Require Import LangSpecI1.
Require Import StaticSemI1.
Require Import DynamicSemI1.
Require Import WeakenI1.
Require Import UniqueTypI1.
Require Import DerivDynI1.
Require Import TransPrelimI1.
Require Import TSoundnessI1.
Require Import SReducI1.
Require Import DetermI1.
Require Import PreReflI1.
Require Import ReflectI1.

Import ListNotations.

Module PreInter (IdT: ModTyp) <: ModTyp.

Module ReflectL := Reflect IdT.
Export ReflectL.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Open Scope type_scope.

Lemma Eval_vls (ts : list VTyp) (vs : list Value) :
    Forall2T VTyping vs ts ->
    tlist2type (map (fun t : VTyp => sVTyp t) ts).
  intros.
  induction X.
  simpl.
  exact tt.
  simpl.
  split.
  inversion r; subst.
  destruct x.
  destruct v.
  exact v.
  exact IHX.
Defined.

(*******************************************************************)

Program Definition SOS_Exp
                   (fenv: funEnv) (env: valEnv)
                   (e: Exp) (t: VTyp) (s: W) (n: nat)
                   (k: SoundExp fenv env e t s n) :
                              sVTyp t * (W * nat) := _.

Next Obligation.
  intros.
  unfold SoundExp in k.
  destruct k.
  split.
  - unfold VTyping in *.
    rewrite <- v.
    exact (sValue x).
  - destruct s0.
    exact x0.
Defined.

Program Definition SOS_Exp1
                   (fenv: funEnv) (env: valEnv)
                   (e: Exp) (t: VTyp) (s: W) (n: nat)
                   (k: SoundExp fenv env e t s n) :
  sVTyp t * (W * nat) :=
  let (x, vt, s0) := k in
  (match vt in (_ = y0) return (sVTyp y0) with
   | eq_refl => sValue x
   end, projT1 s0).

Definition ExpEvalSOS_TRN (fenv: funEnv)
           (k1: FEnvWT fenv)
           (env: valEnv) (e: Exp) (t: VTyp)
           (k3: ExpTyping (funEnv2funTC fenv) (valEnv2valTC env) e t)
           (s: W) (n: nat) : (sVTyp t * (W * nat)) :=
  SOS_Exp1 fenv env e t s n
  (ExpSoundness fenv k1 (funEnv2funTC fenv) (valEnv2valTC env) e t k3
                eq_refl env eq_refl s n).

Program Definition SOS_Prms
                   (fenv: funEnv) (env: valEnv)
                   (ps: Prms) (pt: PTyp) (s: W) (n: nat)
                   (k: SoundPrms fenv env ps pt s n) :
                              PTyp_TRN pt * (W * nat) := _.
Next Obligation.
  intros.
  destruct pt.
  unfold SoundPrms in k.
  destruct k as [es k].
  destruct k as [vs k1 k2].
  unfold isValueList2T in k1.
  rewrite k1 in *.
  clear k1.
  clear es.
  destruct ps.
  destruct k2 as [k2 k3].
  destruct k3 as [s1 k3].
  unfold PTyp_TRN.
  unfold PTyp_ListTrans.

  split.

  eapply matchListsAux02_T with (vs:=vs) in k2.
  unfold vlsTyping in k2.
  eapply Eval_vls.
  exact k2.

  constructor.
  exact s1.
Defined.

Definition PrmsEvalSOS_TRN (fenv: funEnv)
           (k1: FEnvWT fenv)
           (env: valEnv) (ps: Prms) (pt: PTyp)
           (k3: PrmsTyping (funEnv2funTC fenv) (valEnv2valTC env) ps pt)
           (s: W) (n: nat) : (PTyp_TRN pt * (W * nat)) :=
  SOS_Prms fenv env ps pt s n
  (PrmsSoundness fenv k1 (funEnv2funTC fenv) (valEnv2valTC env) ps pt k3
                 eq_refl env eq_refl s n).

(**********************************************************************)

(* experiments *)

Program Definition noDupNil : @noDup Id Fun [] := _.
Next Obligation.
  constructor.
Defined.

Program Definition FEnvWTNil : FEnvWT [] := _.
Next Obligation.
  unfold FEnvWT.
  intros.
  unfold FunWT.
  inversion H0.
Defined.

Program Definition ExpT1 (n: nat) :
  ExpTyping [] [] (Val (existT ValueI Nat (Cst Nat n))) Nat := _.
Next Obligation.
  constructor.
  unfold VTyping.
  simpl.
  auto.
Defined.

Lemma ExpAgree
           (n: nat) :
   ExpEvalTRN nil FEnvWTNil noDupNil nil (Val (existT ValueI Nat (Cst Nat n))) Nat (ExpT1 n) =
      fun w => ExpEvalSOS_TRN nil FEnvWTNil nil (Val (existT ValueI Nat (Cst Nat n))) Nat (ExpT1 n) (fst w) (snd w).
Proof.
  eapply functional_extensionality_dep.
  intro w.
  destruct w.
  simpl in *.
  simpl.
  induction n0.
  compute.
  auto.
  compute.
  auto.
Defined.

Program Definition ExpT11 (T: Type) (C: CTyp T)
           (n: T) :
  ExpTyping [] [] (Val (existT ValueI (VT T C) (Cst (VT T C) n))) (VT T C) := _.
Next Obligation.
  constructor.
  unfold VTyping.
  simpl.
  auto.
Defined.

Lemma ExpAgree1
      (T: Type) (C: CTyp T) (n: T) :
  ExpEvalTRN nil FEnvWTNil noDupNil nil (Val (existT ValueI (VT T C)
            (Cst (VT T C) n))) (VT T C) (ExpT11 T C n) =
  fun w => ExpEvalSOS_TRN nil FEnvWTNil nil (Val (existT ValueI (VT T C)
       (Cst (VT T C) n))) (VT T C) (ExpT11 T C n) (fst w) (snd w).
Proof.
  eapply functional_extensionality_dep.
  intro w.
  destruct w.
  simpl in *.
  induction n0.
  compute.
  auto.
  compute.
  auto.
Defined.

Program Definition ExpT12 (T: Type) (C: CTyp T)
           (n: T) (fenv: funEnv) (env: valEnv) :
  ExpTyping (funEnv2funTC fenv) (valEnv2valTC env)
    (Val (existT ValueI (VT T C) (Cst (VT T C) n))) (VT T C) := _.
Next Obligation.
  constructor.
  unfold VTyping.
  simpl.
  auto.
Defined.

Lemma ExpAgree2 (fenv: funEnv)
           (k1: FEnvWT fenv) (k2: noDup fenv)
           (env: valEnv)
      (T: Type) (C: CTyp T) (n: T) :
  ExpEvalTRN fenv k1 k2 env (Val (existT ValueI (VT T C)
        (Cst (VT T C) n))) (VT T C) (ExpT12 T C n fenv env) =
  fun w => ExpEvalSOS_TRN fenv k1 env (Val (existT ValueI (VT T C)
    (Cst (VT T C) n))) (VT T C) (ExpT12 T C n fenv env) (fst w) (snd w).
Proof.
  eapply functional_extensionality_dep.
  intro w.
  destruct w.
  simpl in *.
  induction n0.
  induction fenv.
  compute.
  auto.
  compute.
  auto.
  induction fenv.
  compute.
  auto.
  compute.
  auto.
Defined.

Lemma ExpAgree2n (fenv: funEnv)
           (k1: FEnvWT fenv) (k2: noDup fenv)
           (env: valEnv)
      (T: Type) (C: CTyp T) (n: T) :
  ExpEvalTRN fenv k1 k2 env (Val (existT ValueI (VT T C)
      (Cst (VT T C) n))) (VT T C) (ExpT12 T C n fenv env) = ret n.
  eapply functional_extensionality_dep.
  intro w.
  destruct w.
  simpl in *.
  induction n0.
  induction fenv.
  compute.
  auto.
  compute.
  auto.
  induction fenv.
  compute.
  auto.
  compute.
  auto.
Defined.

Program Definition ExpT13 (T: Type) (C: CTyp T)
        (x: Id) (fenv: funEnv) (env: valEnv)
        (H: findE (valEnv2valTC env) x = Some (VT T C)) :
  ExpTyping (funEnv2funTC fenv) (valEnv2valTC env) (Var x)
            (VT T C) := _.
Next Obligation.
  constructor.
  exact H.
Defined.

Lemma xxxAA (env: valEnv) (i0: Id) : (if IdT.IdEqDec i0 i0
       then Some (VT nat (CInt nat eq_refl I32 Unsigned))
       else findE (valEnv2valTC env) i0) = Some (VT nat (CInt nat eq_refl I32 Unsigned)).
  destruct (IdT.IdEqDec i0 i0).
  reflexivity.
  intuition n.
Defined.

Lemma ExpSoundnessA_Val : forall (n: nat)
    (ftenv : funTC) (tenv : valTC) (v : Value)
    (t : VTyp) (v0 : VTyping v t),
   forall (fenv: funEnv) (env: valEnv)
           (k1: FEnvWT fenv),
   FEnvTyping fenv ftenv ->
   EnvTyping env tenv ->
   forall (s0 : W) (n0 : nat), n0 <= n -> SoundExp fenv env (Val v) t s0 n0.
    unfold SoundExp.
    intros.
    constructor 1 with (x:=v).
    assumption.
    constructor 1 with (x:=(s0,n0)).
    simpl.
    constructor.
Defined.

Lemma ExpSoundnessA1_Val : forall (n: nat)
    (ftenv : funTC) (tenv : valTC) (v : Value)
    (t : VTyp) (v0 : VTyping v t),
   forall (fenv: funEnv) (env: valEnv)
           (k1: FEnvWT fenv),
   FEnvTyping fenv ftenv ->
   EnvTyping env tenv ->
   forall (s : W), SoundExp fenv env (Val v) t s n.
    unfold SoundExp.
    intros.
    constructor 1 with (x:=v).
    assumption.
    constructor 1 with (x:=(s,n)).
    simpl.
    constructor.
Defined.

Lemma ExpDenotA_Val : forall (n: nat)
    (ftenv : funTC) (tenv : valTC) (v : Value)
    (t : VTyp) (v0 : VTyping v t),
   forall (fenv: funEnv) (env: valEnv) (k1: FEnvWT fenv),
   FEnvTyping fenv ftenv ->
   EnvTyping env tenv ->
  tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
    valTC_Trans (valEnv2valTC env) -> MM WW (sVTyp t).
     intros.
     inversion v0; subst.
     exact (ret (sValue v)).
Defined.

(**********************************************************************)

Lemma ExpSoundnessA_Var : forall (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (t : VTyp) (i : IdTyping tenv x t),
   forall (fenv: funEnv) (env: valEnv)
           (k1: FEnvWT fenv),
   FEnvTyping fenv ftenv ->
   EnvTyping env tenv ->
   forall (s0 : W) (n0 : nat), n0 <= n -> SoundExp fenv env (Var x) t s0 n0.
    unfold SoundExp.
    intros.
    inversion i; subst.
    inversion H0; subst.
    unfold EnvTyping in H0.
    eapply ExtRelVal2 with (f:=valueVTyp) (venv:=env) in H3.
    destruct H3.
    constructor 1 with (x:=x0).
    unfold VTyping.
    exact e0.
    constructor 1 with (x:=(s0,n0)).
    simpl.
    eapply StepIsEClos.
    constructor.
    assumption.
    assumption.
Defined.

Lemma ExpSoundnessB_Var : forall (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (t : VTyp) (i : IdTyping tenv x t),
   forall (fenv: funEnv) (env: valEnv)
           (k1: FEnvWT fenv),
   FEnvTyping fenv ftenv ->
   EnvTyping env tenv ->
   forall (s0 : W) (n0 : nat), n0 <= n -> SoundExp fenv env (Var x) t s0 n0.
  unfold SoundExp.
  intros.
  unfold IdTyping in i.
  unfold EnvrAssign in i.
  unfold EnvTyping in H0.
  unfold MatchEnvs in H0.
  rewrite H0 in i.
  clear H0.
  eapply ExtRelVal2 with (f:=valueVTyp) (venv:=env) in i.
  destruct i.
  constructor 1 with (x:=x0).
  unfold VTyping.
  exact e0.
  constructor 1 with (x:=(s0,n0)).
  simpl.
  eapply StepIsEClos.
  constructor.
  assumption.
  constructor.
Defined.

Lemma ExpDenotA_Var : forall (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (t : VTyp) (i : IdTyping tenv x t),
   forall (fenv: funEnv) (env: valEnv) (k1: FEnvWT fenv),
   FEnvTyping fenv ftenv ->
   EnvTyping env tenv ->
  tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
    valTC_Trans (valEnv2valTC env) -> MM WW (sVTyp t).
     intros.
     inversion i; subst.
     unfold MM.
     intro.
     split.
     inversion H0; subst.
     eapply (extract_from_valTC_TransB _ X0 x).
     exact H2.
     exact X1.
Defined.

Lemma ExpDenotB_Var : forall (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (t : VTyp) (i : IdTyping tenv x t),
   forall (fenv: funEnv) (env: valEnv) (k1: FEnvWT fenv),
   FEnvTyping fenv ftenv ->
   EnvTyping env tenv ->
  tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
    valTC_Trans (valEnv2valTC env) -> MM WW (sVTyp t).
  intros.
  unfold IdTyping in i.
  unfold EnvrAssign in i.
  unfold MM.
  intro.
  split.
  unfold EnvTyping in H0.
  unfold MatchEnvs in H0.
  rewrite H0 in i.
  clear H0.
  eapply (extract_from_valTC_TransB _ X0 x).
  exact i.
  exact X1.
Defined.

Lemma ExpSoundnessDenotC_Var : forall (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (t : VTyp) (i : IdTyping tenv x t),
   forall (fenv: funEnv) (env: valEnv)
           (k1: FEnvWT fenv),
   FEnvTyping fenv ftenv ->
   EnvTyping env tenv ->
   forall (s0 : W) (n0 : nat), n0 <= n ->
                   (SoundExp fenv env (Var x) t s0 n0 * sVTyp t).
  unfold SoundExp.
  intros.
  unfold IdTyping in i.
  unfold EnvrAssign in i.
  rename H into X.
  rename H0 into X0.
  rename H1 into H.
  unfold EnvTyping in X0.
  unfold MatchEnvs in X0.
  rewrite X0 in i.
  clear X0.
  eapply ExtRelVal2 with (f:=valueVTyp) (venv:=env) in i.
  destruct i.
  split.
  constructor 1 with (x:=x0).
  unfold VTyping.
  exact e0.
  constructor 1 with (x:=(s0,n0)).
  simpl.
  eapply StepIsEClos.
  constructor.
  assumption.
  unfold valueVTyp in e0.
  destruct x0.
  rewrite <- e0.
  simpl.
  destruct v.
  exact v.
  constructor.
Defined.

Lemma ExpSoundnessDenotE_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (v : Value)
    (t : VTyp) (i : IdTyping tenv x t) (mB: valueVTyp v = t)
    (fenv: funEnv) (env: valEnv) (mA: findE env x = Some v)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
                   (SoundExp fenv env (Var x) t s0 n0 * sVTyp t).
  unfold SoundExp.
  intros.
  unfold IdTyping in i.
  unfold EnvrAssign in i.
  unfold EnvTyping in m2.
  unfold MatchEnvs in m2.
  rewrite m2 in i.
  clear m2.
(*  eapply ExtRelVal2 with (f:=valueVTyp) (venv:=env) in e. *)
  split.
  constructor 1 with (x:=v).
  unfold VTyping.
  exact mB.
  constructor 1 with (x:=(s0,n0)).
  simpl.
  eapply StepIsEClos.
  constructor.
  assumption.
  unfold valueVTyp in mB.
  destruct v.
  rewrite <- mB.
  simpl.
  destruct v.
  exact v.
Defined.

Lemma ExpSoundnessDenotF_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (v : Value)
    (t : VTyp) (i : IdTyping tenv x t) (mB: valueVTyp v = t)
    (fenv: funEnv) (env: valEnv) (mA: findE env x = Some v)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
     sigT (fun I: SoundExp fenv env (Var x) t s0 n0 * sVTyp t =>
             SOS_Exp1 fenv env (Var x) t s0 n0 (fst I) = (snd I, (s0, n0))).
Proof.
  intros.
  econstructor 1 with (x:=ExpSoundnessDenotE_Var n ftenv tenv x v t i mB
                                            fenv env mA k1 m1 m2 s0 n0 m3).
  unfold SOS_Exp1.
  simpl.
  unfold valueVTyp in mB.
  destruct v.
  destruct v.
  compute.
  destruct mB.
  reflexivity.
Defined.

Lemma ExpSoundnessDenotG_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (v : Value)
    (t : VTyp) (mB: valueVTyp v = t)
    (fenv: funEnv) (env: valEnv) (mA: findE env x = Some v)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
                   (SoundExp fenv env (Var x) t s0 n0 * sVTyp t).
(*
  sigT (fun I: SoundExp fenv env (Var x) t s0 n0 * sVTyp t =>
             SOS_Exp1 fenv env (Var x) t s0 n0 (fst I) = (snd I, (s0, n0))).
*)
Proof.
  unfold SoundExp.
  intros.
  intros.
  assert (IdTyping tenv x t) as i.
  eapply (ExtRelTyp tenv x v t mB env m2 mA).
  unfold EnvTyping in m2.
  unfold MatchEnvs in m2.
  rewrite m2 in i.
  clear m2.
  split.
  constructor 1 with (x:=v).
  unfold VTyping.
  exact mB.
  constructor 1 with (x:=(s0,n0)).
  simpl.
  eapply StepIsEClos.
  constructor.
  assumption.
  unfold valueVTyp in mB.
  destruct v.
  rewrite <- mB.
  simpl.
  destruct v.
  exact v.
Defined.

Lemma ExpSoundnessDenotG1_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (v : Value)
    (t : VTyp) (mB: valueVTyp v = t)
    (fenv: funEnv) (env: valEnv) (mA: findE env x = Some v)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
                   (SoundExp fenv env (Var x) t s0 n0 * sVTyp t).
Proof.
  eapply (ExpSoundnessDenotE_Var n ftenv tenv x v t
                                 (ExtRelTyp tenv x v t mB env m2 mA)
                                 mB fenv env mA k1 m1 m2 s0 n0 m3).
Defined.

Lemma ExpSoundnessDenotH_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id) (t: VTyp)
    (i : IdTyping tenv x t) (*mB: valueVTyp v = t*)
    (fenv: funEnv) (env: valEnv) (*mA: findE env x = Some v*)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
     sigT (fun I: SoundExp fenv env (Var x) t s0 n0 * sVTyp t =>
             SOS_Exp1 fenv env (Var x) t s0 n0 (fst I) = (snd I, (s0, n0))).
Proof.
  intros.
  unfold EnvTyping in m2.
  econstructor 1 with (x:=ExpSoundnessDenotG1_Var n ftenv tenv x
       (*v*)(ExtRelVal2A_1 valueVTyp tenv env x t m2 i) t
       (*mB*)(ExtRelVal2A_4 valueVTyp tenv env x t m2 i)
        fenv env
       (*mA*)(ExtRelVal2A_2 valueVTyp tenv env x t m2 i)
        k1 m1 m2 s0 n0 m3).
  unfold ExpSoundnessDenotG1_Var.
  unfold SOS_Exp1.
  simpl.
  remember (ExtRelVal2A valueVTyp tenv env x t m2 i) as K.
  destruct K as [v mA mB].
  unfold ExtRelVal2A_1.
  unfold ExtRelVal2A_4.
  unfold ExtRelVal2A_2.
  rewrite <- HeqK.

  unfold valueVTyp.
  destruct v.
  destruct v.
  compute.
  destruct mB.
  reflexivity.
Defined.

Definition FunEnvTRN2 (fenv : funEnv) (k1: FEnvWT fenv) (k2: noDup fenv)
  (n: nat) : tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) :=
  FunEnvTRN fenv k1 k2 n.

Lemma ExpDenotI_Var'
  (ftenv : funTC)
  (tenv : valTC)
  (x : Id)
  (t : VTyp)
  (i :  IdTyping tenv x t)
  (v: Value)
  (mB : valueVTyp v = t) :
  tlist2type (map snd (FunTC_ListTrans ftenv)) ->
  valTC_Trans tenv -> MM WW (sVTyp t).
  unfold valueVTyp in mB.
  destruct v.
(**)
  destruct x0.
  destruct v.
  simpl in *.
  inversion mB; subst.
  clear H.
  intros.
  unfold MM.
  intro.
  simpl.
  exact (v,X1).
Defined.
(**)

Lemma ExpDenotI_Var''
  (ftenv : funTC)
  (tenv : valTC)
  (x : Id)
  (t : VTyp)
  (i :  IdTyping tenv x t)
  (v: Value)
  (mB : valueVTyp v = t) :
  tlist2type (map snd (FunTC_ListTrans ftenv)) ->
  valTC_Trans tenv -> MM WW (sVTyp t).
  unfold valueVTyp in mB.
  destruct v.

  rewrite <- mB.
  simpl.
  destruct v.
  unfold MM.
  intros.
  exact (v, X1).
Defined.

Lemma ExpDenotI_VarS
  (tenv : valTC)
  (x : Id)
  (t : VTyp)
  (i :  IdTyping tenv x t)
  (v: Value)
  (mB : valueVTyp v = t) : MM WW (sVTyp t).
  unfold valueVTyp in mB.
  destruct v.
(**)
  destruct x0.
  destruct v.
  simpl in *.
  inversion mB; subst.
  clear H.
  intros.
  unfold MM.
  intro.
  simpl.
  exact (v,X).
Defined.

Program Fixpoint ValEnvTRN2 (tenv: valTC) (env: valEnv)
        (k: EnvTyping env tenv) :
  valTC_Trans tenv := _.
Next Obligation.
  intros.
  inversion k; subst.
  eapply ValEnvTRN.
Defined.

Lemma valenvtrn_eq (env: valEnv) :
    ((ValEnvTRN2 (map (thicken StaticSemL.Id valueVTyp) env) env
                      eq_refl) = ValEnvTRN env).
  induction env.
  simpl.
  unfold eq_rect_r.
  rewrite <- eq_rect_eq.
  rewrite <- eq_rect_eq.
  reflexivity.
  simpl.
  unfold eq_rect_r.
  rewrite <- eq_rect_eq.
  rewrite <- eq_rect_eq.
  reflexivity.
Defined.

(***** interesting for the proof *********************)
Lemma compare_den_var
  (tenv : valTC)
  (x : Id)
  (t : VTyp)
  (i :  IdTyping tenv x t)
  (v: Value)
  (env: valEnv)
  (k: EnvTyping env tenv)
  (mB : valueVTyp v = t)
  (mA: findE env x = Some v)
  (senv: valTC_Trans tenv)
  (k1: senv = ValEnvTRN2 tenv env k)
   :
  (ExpDenI_Var tenv x t i) senv = ExpDenotI_VarS tenv x t i v mB.
  destruct t.
  destruct v.
  destruct v.
  destruct x0.
  simpl in v.
  simpl in mB.
  inversion mB; subst.
  inversion k; subst.
  simpl in *.
  dependent destruction mB.
  simpl.
  unfold ExpDenI_Var.
  eapply functional_extensionality_dep.
  intro.
  unfold IdTyping in i.
  unfold EnvrAssign in i.
  dependent induction env.
  inversion mA.
  destruct a.
  simpl in mA.
  simpl in i.
  revert mA.
  revert i.
  simpl.
  destruct (IdT.IdEqDec x i0).
  intros.
  inversion i; subst.
  inversion mA; subst.
  simpl in i.
  simpl in H0.
  clear H0.
  clear mA.
  dependent destruction i.
  unfold eq_rect_r.
  rewrite <- eq_rect_eq.
  rewrite <- eq_rect_eq.
  rewrite <- eq_rect_eq.
  f_equal.
  unfold ValEnvTRN2_obligation_1.
  unfold EnvTyping in k.
  unfold MatchEnvs in k.
  dependent destruction k.
  unfold eq_rect_r.
  rewrite <- eq_rect_eq.
  rewrite <- eq_rect_eq.
  simpl.
  reflexivity.

(**)

  unfold EnvTyping in k.
  unfold MatchEnvs in k.
  dependent destruction k.
  intros.
  unfold ValEnvTRN2_obligation_1.
  unfold eq_rect_r.
  rewrite <- eq_rect_eq.
  rewrite <- eq_rect_eq.
  simpl.
  specialize (IHenv eq_refl i v mA eq_refl x1).
  rewrite valenvtrn_eq in IHenv.
  exact IHenv.
Defined.

(* senv not really used *)
Lemma ExpSoundnessDenotI_Var' (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (v : Value)
    (t : VTyp) (i : IdTyping tenv x t) (mB: valueVTyp v = t)
    (fenv: funEnv) (env: valEnv) (mA: findE env x = Some v)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  (SoundExp fenv env (Var x) t s0 n0 *
   (tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
    (* senv: *) valTC_Trans (valEnv2valTC env) ->
    MM WW (sVTyp t))).
  unfold SoundExp.
  intros.
  unfold IdTyping in i.
  unfold EnvrAssign in i.
  unfold EnvTyping in m2.
  unfold MatchEnvs in m2.
  rewrite m2 in i.
  clear m2.
(*  eapply ExtRelVal2 with (f:=valueVTyp) (venv:=env) in e. *)
  split.
  constructor 1 with (x:=v).
  unfold VTyping.
  exact mB.
  constructor 1 with (x:=(s0,n0)).
  simpl.
  eapply StepIsEClos.
  constructor.
  assumption.
  intros.
  eapply ExpDenotI_VarS.
  exact i.
  exact mB.
Defined.

Lemma ExpSoundnessDenotI_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (v : Value)
    (t : VTyp) (i : IdTyping tenv x t) (mB: valueVTyp v = t)
    (fenv: funEnv) (env: valEnv) (mA: findE env x = Some v)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  (SoundExp fenv env (Var x) t s0 n0 *
   (tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
                valTC_Trans (valEnv2valTC env) -> MM WW (sVTyp t))).
  unfold SoundExp.
  intros.
  unfold IdTyping in i.
  unfold EnvrAssign in i.
  unfold EnvTyping in m2.
  unfold MatchEnvs in m2.
  rewrite m2 in i.
  clear m2.
(*  eapply ExtRelVal2 with (f:=valueVTyp) (venv:=env) in e. *)
  split.
  constructor 1 with (x:=v).
  unfold VTyping.
  exact mB.
  constructor 1 with (x:=(s0,n0)).
  simpl.
  eapply StepIsEClos.
  constructor.
  assumption.
  eapply ExpDenotI_Var.
  exact i.
Defined.

Lemma ExpSoundnessDenotI1_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (v : Value)
    (t : VTyp) (mB: valueVTyp v = t)
    (fenv: funEnv) (env: valEnv) (mA: findE env x = Some v)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  (SoundExp fenv env (Var x) t s0 n0 *
   (tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
                valTC_Trans (valEnv2valTC env) -> MM WW (sVTyp t))).
Proof.
  eapply (ExpSoundnessDenotI_Var n ftenv tenv x v t
                                 (ExtRelTyp tenv x v t mB env m2 mA)
                                 mB fenv env mA k1 m1 m2 s0 n0 m3).
Defined.

Lemma ExpSoundnessDenotI1_Var' (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (v : Value)
    (t : VTyp) (mB: valueVTyp v = t)
    (fenv: funEnv) (env: valEnv) (mA: findE env x = Some v)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  (SoundExp fenv env (Var x) t s0 n0 *
   (tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
                valTC_Trans (valEnv2valTC env) -> MM WW (sVTyp t))).
Proof.
  eapply (ExpSoundnessDenotI_Var' n ftenv tenv x v t
                                 (ExtRelTyp tenv x v t mB env m2 mA)
                                 mB fenv env mA k1 m1 m2 s0 n0 m3).
Defined.

Lemma ExpSoundnessDenotJ_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id) (t: VTyp)
    (i : IdTyping tenv x t) (*mB: valueVTyp v = t*)
    (fenv: funEnv) (env: valEnv) (*mA: findE env x = Some v*)
    (k1: FEnvWT fenv)
    (k2: noDup fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  sigT (fun I: SoundExp fenv env (Var x) t s0 n0 *
      (tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
         valTC_Trans (valEnv2valTC env) -> MM WW (sVTyp t)) =>
          SOS_Exp1 fenv env (Var x) t s0 n0 (fst I) =
          (snd I) (FunEnvTRN2 fenv k1 k2 n) (ValEnvTRN env) (s0, n0)).
Proof.
  intros.
  unfold EnvTyping in m2.
  econstructor 1 with (x:=ExpSoundnessDenotI1_Var' n ftenv tenv x
       (*v*)(ExtRelVal2A_1 valueVTyp tenv env x t m2 i) t
       (*mB*)(ExtRelVal2A_4 valueVTyp tenv env x t m2 i)
        fenv env
       (*mA*)(ExtRelVal2A_2 valueVTyp tenv env x t m2 i)
        k1 m1 m2 s0 n0 m3).
  unfold ExpSoundnessDenotG1_Var.
(*  destruct i as [tenv x t i]. *)
  unfold SOS_Exp1.
  simpl.
  remember (ExtRelVal2A valueVTyp tenv env x t m2 i) as K.
  destruct K as [v mA mB].
  unfold ExtRelVal2A_1.
  unfold ExtRelVal2A_4.
  unfold ExtRelVal2A_2.
  rewrite <- HeqK.

  unfold valueVTyp.
  destruct v.
  destruct v.

  unfold MatchEnvs in m2.
  unfold FEnvTyping in m1.
  unfold MatchEnvs in m1.
  inversion m1; subst.
  clear H.
  simpl in mA.
  destruct x0.
  unfold IdTyping in i.
  unfold EnvrAssign in i.
  simpl in v.
  compute.
  reflexivity.
Defined.

Lemma ExpSoundnessDenotI2_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (v : Value)
    (t : VTyp) (i : IdTyping tenv x t) (mB: valueVTyp v = t)
    (fenv: funEnv) (env: valEnv) (mA: findE env x = Some v)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  (SoundExp fenv env (Var x) t s0 n0 *
   (valTC_Trans (valEnv2valTC env) -> nat -> W -> (sVTyp t * WW))).
  unfold SoundExp.
  intros.
  unfold IdTyping in i.
  unfold EnvrAssign in i.
  unfold EnvTyping in m2.
  unfold MatchEnvs in m2.
  rewrite m2 in i.
  clear m2.
(*  eapply ExtRelVal2 with (f:=valueVTyp) (venv:=env) in e. *)
  split.
  constructor 1 with (x:=v).
  unfold VTyping.
  exact mB.
  constructor 1 with (x:=(s0,n0)).
  simpl.
  eapply StepIsEClos.
  constructor.
  assumption.
  intros.
  eapply ExpDenotI_VarS.
  exact i.
  exact mB.
  exact (s0,n0).
Defined.

Lemma ExpSoundnessDenotI2_VarA (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (v : Value)
    (t : VTyp) (mB: valueVTyp v = t)
    (fenv: funEnv) (env: valEnv) (mA: findE env x = Some v)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  (SoundExp fenv env (Var x) t s0 n0 *
   (valTC_Trans (valEnv2valTC env) -> nat -> W -> (sVTyp t * WW))).
Proof.
  eapply (ExpSoundnessDenotI2_Var n ftenv tenv x v t
                                 (ExtRelTyp tenv x v t mB env m2 mA)
                                 mB fenv env mA k1 m1 m2 s0 n0 m3).
Defined.

Lemma ExpSoundnessDenotJ2_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id) (t: VTyp)
    (i : IdTyping tenv x t) (*mB: valueVTyp v = t*)
    (fenv: funEnv) (env: valEnv) (*mA: findE env x = Some v*)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  sigT (fun I: SoundExp fenv env (Var x) t s0 n0 *
      (valTC_Trans (valEnv2valTC env) -> nat -> W -> (sVTyp t * WW)) =>
          SOS_Exp1 fenv env (Var x) t s0 n0 (fst I) =
          (snd I) (ValEnvTRN env) n0 s0).
Proof.
  intros.
(*  destruct i as [tenv x t i]. *)
  unfold EnvTyping in m2.
  econstructor 1 with (x:=ExpSoundnessDenotI2_VarA n ftenv tenv x
       (*v*)(ExtRelVal2A_1 valueVTyp tenv env x t m2 i) t
       (*mB*)(ExtRelVal2A_4 valueVTyp tenv env x t m2 i)
        fenv env
       (*mA*)(ExtRelVal2A_2 valueVTyp tenv env x t m2 i)
        k1 m1 m2 s0 n0 m3).
(*  destruct i as [tenv x t i]. *)
  unfold SOS_Exp1.
  simpl.
  remember (ExtRelVal2A valueVTyp tenv env x t m2 i) as K.
  destruct K as [v mA mB].
  unfold ExtRelVal2A_1.
  unfold ExtRelVal2A_4.
  unfold ExtRelVal2A_2.
  rewrite <- HeqK.

  unfold valueVTyp.
  destruct v.
  destruct v.

  unfold MatchEnvs in m2.
  unfold FEnvTyping in m1.
  unfold MatchEnvs in m1.
  inversion m1; subst.
  clear H.
  simpl in mA.
  destruct x0.
  unfold IdTyping in i.
  unfold EnvrAssign in i.
  simpl in v.
  compute.
  reflexivity.
Defined.

Definition ExpSoundnessJ2_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (t : VTyp) (i : IdTyping tenv x t)
    (fenv: funEnv) (env: valEnv)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  SoundExp fenv env (Var x) t s0 n0 := fst (projT1
  (ExpSoundnessDenotJ2_Var n ftenv tenv x t i fenv env k1 m1 m2 s0 n0 m3)).

Definition ExpDenotJ2_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (t : VTyp) (i : IdTyping tenv x t)
    (fenv: funEnv) (env: valEnv)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  valTC_Trans (valEnv2valTC env) -> nat -> W -> (sVTyp t * WW) :=
  snd (projT1
  (ExpSoundnessDenotJ2_Var n ftenv tenv x t i fenv env k1 m1 m2 s0 n0 m3)).

(***************************************************************
******************************************************************)

Definition ExpSoundnessH_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (t : VTyp) (i : IdTyping tenv x t)
    (fenv: funEnv) (env: valEnv)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  SoundExp fenv env (Var x) t s0 n0 := fst (projT1
  (ExpSoundnessDenotH_Var n ftenv tenv x t i fenv env k1 m1 m2 s0 n0 m3)).

Definition ExpDenotH_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (t : VTyp) (i : IdTyping tenv x t)
    (fenv: funEnv) (env: valEnv)
    (k1: FEnvWT fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
  valTC_Trans (valEnv2valTC env) -> MM WW (sVTyp t) :=
  fun stf sf s => (snd (projT1
  (ExpSoundnessDenotH_Var n ftenv tenv x t i fenv env k1 m1 m2 s0 n0 m3)), s).

Definition ExpSoundnessJ_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (t : VTyp) (i : IdTyping tenv x t)
    (fenv: funEnv) (env: valEnv)
    (k1: FEnvWT fenv)
    (k2: noDup fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  SoundExp fenv env (Var x) t s0 n0 := fst (projT1
  (ExpSoundnessDenotJ_Var n ftenv tenv x t i fenv env k1 k2 m1 m2 s0 n0 m3)).

Definition ExpDenotJ_Var (n: nat)
    (ftenv : funTC) (tenv : valTC) (x : Id)
    (t : VTyp) (i : IdTyping tenv x t)
    (fenv: funEnv) (env: valEnv)
    (k1: FEnvWT fenv)
    (k2: noDup fenv)
    (m1: FEnvTyping fenv ftenv)
    (m2: EnvTyping env tenv)
    (s0 : W) (n0 : nat) (m3: n0 <= n) :
  tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
  valTC_Trans (valEnv2valTC env) -> MM WW (sVTyp t) :=
  snd (projT1
  (ExpSoundnessDenotJ_Var n ftenv tenv x t i fenv env k1 k2 m1 m2 s0 n0 m3)).

Lemma PushOutForAll1 (ftenv : funTC) (tenv : valTC)
  (e : Exp)
  (t : VTyp)
  (m : ExpTyping ftenv tenv e t)
  (fenv : funEnv)
  (env : valEnv)
  (k1: FEnvWT fenv)
  (k2: noDup fenv)
  (m1: FEnvTyping fenv ftenv)
  (m2: EnvTyping env tenv)
  (n: nat) :
  {I1 : forall (s : W) (n0 : nat), n0 <= n -> SoundExp fenv env e t s n0
      &
      {I2
      : tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
        valTC_Trans (valEnv2valTC env) -> MM WW (sVTyp t) &
      {FE : nat -> tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv)))
      &
      forall (s : W) (n0 : nat) (q : n0 <= n),
      SOS_Exp1 fenv env e t s n0 (I1 s n0 q) =
      I2 (FE n0) (ValEnvTRN env) (s, n0)}}} ->
 forall (s : W) (n0 : nat), n0 <= n ->
  {I3 : SoundExp fenv env e t s n0
      &
      {I4
      : tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
        valTC_Trans (valEnv2valTC env) -> MM WW (sVTyp t) &
      {FE : nat -> tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv)))
      &
      SOS_Exp1 fenv env e t s n0 I3 =
      I4 (FE n0) (ValEnvTRN env) (s, n0)}}}.
  intros.
  destruct X as [k4 X].
  destruct X as [k5 X].
  destruct X as [k6 X].
  econstructor 1 with (x:=k4 s n0 H).
  econstructor 1 with (x:=k5).
  econstructor 1 with (x:=k6).
  specialize (X s n0 H).
  eapply X.
Defined.

Lemma PushOutForAll1aux (ftenv : funTC) (tenv : valTC)
  (e : Exp)
  (t : VTyp)
  (m : ExpTyping ftenv tenv e t)
  (fenv : funEnv)
  (env : valEnv)
  (k1: FEnvWT fenv)
  (k2: noDup fenv)
  (m1: FEnvTyping fenv ftenv)
  (m2: EnvTyping env tenv)
  (n: nat) :
( {I1 : forall (s0 : W) (n1 : nat), n1 <= n -> SoundExp fenv env e t s0 n1
      &
      {I2
      : tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
        valTC_Trans (valEnv2valTC env) -> MM WW (sVTyp t) &
      {FE : nat -> tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv)))
      &
      forall (s : W) (n1 : nat) (q : n1 <= n),
      SOS_Exp1 fenv env e t s n1 (I1 s n1 q) =
      I2 (FE n1) (ValEnvTRN env) (s, n1)}}}) ->

  {I1 : forall (s : W) (n0 : nat), n0 <= n -> SoundExp fenv env e t s n0
      &
      {I2
      : tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) ->
        valTC_Trans (valEnv2valTC env) -> MM WW (sVTyp t) &
      {FE : nat -> tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv)))
      &
      forall (s: W) (n0 : nat) (q : n0 <= n),
      SOS_Exp1 fenv env e t s n0 (I1 s n0 q) =
      I2 (FE n0) (ValEnvTRN env) (s, n0)}}}.
  intros.
  destruct X as [k4 X].
  destruct X as [k5 X].
  destruct X as [k6 X].
  econstructor 1 with (x:=k4).
  econstructor 1 with (x:=k5).
  econstructor 1 with (x:=k6).
  intros.
  eapply X.
Defined.

(************************************************************************)

Program Definition preSucc_Y
    (fenv: funEnv)
    (ET : forall (tenv: valTC) (e: Exp) (t: VTyp)
          (k: ExpTyping (funEnv2funTC fenv) tenv e t)
  (sfenv: nat -> tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv)))),      (valTC_Trans tenv -> MM WW (sVTyp t)))

    (k: FEnvWT fenv) (x: Id) (f: Fun) :
  findE fenv x = Some f ->
  forall (sfenv: nat -> tlist2type
                   (map snd (FunTC_ListTrans (funEnv2funTC fenv)))),
  FunTyp_TRN f := _.
Next Obligation.
  intros.
  set (tenv := funValTC f).
  set (e := funSExp f).
  set (t := funVTyp f).
  set (ftenv := funEnv2funTC fenv).

  assert (ExpTyping ftenv tenv e t) as k1.
  unfold FEnvWT in k.
  specialize (k ftenv eq_refl x f H).
  unfold FunWT in k.
  destruct f.
  subst e.
  subst t.
  subst tenv.
  simpl in *.
  exact k.

  unfold FunTyp_TRN.
  unfold FTyp_TRN2.
  unfold FType_mk2.

(* apply ET (the translation) to e (the function body) in shallow
   environment sfenv *)
  specialize (ET tenv e t k1 sfenv).
  unfold valTC_Trans in ET.
  unfold VTList_Trans in ET.
  destruct f.
  subst tenv e t.
  simpl in *.
  intro.
  specialize (ET X).
  exact ET.
Defined.

Program Definition ZeroTRN4 (ftenv: funTC) (fenv: funEnv)
        (m: FEnvTyping fenv ftenv) :
  tlist2type (map snd (FunTC_ListTrans ftenv)) := _.
Next Obligation.
  intros.
  inversion m; subst.
  rewrite <- FunEnv_Trans_lemma.
  eapply ZeroTRN1.
Defined.

Program Definition preSucc_Z
        (ftenv: funTC) (fenv: funEnv)
        (m: FEnvTyping fenv ftenv)
    (ET : forall (tenv: valTC) (e: Exp) (t: VTyp)
          (k: ExpTyping ftenv tenv e t)
          (sfenv: nat -> tlist2type (map snd (FunTC_ListTrans ftenv))),
        (valTC_Trans tenv -> MM WW (sVTyp t)))

    (k: FEnvWT fenv) (x: Id) (f: Fun) :
  findE fenv x = Some f ->
  forall (sfenv: nat -> tlist2type
                   (map snd (FunTC_ListTrans (funEnv2funTC fenv)))),
  FunTyp_TRN f := _.
Next Obligation.
  intros.
  inversion m; subst.
  eapply preSucc_Y.
  eassumption.
  assumption.
  eassumption.
  assumption.
Defined.

End PreInter.


From ITree Require Import ITree.
From compcert Require Import Maps AST Values Memory Globalenvs Ctypes.
From compcert Require Coqlib Clight Clightdefs.
From Paco Require Import paco.

Require Import Arith ZArith Bool.
Require Import String List Lia.

Require Import sflib.
Require Import Axioms StdlibExt IntegersExt ITreeTac.

Require Import SysSem.
Require Import IPModel DiscreteTimeModel IntByteModel.
Require Import OSModel OSNodes.
Require Import ProgSem CProgEventSem.
Require Import ProgSim CProgSimLemmas.
Require Import RTSysEnv MWITree.

(* Require Import SystemParams. *)
(* Require Import SystemDefs ITreeSpec. *)
(* Require Import SystemEventSem. *)
Require Import config_prm main_prm SystemProgs.
Require Import ctrl.
Require Import VerifProgBase.
Require Import VerifMainUtil.
Require Import PALSSystem.

Require Import AcStSystem.
Require Import LinkController.
Require Import SpecController.

Import Clight Clightdefs.
Import ITreeNotations.
Import ActiveStandby.

Import CtrlState.

Set Nested Proofs Allowed.
(* Arguments app : simpl nomatch. *)
Local Transparent Archi.ptr64.
Local Opaque Z.of_nat Z.to_nat.

(* Arguments Nat.mul: simpl never. *)
Arguments Nat.mul: simpl never.

Opaque globalenv.

Local Open Scope Z.

Definition ctrl_gvar_ids := map fst ctrl_gvar_ilist.
Definition ctrl_gfun_ids := map fst ctrl_gfun_ilist.
Definition ctrl_cenv_ids := map fst ctrl_cenv_ilist.

Lemma range_qrange_sanitize_prec i
  : 0 <= qrange_sanitize i < 4.
Proof.
  unfold qrange_sanitize.
  destruct (Z.leb_spec 0 i);
    destruct (Z.ltb_spec i QSIZE); ss.
Qed.

Lemma range_adv_qidx_prec i
  : 0 <= adv_qidx i < 4.
Proof.
  apply range_qrange_sanitize_prec.
Qed.

Lemma set_queue_mem
      c e q q' m m' b ofs
      (MEM_Q: Mem.loadbytes m b ofs 4 =
              Some (inj_bytes (map Byte.repr q)))
      (RANGE_C: 0 <= c < 4)
      (RANGE_E: IntRange.sintz8 e)
      (SET_Q: q' = set_queue c e q)
      (STORE: Mem.store Mint8signed m b (ofs + c)
                        (Vint (Int.repr e)) = Some m')
  : Mem.loadbytes m' b ofs 4 =
    Some (inj_bytes (map Byte.repr q')).
Proof.

  assert (LEN_Q: length q = 4%nat).
  { apply Mem.loadbytes_length in MEM_Q.
    unfold inj_bytes in MEM_Q.
    do 2 rewrite map_length in MEM_Q. nia. }

  assert (CN: exists cn, Z.of_nat cn = c).
  { exists (Z.to_nat c). nia. }
  des.

  assert (q' = firstn cn q ++ [e] ++ skipn (S cn) q).
  { unfold set_queue in *.
    generalize (replace_nth_spec _ q cn e).
    i. des.
    { exfalso. nia. }

    cut (firstn cn q = l1 /\ skipn (S cn) q = l2).
    { i. des. subst.
      rewrite firstn_app_exact by ss.
      replace (l1 ++ [p] ++ l2) with ((l1 ++ [p]) ++ l2).
      2: { rewrite app_assoc. ss. }

      rewrite skipn_app_exact.
      2: { rewrite app_length. ss. nia. }
      rewrite Nat2Z.id.
      rewrite <- app_assoc. ss.
    }
    split.
    - subst.
      rewrite firstn_app_exact; ss.
    - subst.
      replace (l1 ++ [p] ++ l2) with ((l1 ++ [p]) ++ l2).
      2: { rewrite app_assoc. ss. }
      rewrite skipn_app_exact.
      2: { rewrite app_length. ss. nia. }
      ss.
  }
  clear SET_Q.
  subst q'.

  rename MEM_Q into LBS.
  replace 4 with (c + (1 + (3 - c))) in * by nia.
  eapply Mem.loadbytes_split in LBS; try nia.
  destruct LBS as (mvs1 & mvs2 & LBS1 & LBS2 & MVS_EQ).

  assert (LEN_BS1: length mvs1 = cn).
  { apply Mem.loadbytes_length in LBS1.
    rewrite LBS1. nia. }

  rewrite <- firstn_skipn with (l:= q) (n:=cn) in MVS_EQ.
  unfold inj_bytes in MVS_EQ.
  rewrite map_app in MVS_EQ.
  rewrite map_app in MVS_EQ.
  apply app_eqlen_inv in MVS_EQ.
  2: { do 2 rewrite map_length.
       rewrite firstn_length_le by nia.
       ss. }

  destruct MVS_EQ as (MVS_EQ1 & MVS_EQ2).

  unfold inj_bytes.
  do 2 rewrite map_app.
  apply Mem.loadbytes_concat; try nia.
  { rewrite MVS_EQ1.
    eapply Mem.loadbytes_unchanged_on; eauto.
    { eapply store_unchanged_on'; eauto. }
    unfold mem_range.
    ii. des; ss. nia.
  }
  clear mvs1 LBS1 MVS_EQ1 LEN_BS1.

  (**)
  eapply Mem.loadbytes_split in LBS2; try nia.
  destruct LBS2 as (mvs3 & mvs4 & LBS3 & LBS4 & MVS_EQ').

  assert (LEN_MVSS3: length mvs3 = 1%nat).
  { apply Mem.loadbytes_length in LBS3.
    rewrite LBS3. nia. }

  subst mvs2.

  assert (DIV_SKIPN: exists x, skipn cn q = x :: skipn (S cn) q).
  { destruct (skipn cn q) as [| h t] eqn: DES.
    { exfalso.
      hexploit skipn_nil_implies; eauto.
      nia.
    }
    erewrite skipn_nth_next; eauto.
  }
  des.
  rewrite DIV_SKIPN in MVS_EQ2. ss.
  destruct mvs3 as [| mvs3_h []]; ss.
  clarify.

  rewrite rw_cons_app.
  apply Mem.loadbytes_concat; try nia.
  - apply Mem.loadbytes_store_same in STORE.
    ss. rewrite STORE.
    unfold inj_bytes, encode_int. s.
    rewrite rev_if_be_single. ss.

    cut (Byte.repr e =
         Byte.repr (Int.unsigned (Int.repr e))).
    { congruence. }
    apply signed_byte_int_unsigned_repr_eq.
  - eapply Mem.loadbytes_unchanged_on; eauto.
    { eapply store_unchanged_on'; eauto. }
    unfold mem_range. ii. des. ss. nia.
Qed.

Record mem_cst_blk (m: mem) (st: CtrlState.t) (b_cst: block): Prop :=
  MemCtrlState {
      (* mem_cst_load: *)
      (*   Mem.loadbytes m b_cst 0 8 = *)
      (*   Some (inj_bytes (CtrlState.to_bytes cst)); *)

      mem_cst_mode: (* exists md_z, *)
        (* Mem.loadbytes m b_cst 0 1 = Some [Byte (Byte.repr md_z)] /\ *)
        (* mode st = mode_of_Z md_z ; *)
        Mem.loadbytes m b_cst 0 1 =
        Some [Byte (Byte.repr (mode_to_Z (mode st)))] ;
      mem_cst_tout: Mem.loadbytes m b_cst 1 1 =
                    Some [Byte (Byte.repr (timeout st))] ;
      mem_cst_qbgn: Mem.loadbytes m b_cst 2 1 =
                    Some [Byte (Byte.repr (queue_begin st))] ;
      mem_cst_qend: Mem.loadbytes m b_cst 3 1 =
                    Some [Byte (Byte.repr (queue_end st))] ;
      mem_cst_q: Mem.loadbytes m b_cst 4 4 =
                 Some (inj_bytes (map Byte.repr (queue st))) ;

      mem_cst_perm:
        Mem.range_perm m b_cst 0 8 Cur Writable;
    }.

Lemma loadbytes_mem_cst
      m b_cst bs md st
      (PERM: Mem.range_perm m b_cst 0 8 Cur Writable)
      (LBS: Mem.loadbytes m b_cst 0 8 =
            Some (Byte (Byte.repr (mode_to_Z md))
                       :: inj_bytes (tl bs)))
      (* (STATE: st = of_bytes bs) *)
      (STATE: st = copy_state_from_hb md bs)
  : mem_cst_blk m st b_cst.
Proof.
  subst st.

  replace 8 with (1 + 7) in LBS by ss.
  eapply Mem.loadbytes_split in LBS; try nia.
  destruct LBS as (mvs1 & mvs & LBS1 & LBS & MVS_EQ). ss.
  hexploit Mem.loadbytes_length; try apply LBS1.
  intros LEN_BS1.
  destruct mvs1 as [| mv1 []]; ss. clarify.
  destruct bs as [| b1 bs].
  { exfalso. ss.
    apply Mem.loadbytes_length in LBS. ss. }
  ss.

  replace 7 with (1 + 6) in LBS by ss.
  eapply Mem.loadbytes_split in LBS; try nia.
  destruct LBS as (mvs1 & mvs & LBS2 & LBS & MVS_EQ). ss.
  hexploit Mem.loadbytes_length; try apply LBS2.
  intros LEN_BS2.
  destruct mvs1 as [| mv1 []]; ss.
  destruct bs as [| b2 bs]; ss. clarify.

  replace 6 with (1 + 5) in LBS by ss.
  eapply Mem.loadbytes_split in LBS; try nia.
  destruct LBS as (mvs1 & mvs & LBS3 & LBS & MVS_EQ). ss.
  hexploit Mem.loadbytes_length; try apply LBS3.
  intros LEN_BS3.
  destruct mvs1 as [| mv1 []]; ss.
  destruct bs as [| b3 bs]; ss. clarify.

  replace 5 with (1 + 4) in LBS by ss.
  eapply Mem.loadbytes_split in LBS; try nia.
  destruct LBS as (mvs1 & mvs & LBS4 & LBS & MVS_EQ). ss.
  hexploit Mem.loadbytes_length; try apply LBS4.
  intros LEN_BS4.
  destruct mvs1 as [| mv1 []]; ss.
  destruct bs as [| b4 bs]; ss. clarify.

  unfold of_bytes. ss.
  econs; ss.
  - rewrite Byte.repr_signed. ss.
  - rewrite Byte.repr_signed. ss.
  - rewrite Byte.repr_signed. ss.
  - repeat rewrite Byte.repr_signed.
    hexploit Mem.loadbytes_length; try apply LBS.
    intro LEN_BS.
    destruct bs as [| ? bs]; ss.
    destruct bs as [| ? bs]; ss.
    destruct bs as [| ? bs]; ss.
    destruct bs as [| ? bs]; ss.
    destruct bs as [| ? bs]; ss.
Qed.

Lemma mem_cst_loadbytes
      m b_cst bs st
      (MEM_CST: mem_cst_blk m st b_cst)
      (WF_ST: wf st)
      (TO_BYTES: bs = to_bytes st)
  : Mem.loadbytes m b_cst 0 8 = Some (inj_bytes bs).
Proof.
  subst bs.
  inv WF_ST.
  inv MEM_CST. ss. des.

  replace 8 with (1 + 7) by ss.
  rewrite rw_cons_app.
  eapply Mem.loadbytes_concat; try nia; ss.

  s. replace 7 with (1 + 6) by ss.
  rewrite rw_cons_app.
  eapply Mem.loadbytes_concat; try nia; ss.

  s. replace 6 with (1 + 5) by ss.
  rewrite rw_cons_app.
  eapply Mem.loadbytes_concat; try nia; ss.

  s. replace 5 with (1 + 4) by ss.
  rewrite rw_cons_app.
  eapply Mem.loadbytes_concat; try nia; ss.
Qed.

Lemma store_set_mode
      md m m' st b
      (MEM_CST: mem_cst_blk m st b)
      (STORE: Mem.store Mint8signed m b
                        0 (Vint (Int.repr (mode_to_Z md))) = Some m')
  : mem_cst_blk m' (set_mode md st) b.
Proof.
  destruct st as [md_p tout qb qe q].
  inv MEM_CST.
  unfold set_mode. ss.

  hexploit store_unchanged_on'; eauto.
  s. unfold mem_range. i.

  econs; s.
  - hexploit Mem.load_loadbytes.
    { eapply Mem.load_store_same in STORE.
      apply STORE. }
    clear. ss.
    intros (bs & LBS & VEQ).
    rewrite LBS. f_equal.
    apply Mem.loadbytes_length in LBS.
    destruct bs as [| mv []]; ss.
    f_equal.
    rewrite sign_ext_byte_range in VEQ.
    2: { destruct md; ss. }

    destruct mv; ss. f_equal.
    rewrite decode_val_signed_byte in VEQ.

    assert (MODE_TO_Z_EQ: mode_to_Z md = Byte.signed i).
    { apply Int_repr_eq_inv.
      { destruct md; ss. }
      { r. generalize (Byte.signed_range i).
        range_stac. }

      assert (AUX: forall x y, Vint x = Vint y -> x = y).
      { inversion 1. ss. }
      apply AUX. ss.
    }
    rewrite MODE_TO_Z_EQ.
    rewrite Byte.repr_signed. ss.
  - eapply Mem.loadbytes_unchanged_on; eauto.
    unfold mem_range.
    ii. nia.
  - eapply Mem.loadbytes_unchanged_on; eauto.
    unfold mem_range.
    ii. nia.
  - eapply Mem.loadbytes_unchanged_on; eauto.
    unfold mem_range.
    ii. nia.
  - eapply Mem.loadbytes_unchanged_on; eauto.
    unfold mem_range.
    ii. nia.
  - ii. eapply Mem.perm_store_1; eauto.
Qed.

Lemma init_zerobytes
  : of_bytes (List.repeat Byte.zero 8) = init.
Proof.
  unfold of_bytes, init. ss.
Qed.

Section MEMORY_INV.

  Variable ge: genv.

  Let fsymb (id: ident) (bpred: block -> Prop): Prop :=
    forall b (FIND_SYMB: Genv.find_symbol ge id = Some b),
      bpred b.

  Definition mem_cst (m: mem) (cst: CtrlState.t): Prop :=
    fsymb _state (mem_cst_blk m cst).

  Definition mem_grant (m: mem): Prop :=
    fsymb _grant_msg
          (fun b_gr => Mem.loadbytes m b_gr 0 8 =
                    Some (inj_bytes grant_msg)).

  Definition inv_ctrl
             (ast: CtrlState.t) (m: mem): Prop :=
    <<CST_WF: CtrlState.wf ast>> /\
    <<MEM_CST: mem_cst m ast>> /\
    <<MEM_GRANT: mem_grant m>>.

  Lemma mem_cst_unch
        ast m m'
        (MEM_CST : mem_cst m ast)
        (MEM_UNCH : Mem.unchanged_on (blocks_of ge [_state]) m m')
    : mem_cst m' ast.
  Proof.
    rr. rr in MEM_CST. i.
    hexploit MEM_CST.
    { apply FIND_SYMB. }
    inversion 1.

    assert (forall i, blocks_of ge [_state] b i).
    { unfold blocks_of. i.
      exists _state.
      split.
      * clear. ss. eauto.
      * apply FIND_SYMB.
    }

    econs;
      try by eapply Mem.loadbytes_unchanged_on; eauto.
    ii. eapply Mem.perm_unchanged_on; eauto.
  Qed.

  Lemma mem_cst_unch_diffblk
        ast m m' b
        (MEM_CST : mem_cst m ast)
        (MEM_UNCH : mem_changed_block b m m')
        (FSYMB: Genv.find_symbol ge _state <> Some b)
    : mem_cst m' ast.
  Proof.
    eapply mem_cst_unch; eauto.
    eapply Mem.unchanged_on_implies; eauto.
    unfold blocks_of. i.
    simpl in *. des; ss.
    ii. subst. ss.
  Qed.

  Lemma mem_grant_unch
        m m'
        (MEM_GRANT : mem_grant m)
        (MEM_UNCH : Mem.unchanged_on (blocks_of ge [_grant_msg]) m m')
    : mem_grant m'.
  Proof.
    rr. rr in MEM_GRANT. i.
    hexploit MEM_GRANT.
    { apply FIND_SYMB. }
    i. eapply Mem.loadbytes_unchanged_on; eauto.
    unfold blocks_of.
    intros _ _.
    exists _grant_msg.
    splits.
    - clear. ss. eauto.
    - apply FIND_SYMB.
  Qed.

  Lemma mem_grant_unch_diffblk
        m m' b
        (MEM_CST : mem_grant m)
        (MEM_UNCH : mem_changed_block b m m')
        (FSYMB: Genv.find_symbol ge _grant_msg <> Some b)
    : mem_grant m'.
  Proof.
    eapply mem_grant_unch; eauto.
    eapply Mem.unchanged_on_implies; eauto.
    unfold blocks_of. i.
    simpl in *. des; ss.
    ii. subst. ss.
  Qed.

  Lemma inv_ctrl_dep_app_blocks
    : forall (ast : CtrlState.t) (m m' : mem)
        (INV: inv_ctrl ast m)
        (MEM_UNCH: Mem.unchanged_on (blocks_of ge ctrl_gvar_ids) m m'),
      inv_ctrl ast m'.
  Proof.
    unfold inv_ctrl. i. des.
    splits.
    - ss.
    - eapply mem_cst_unch; eauto.
      eapply Mem.unchanged_on_implies; eauto.
      unfold blocks_of. ss.
      i. des; ss.
      clarify. esplits; eauto.
    - eapply mem_grant_unch; eauto.
      eapply Mem.unchanged_on_implies; eauto.
      unfold blocks_of. ss.
      i. des; ss.
      clarify.
      exists _grant_msg. esplits; eauto.
  Qed.

End MEMORY_INV.

Section MEM_INIT.

  Variable tid: nat.
  Variable cprog: Clight.program.

  (* Hypothesis CTRL_TASK_ID: (tid = 1 \/ tid = 2)%nat. *)
  Hypothesis CPROG_EQ: __guard__ (cprog = prog_ctrl (Z.of_nat tid)).
  (* Notation prog := (prog_of_clight (prog_ctrl (Z.of_nat tid))). *)
  (* Notation prog := (prog_of_clight cprog). *)
  Notation ge := (globalenv cprog).

  Let GENV_PROPS
    : genv_props (globalenv cprog)
                 (main_gvar_ilist tid ++ ctrl_gvar_ilist)
                 (main_gfun_ilist ++ ctrl_gfun_ilist)
                 (main_cenv_ilist ++ ctrl_cenv_ilist).
  Proof.
    rewrite CPROG_EQ.
    apply (genv_props_ctrl tid).
  Qed.

  Lemma inv_ctrl_init:
    forall (m_i : mem),
      Genv.init_mem cprog = Some m_i ->
      inv_ctrl ge CtrlState.init m_i.
  Proof.
    intros m_i INIT_MEM. r.
    split.
    { apply CtrlState.wf_init. }

    assert (DEFMAP: (prog_defmap cprog) ! _state = Some (Gvar v_state) /\
                    (prog_defmap cprog) ! _grant_msg = Some (Gvar v_grant_msg)).
    { rewrite CPROG_EQ.
      change (prog_defmap (prog_ctrl (Z.of_nat tid))) with
          (PTree.combine Linking.link_prog_merge
                         (prog_defmap prog_mw) (prog_defmap (ctrl.prog (Z.of_nat tid)))).
      do 2 rewrite PTree.gcombine by ss.
      split.
      - replace ((prog_defmap prog_mw) ! _state) with
            (@None (globdef fundef type)).
        2: {
          change (prog_defmap prog_mw) with
              (PTree.combine Linking.link_prog_merge
                             (prog_defmap config_prog)
                             (prog_defmap main_prog)).
          rewrite PTree.gcombine by ss.
          ss.
        }
        ss.
      - replace ((prog_defmap prog_mw) ! _grant_msg) with
            (@None (globdef fundef type)).
        2: {
          change (prog_defmap prog_mw) with
              (PTree.combine Linking.link_prog_merge
                             (prog_defmap config_prog)
                             (prog_defmap main_prog)).
          rewrite PTree.gcombine by ss.
          ss.
        }
        ss.
    }
    destruct DEFMAP as [DEFMAP1 DEFMAP2].

    split.
    - (* ctrl_state *)
      intros b_cst FSYMB_CST.

      apply Genv.find_def_symbol in DEFMAP1.
      destruct DEFMAP1 as (b_cst' & FSYMB_CST' & FDEF_CST).

      replace (Genv.globalenv cprog) with
          (genv_genv (globalenv cprog)) in FSYMB_CST' by ss.
      fold fundef in FSYMB_CST'.
      rewrite FSYMB_CST in FSYMB_CST'.
      symmetry in FSYMB_CST'. inv FSYMB_CST'.

      eapply Genv.init_mem_characterization_gen in INIT_MEM.
      r in INIT_MEM.
      exploit INIT_MEM; eauto. s.
      intros (RANGE_PERM & PERM & LOAD & LOADBYTES).

      eapply loadbytes_mem_cst; cycle 2.
      + rewrite <- init_zerobytes. ss.
      + rewrite Z.max_l in RANGE_PERM by nia. ss.
      + rewrite Z.max_l in LOADBYTES by nia.
        rewrite LOADBYTES by ss.
        clear. ss.

    - intros b_gr FSYMB_GR.
      apply Genv.find_def_symbol in DEFMAP2.
      destruct DEFMAP2 as (b_gr' & FSYMB_GR' & FDEF_GR).

      replace (Genv.globalenv cprog) with
          (genv_genv (globalenv cprog)) in FSYMB_GR' by ss.
      fold fundef in FSYMB_GR'.
      rewrite FSYMB_GR in FSYMB_GR'.
      symmetry in FSYMB_GR'. clarify.

      eapply Genv.init_mem_characterization_gen in INIT_MEM.
      r in INIT_MEM.
      exploit INIT_MEM; eauto. s.
      intros (RANGE_PERM & PERM & LOAD & LOADBYTES).

      rewrite LOADBYTES by ss.
      ss.
  Qed.

End MEM_INIT.

Section SIM_FUNCS.
  Variable tid: nat.
  Variable cprog: Clight.program.
  Variable r: nat -> itree progE unit -> Clight.state -> Prop.

  (* Hypothesis CTRL_TASK_ID: (tid = 1 \/ tid = 2)%nat. *)
  (* Hypothesis CPROG_EQ: __guard__ (cprog = prog_ctrl (Z.of_nat tid)). *)
  Notation ge := (globalenv cprog).
  Notation prog := (prog_of_clight cprog).

  Hypothesis GENV_PROPS
    : genv_props ge
                 (main_gvar_ilist tid ++ ctrl_gvar_ilist)
                 (main_gfun_ilist ++ ctrl_gfun_ilist)
                 (main_cenv_ilist ++ ctrl_cenv_ilist).

  Definition idx_qs: nat := 20.

  Lemma sim_qrange_sanitize
        (itr: itree progE unit)
        (m: mem) (k: cont)
        (i: Z) (idx_ret: nat)
        (CALL_CONT: is_call_cont k)
        (RANGE_I: IntRange.sintz i)
        (SIM_RET:
           paco3 (_sim_itree prog) r
                 idx_ret itr
                 (Returnstate (Vint (Int.repr (qrange_sanitize i))) k m))
    : paco3 (_sim_itree prog) r
            (idx_ret + idx_qs)%nat itr
            (Callstate (Internal f_qrange_sanitize)
                       [Vint (Int.repr i)] k m).
  Proof.
    (* clear CPROG_EQ. *)
    unfold idx_qs.
    start_func.
    { econs. }
    ss.
    fw. fw. fw.
    { econs.
      - eval_comput.
        repr_tac. ss.
      - rewrite bool_val_of_bool. ss.
    }
    unfold qrange_sanitize in SIM_RET.

    destruct (Z.ltb_spec i 0).
    - s.
      fw.
      { econs. eval_comput. ss. }
      upd_lenv.
      fw. fw.
      { econs.
        - eval_comput. ss.
        - ss.
      }
      rewrite Int.eq_true. s.
      fw.
      { econs.
        - eval_comput. ss.
        - eval_comput. ss.
        - ss.
      }
      destruct (Z.leb_spec 0 i).
      { exfalso. nia. }
      rewrite andb_false_l in SIM_RET.

      red_idx idx_ret.
      rewrite call_cont_is_call_cont by ss.
      apply SIM_RET.
    - s.
      fw.
      { econs.
        eval_comput.
        repr_tac.
        instantiate (1:= if i <? 4 then Vtrue else Vfalse).
        destruct (Z.ltb_spec i 4); ss.
      }
      upd_lenv.
      fw. fw.
      { econs.
        - eval_comput. reflexivity.
        - instantiate (1:= (i <? 4)).
          clear. desf.
      }

      destruct (Z.leb_spec 0 i).
      2: { exfalso. nia. }

      unfold QSIZE in *.
      destruct (Z.ltb_spec i 4); ss.
      + (* safe value *)
        fw.
        { econs.
          - eval_comput. reflexivity.
          - eval_comput. reflexivity.
          - ss.
        }
        rewrite call_cont_is_call_cont by ss.
        red_idx idx_ret.
        apply SIM_RET.
      + (* return 0 *)
        fw.
        { econs.
          - eval_comput. reflexivity.
          - eval_comput. reflexivity.
          - ss.
        }
        rewrite call_cont_is_call_cont by ss.
        red_idx idx_ret.
        apply SIM_RET.
  Qed.

  Opaque idx_qs.
  Definition idx_aqi: nat := idx_qs + 20.

  Lemma sim_adv_qidx
        (itr: itree progE unit)
        (m: mem) (k: cont)
        (i: Z) (idx_ret: nat)
        (CALL_CONT: is_call_cont k)
        (RANGE_I: IntRange.sintz i)
        (SIM_RET:
           paco3 (_sim_itree prog) r
                 idx_ret itr
                 (Returnstate (Vint (Int.repr (adv_qidx i))) k m))
    : paco3 (_sim_itree prog) r
            (idx_ret + idx_aqi)%nat itr
            (Callstate (Internal f_adv_qidx)
                       [Vint (Int.repr i)] k m).
  Proof.
    (* clear CPROG_EQ. *)
    unfold idx_aqi.
    start_func.
    { econs. }
    simpl in *.

    fw. fw. fw. fw. fw.
    { econs.
      eval_comput.
      rewrite Int_add_repr_signed by range_stac.
      reflexivity. }
    upd_lenv.

    fw. fw.
    { econs.
      eval_comput.
      reflexivity. }
    upd_lenv.

    fw. fw.
    { hexploit (in_gfun_ilist _qrange_sanitize); [sIn|].
      i. des.
      econs; eauto.
      - ss.
      - eval_comput. rewrite FDEF_SYMB. ss.
      - eval_comput.
        reflexivity.
      - ss.
    }

    red_idx (idx_ret + 10 + idx_qs)%nat.
    replace (Int.repr (i + 1)) with
        (Int.repr (Int.signed (Int.repr (i + 1)))).
    2: { rewrite Int.repr_signed. ss. }

    eapply sim_qrange_sanitize; eauto.
    { ss. }
    { apply Int.signed_range. }

    fw. upd_lenv.
    fw. fw.
    { econs.
      - eval_comput.
        replace (qrange_sanitize (Int.signed (Int.repr (i + 1))))
          with (adv_qidx i).
        2: { unfold adv_qidx.
             unfold qrange_sanitize.

             destruct (Z.ltb_spec i Int.max_signed).
             - assert (IntRange.sintz (i + 1)).
               { range_stac. }
               rewrite Int.signed_repr by range_stac.
               ss.
             - assert (i = Int.max_signed).
               { r in RANGE_I.
                 nia. }
               subst i. ss.
        }
        reflexivity.
      - ss.
      - ss.
    }
    ss.

    rewrite call_cont_is_call_cont by ss.
    red_idx (idx_ret)%nat.
    apply SIM_RET.
  Qed.

  Opaque idx_aqi.

  Definition idx_chdev: nat := 30.

  Lemma sim_check_dev_id
        (itr: itree progE unit)
        (m: mem) (k: cont)
        (tid_dev: Z) (idx_ret: nat)
        (CALL_CONT: is_call_cont k)
        (RANGE_TID_DEV: IntRange.sintz tid_dev)
        (SIM_RET:
           paco3 (_sim_itree prog) r
                 idx_ret itr
                 (Returnstate (Val.of_bool (check_dev_id tid_dev)) k m))
    : paco3 (_sim_itree prog) r
            (idx_ret + idx_chdev)%nat itr
            (Callstate (Internal f_check_dev_id)
                       [Vint (Int.repr tid_dev)] k m).
  Proof.
    (* clear CPROG_EQ. *)
    unfold idx_chdev.
    start_func.
    { econs. }
    unfold check_dev_id in SIM_RET. ss.

    fw. fw. fw. fw. fw.
    { econs.
      - eval_comput.
        rewrite Int_eq_repr_signed by range_stac.
        reflexivity.
      - rewrite bool_val_of_bool. reflexivity.
    }
    change (Z.of_nat 3) with 3 in *.
    change (Z.of_nat 4) with 4 in *.
    change (Z.of_nat 5) with 5 in *.

    destruct (Z.eqb tid_dev 3).
    { (* tid_dev = 3 *)
      fw.
      { econs.
        eval_comput. reflexivity. }
      upd_lenv.
      fw. fw.
      { econs.
        { eval_comput. reflexivity. }
        ss. }
      rewrite Int.eq_false by ss.
      s.
      fw.
      { econs.
        eval_comput. reflexivity. }
      upd_lenv.
      fw. fw.
      { econs.
        eval_comput. reflexivity. }
      upd_lenv.
      fw. fw.
      { econs; ss.
        - eval_comput. ss.
        - ss. }

      ss.
      rewrite call_cont_is_call_cont by ss.

      red_idx idx_ret.
      eapply SIM_RET.
    }
    fw.
    { econs.
      eval_comput.
      rewrite Int_eq_repr_signed by range_stac.
      instantiate (1:= if tid_dev =? 4 then Vtrue else Vfalse).
      destruct (Z.eqb_spec tid_dev 4); ss.
    }
    upd_lenv.
    fw.

    destruct (Z.eqb tid_dev 4).
    { (* tid_dev = 4 *)
      fw.
      { econs.
        - eval_comput. reflexivity.
        - ss. }
      rewrite Int.eq_false by ss.
      s.
      fw.
      { econs.
        eval_comput. reflexivity. }
      upd_lenv.
      fw. fw.
      { econs.
        eval_comput. reflexivity. }
      upd_lenv.
      fw. fw.
      { econs; ss.
        - eval_comput. ss.
        - ss. }

      ss.
      rewrite call_cont_is_call_cont by ss.

      red_idx idx_ret.
      eapply SIM_RET.
    }

    fw.
    { econs.
      - eval_comput. ss.
      - ss. }
    rewrite Int.eq_true. s.

    fw.
    { econs.
      eval_comput.
      rewrite Int_eq_repr_signed by range_stac.
      instantiate (1:= if tid_dev =? 5 then Vtrue else Vfalse).
      destruct (Z.eqb_spec tid_dev 5); ss.
    }
    upd_lenv.
    fw.

    destruct (Z.eqb tid_dev 5).
    { (* tid_dev = 5 *)
      fw.
      { econs.
        eval_comput. reflexivity. }
      upd_lenv.
      fw. fw.
      { econs; ss.
        - eval_comput. ss.
        - ss. }

      ss.
      rewrite call_cont_is_call_cont by ss.
      red_idx idx_ret.
      eapply SIM_RET.
    }
    (* false *)
    fw.
    { econs. eval_comput. ss. }
    upd_lenv.
    fw. fw.
    { econs; ss.
      - eval_comput. ss.
      - ss. }
    s. rewrite call_cont_is_call_cont by ss.
    red_idx idx_ret.
    eapply SIM_RET.
  Qed.

End SIM_FUNCS.


Require Import LayerDeps.
Require Import Ident.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import BaremoreHandler.Spec.
Require Import AbsAccessor.Spec.
Require Import RmiSMC.Spec.
Require Import RunSMC.Spec.
Require Import TableAux.Spec.
Require Import TableDataOpsIntro.Spec.

Local Open Scope Z_scope.

Section Layer.

  Context `{real_params: RealParams}.

  Section InvDef.

    Record high_level_invariant (adt: RData) :=
      mkInvariants { }.

    Global Instance TableDataOpsIntro_ops : CompatDataOps RData :=
      {
        empty_data := empty_adt;
        high_level_invariant := high_level_invariant;
        low_level_invariant := fun (b: block) (d: RData) => True;
        kernel_mode adt := True
      }.

  End InvDef.

  Section InvInit.

    Global Instance TableDataOpsIntro_prf : CompatData RData.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

  End InvInit.

  Context `{Hstencil: Stencil}.
  Context `{Hmem: Mem.MemoryModelX}.
  Context `{Hmwd: UseMemWithData mem}.

  Section InvProof.

    Global Instance table_create_inv: PreservesInvariants table_create_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance table_destroy_inv: PreservesInvariants table_destroy_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance table_map_inv: PreservesInvariants table_map_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance table_unmap_inv: PreservesInvariants table_unmap_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance data_create_inv: PreservesInvariants data_create_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance data_create_unknown_inv: PreservesInvariants data_create_unknown_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance data_destroy_inv: PreservesInvariants data_destroy_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance el3_sync_lel_inv: PreservesInvariants el3_sync_lel_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance buffer_unmap_inv: PreservesInvariants buffer_unmap_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_unlock_inv: PreservesInvariants granule_unlock_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance enter_rmm_inv: PreservesInvariants enter_rmm_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance smc_granule_delegate_inv: PreservesInvariants smc_granule_delegate_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance exit_rmm_inv: PreservesInvariants exit_rmm_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance smc_granule_undelegate_inv: PreservesInvariants smc_granule_undelegate_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_set_state_inv: PreservesInvariants granule_set_state_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance smc_rec_destroy_inv: PreservesInvariants smc_rec_destroy_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance smc_rec_create_inv: PreservesInvariants smc_rec_create_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_map_inv: PreservesInvariants granule_map_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance smc_rec_run_inv: PreservesInvariants smc_rec_run_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance read_reg_inv: PreservesInvariants read_reg_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance find_lock_granule_inv: PreservesInvariants find_lock_granule_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance is_null_inv: PreservesInvariants is_null_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance assert_cond_inv: PreservesInvariants assert_cond_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance validate_table_commands_inv: PreservesInvariants validate_table_commands_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rd_state_inv: PreservesInvariants get_rd_state_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance find_granule_inv: PreservesInvariants find_granule_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance smc_realm_create_inv: PreservesInvariants smc_realm_create_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance user_step_inv: PreservesInvariants user_step_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance smc_realm_activate_inv: PreservesInvariants smc_realm_activate_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance smc_realm_destroy_inv: PreservesInvariants smc_realm_destroy_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

  End InvProof.

  Section LayerDef.

    Definition TableDataOpsIntro_fresh : compatlayer (cdata RData) :=
      _table_create ↦ gensem table_create_spec
        ⊕ _table_destroy ↦ gensem table_destroy_spec
        ⊕ _table_map ↦ gensem table_map_spec
        ⊕ _table_unmap ↦ gensem table_unmap_spec
        ⊕ _data_create ↦ gensem data_create_spec
        ⊕ _data_create_unknown ↦ gensem data_create_unknown_spec
        ⊕ _data_destroy ↦ gensem data_destroy_spec
      .

    Definition TableDataOpsIntro_passthrough : compatlayer (cdata RData) :=
      _el3_sync_lel ↦ gensem el3_sync_lel_spec
        ⊕ _buffer_unmap ↦ gensem buffer_unmap_spec
        ⊕ _granule_unlock ↦ gensem granule_unlock_spec
        ⊕ _enter_rmm ↦ gensem enter_rmm_spec
        ⊕ _smc_granule_delegate ↦ gensem smc_granule_delegate_spec
        ⊕ _exit_rmm ↦ gensem exit_rmm_spec
        ⊕ _smc_granule_undelegate ↦ gensem smc_granule_undelegate_spec
        ⊕ _granule_set_state ↦ gensem granule_set_state_spec
        ⊕ _smc_rec_destroy ↦ gensem smc_rec_destroy_spec
        ⊕ _smc_rec_create ↦ gensem smc_rec_create_spec
        ⊕ _granule_map ↦ gensem granule_map_spec
        ⊕ _smc_rec_run ↦ gensem smc_rec_run_spec
        ⊕ _read_reg ↦ gensem read_reg_spec
        ⊕ _find_lock_granule ↦ gensem find_lock_granule_spec
        ⊕ _is_null ↦ gensem is_null_spec
        ⊕ _assert_cond ↦ gensem assert_cond_spec
        ⊕ _validate_table_commands ↦ gensem validate_table_commands_spec
        ⊕ _get_rd_state ↦ gensem get_rd_state_spec
        ⊕ _find_granule ↦ gensem find_granule_spec
        ⊕ _smc_realm_create ↦ gensem smc_realm_create_spec
        ⊕ _user_step ↦ gensem user_step_spec
        ⊕ _smc_realm_activate ↦ gensem smc_realm_activate_spec
        ⊕ _smc_realm_destroy ↦ gensem smc_realm_destroy_spec
      .

    Definition TableDataOpsIntro := TableDataOpsIntro_fresh ⊕ TableDataOpsIntro_passthrough.

  End LayerDef.

End Layer.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*           Layers of PM: Assembly Verification for PKContext         *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import Integers.
Require Import Constant.
Require Import GlobIdent.

Require Import liblayers.compat.CompatLayers.
Require Import LAsm.

Section ASM_CODE.

  Definition AddrMake1 (r: ireg) :=
    Addrmode (Some r) (Some (r, Int.repr 2)) (inl Int.zero).

  Definition AddrMake2 (r: ireg) :=
    Addrmode None (Some (r, Int.repr 8)) (inr (KCtxtPool_LOC, Int.zero)).

  Definition AddrMake3 (r: ireg) (ofs:int) :=
    Addrmode (Some r) None (inl ofs).

  (*
	.globl cswitch
cswitch:
	/* save the old kernel context */
	leal	(%eax,%eax,2), %eax
	leal	KCtxtPool_LOC(,%eax,8), %eax
	movl	%esp, (%eax)
	movl	%edi, 4(%eax)
	movl	%esi, 8(%eax)
	movl	%ebx, 12(%eax)
	movl	%ebp, 16(%eax)

	popl	%ecx
	movl	%ecx, 20(%eax)

	/* load the new kernel context */
	leal	(%edx,%edx,2), %edx
	leal	KCtxtPool_LOC(,%edx,8), %edx
	movl	(%edx), %esp
	movl	4(%edx), %edi
	movl	8(%edx), %esi
	movl	12(%edx), %ebx
	movl	16(%edx), %ebp
	movl	20(%edx), %ecx
	pushl	%ecx
	xorl	%eax, %eax
	ret

   *)

  Definition Im_cswitch : list instruction :=
    (*save the old kernel context*)
    asm_instruction (Plea EAX (AddrMake1 EAX)) ::  (* EAX = EAX * 3 *)
                    asm_instruction (Plea EAX (AddrMake2 EAX)) ::  (* EAX = KCtxtPool_LOC (EAX * 8) *)
                    asm_instruction (Pmov_mr (AddrMake3 EAX Int.zero) Asm.ESP) ::
                    asm_instruction (Pmov_mr (AddrMake3 EAX (Int.repr 4)) Asm.EDI) ::
                    asm_instruction (Pmov_mr (AddrMake3 EAX (Int.repr 8)) Asm.ESI) ::
                    asm_instruction (Pmov_mr (AddrMake3 EAX (Int.repr 12)) Asm.EBX) ::
                    asm_instruction (Pmov_mr (AddrMake3 EAX (Int.repr 16)) Asm.EBP) ::
                    Ppopl_RA ECX ::
                    asm_instruction (Pmov_mr (AddrMake3 EAX (Int.repr 20)) ECX) ::

                    (*load the new kernel context*)
                    asm_instruction (Plea EDX (AddrMake1 EDX)) ::  (* EAX = EAX * 3 *)
                    asm_instruction (Plea EDX (AddrMake2 EDX)) ::  (* EAX = KCtxtPool_LOC (EAX * 8) *)

                    asm_instruction (Pmov_rm Asm.ESP (AddrMake3 EDX Int.zero)) ::
                    asm_instruction (Pmov_rm Asm.EDI (AddrMake3 EDX (Int.repr 4))) ::
                    asm_instruction (Pmov_rm Asm.ESI (AddrMake3 EDX (Int.repr 8))) ::
                    asm_instruction (Pmov_rm Asm.EBX (AddrMake3 EDX (Int.repr 12))) ::
                    asm_instruction (Pmov_rm Asm.EBP (AddrMake3 EDX (Int.repr 16))) ::
                    asm_instruction (Pmov_rm Asm.ECX (AddrMake3 EDX (Int.repr 20))) ::
                    Ppushl_RA ECX ::
                    asm_instruction (Pxor_r EAX) ::
                    asm_instruction (Pret) ::
                    nil.

  Definition cswitch_function: function := mkfunction null_signature Im_cswitch.

End ASM_CODE.


Require Import HoTT.
Require Import UnivalenceAxiom.

Require Import HoTTEx.
Require Import Denotation.
Require Import UnivalentSemantics.

Open Scope type.

Module AggregationOptimization (T : Types) (S : Schemas T) (R : Relations T S)  (A : Aggregators T S).
  Import T S R A.
  Module SQL_TSRA := SQL T S R A.
  Import SQL_TSRA.

  Parameter integer : type.
  Parameter count : forall {T}, aggregator T integer.
  Notation "'COUNT' ( e )" := (aggregatorGroupByProj count e).

  Definition AggregationQuery : Type.
    refine (forall (Γ : Schema) s (a : relation s) C0 (value : Column C0 s) C1 (label: Column C1 s) (l : constant C1), _).
    pose (@variable C1 (Γ ++ s) (right⋅label)) as lbl.
    pose (@variable C0 (Γ ++ s) (right⋅value)) as val.
    pose (@variable C1 (Γ ++ (singleton C1 ++ singleton integer)) (right⋅left)) as lbl'.
    refine (⟦ Γ ⊢ (SELECT *
                  FROM1
                  (SELECT (combineGroupByProj PLAIN(lbl) COUNT(val)) FROM1 table a GROUP BY (right⋅label))
                  WHERE equal lbl' (constantExpr l)) : _ ⟧ =
            ⟦ Γ ⊢ SELECT (combineGroupByProj PLAIN(lbl) COUNT(val))
                  FROM1 table a
                  WHERE equal lbl (constantExpr l)
                  GROUP BY (right⋅label) : _ ⟧).
  Defined.
  Arguments AggregationQuery /.

  Lemma aggregationQuery : AggregationQuery.
    start.
    apply path_universe_uncurried.
    apply equiv_iff_hprop_uncurried.
    constructor.
    + intros [p u].
      strip_truncations.
      destruct u as [t0 [a0 u]].
      apply tr.
      rewrite <- u in p.
      refine (t0; (_,  _)).
      * refine (_, a0).
        assumption.
      * rewrite <- u.
        rewrite p.
        repeat f_ap.
        by_extensionality t'.
        f_ap.
        by_extensionality t1.
        rewrite (path_universe_uncurried (equiv_prod_assoc _ _ _)).
        repeat f_ap.
        rewrite (path_universe_uncurried (equiv_prod_symm _ _)).
        apply path_universe_uncurried.
        apply hprop_prod_l'.
        intros.
        symmetry.
        assumption.
    + intros p.
      strip_truncations.
      destruct p as [t0 [[c d] e]].
      rewrite <- e.
      cbn.
      constructor; try apply tr; try assumption.
      refine (t0; (d, _)).
      repeat f_ap.
      by_extensionality t'.
      f_ap.
      by_extensionality t1.
      rewrite <- c.
      f_ap.
      rewrite (path_universe_uncurried (equiv_prod_assoc _ _ _)).
      f_ap.
      rewrite (path_universe_uncurried (equiv_prod_symm _ _)).
      symmetry.
      apply path_universe_uncurried.
      apply hprop_prod_l'.
      intros.
      symmetry.
      assumption.
  Qed.

End AggregationOptimization.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import BaremoreSMC.Spec.
Require Import RmiOps.Specs.granule_undelegate_ops.
Require Import RmiOps.LowSpecs.granule_undelegate_ops.
Require Import RmiOps.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       granule_set_state_spec
       smc_mark_nonsecure_spec
       granule_unlock_spec
    .

  Lemma granule_undelegate_ops_spec_exists:
    forall habd habd'  labd g addr
           (Hspec: granule_undelegate_ops_spec g addr habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', granule_undelegate_ops_spec0 g addr labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    intros. destruct Hrel. inv id_rdata. destruct g, addr.
    unfold granule_undelegate_ops_spec, granule_undelegate_ops_spec0 in *.
    repeat autounfold in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; bool_rel; simpl in *; srewrite;
        repeat (simpl_htarget; grewrite; simpl in *).
    eexists; (split; [reflexivity| constructor; try reflexivity]).
  Qed.

End Refine.


(* Default settings (from HsToCoq.Coq.Preamble) *)

Generalizable All Variables.

Unset Implicit Arguments.
Set Maximal Implicit Insertion.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Coq.Program.Tactics.
Require Coq.Program.Wf.

(* Converted imports: *)

Require DynFlags.
Require FastString.
Require GHC.Base.
Require GHC.Err.
Require GHC.Num.
Require Panic.
Import GHC.Base.Notations.
Import GHC.Num.Notations.

(* Converted type declarations: *)

Inductive Width : Type
  := W8 : Width
  |  W16 : Width
  |  W32 : Width
  |  W64 : Width
  |  W80 : Width
  |  W128 : Width
  |  W256 : Width
  |  W512 : Width.

Definition Length :=
  GHC.Num.Int%type.

Inductive ForeignHint : Type
  := NoHint : ForeignHint
  |  AddrHint : ForeignHint
  |  SignedHint : ForeignHint.

Inductive CmmCat : Type
  := GcPtrCat : CmmCat
  |  BitsCat : CmmCat
  |  FloatCat : CmmCat
  |  VecCat : Length -> CmmCat -> CmmCat.

Inductive CmmType : Type := Mk_CmmType : CmmCat -> Width -> CmmType.

Instance Default__Width : GHC.Err.Default Width := GHC.Err.Build_Default _ W8.

Instance Default__ForeignHint : GHC.Err.Default ForeignHint :=
  GHC.Err.Build_Default _ NoHint.

Instance Default__CmmCat : GHC.Err.Default CmmCat :=
  GHC.Err.Build_Default _ GcPtrCat.

(* Midamble *)

Require Import GHC.Nat.

Instance Default__CmmType : GHC.Err.Default CmmType :=
	 { default := Mk_CmmType GHC.Err.default GHC.Err.default }.

(* Converted value declarations: *)

Definition wordWidth : DynFlags.DynFlags -> Width :=
  fun dflags =>
    if DynFlags.wORD_SIZE dflags GHC.Base.== #4 : bool then W32 else
    if DynFlags.wORD_SIZE dflags GHC.Base.== #8 : bool then W64 else
    Panic.panic (GHC.Base.hs_string__ "MachOp.wordRep: Unknown word size").

Definition widthInLog : Width -> GHC.Num.Int :=
  fun arg_0__ =>
    match arg_0__ with
    | W8 => #0
    | W16 => #1
    | W32 => #2
    | W64 => #3
    | W128 => #4
    | W256 => #5
    | W512 => #6
    | W80 => Panic.panic (GHC.Base.hs_string__ "widthInLog: F80")
    end.

Definition widthInBytes : Width -> GHC.Num.Int :=
  fun arg_0__ =>
    match arg_0__ with
    | W8 => #1
    | W16 => #2
    | W32 => #4
    | W64 => #8
    | W128 => #16
    | W256 => #32
    | W512 => #64
    | W80 => #10
    end.

Definition widthInBits : Width -> GHC.Num.Int :=
  fun arg_0__ =>
    match arg_0__ with
    | W8 => #8
    | W16 => #16
    | W32 => #32
    | W64 => #64
    | W128 => #128
    | W256 => #256
    | W512 => #512
    | W80 => #80
    end.

Definition widthFromBytes : GHC.Num.Int -> Width :=
  fun arg_0__ =>
    let 'num_1__ := arg_0__ in
    if num_1__ GHC.Base.== #1 : bool then W8 else
    let 'num_2__ := arg_0__ in
    if num_2__ GHC.Base.== #2 : bool then W16 else
    let 'num_3__ := arg_0__ in
    if num_3__ GHC.Base.== #4 : bool then W32 else
    let 'num_4__ := arg_0__ in
    if num_4__ GHC.Base.== #8 : bool then W64 else
    let 'num_5__ := arg_0__ in
    if num_5__ GHC.Base.== #16 : bool then W128 else
    let 'num_6__ := arg_0__ in
    if num_6__ GHC.Base.== #32 : bool then W256 else
    let 'num_7__ := arg_0__ in
    if num_7__ GHC.Base.== #64 : bool then W512 else
    let 'num_8__ := arg_0__ in
    if num_8__ GHC.Base.== #10 : bool then W80 else
    let 'n := arg_0__ in
    Panic.panicStr (GHC.Base.hs_string__ "no width for given number of bytes")
    (Panic.someSDoc).

Definition vecLength : CmmType -> Length :=
  fun arg_0__ =>
    match arg_0__ with
    | Mk_CmmType (VecCat l _) _ => l
    | _ => Panic.panic (GHC.Base.hs_string__ "vecLength: not a vector")
    end.

Definition vec : Length -> CmmType -> CmmType :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | l, Mk_CmmType cat w =>
        let vecw : Width := widthFromBytes (l GHC.Num.* widthInBytes w) in
        Mk_CmmType (VecCat l cat) vecw
    end.

Definition vec16 : CmmType -> CmmType :=
  vec #16.

Definition vec2 : CmmType -> CmmType :=
  vec #2.

Definition vec4 : CmmType -> CmmType :=
  vec #4.

Definition vec8 : CmmType -> CmmType :=
  vec #8.

Definition typeWidth : CmmType -> Width :=
  fun '(Mk_CmmType _ w) => w.

Definition mrStr : Width -> FastString.LitString :=
  fun arg_0__ =>
    match arg_0__ with
    | W8 => FastString.sLit (GHC.Base.hs_string__ "W8")
    | W16 => FastString.sLit (GHC.Base.hs_string__ "W16")
    | W32 => FastString.sLit (GHC.Base.hs_string__ "W32")
    | W64 => FastString.sLit (GHC.Base.hs_string__ "W64")
    | W128 => FastString.sLit (GHC.Base.hs_string__ "W128")
    | W256 => FastString.sLit (GHC.Base.hs_string__ "W256")
    | W512 => FastString.sLit (GHC.Base.hs_string__ "W512")
    | W80 => FastString.sLit (GHC.Base.hs_string__ "W80")
    end.

Definition isWord64 : CmmType -> bool :=
  fun arg_0__ =>
    match arg_0__ with
    | Mk_CmmType BitsCat W64 => true
    | Mk_CmmType GcPtrCat W64 => true
    | _other => false
    end.

Definition isWord32 : CmmType -> bool :=
  fun arg_0__ =>
    match arg_0__ with
    | Mk_CmmType BitsCat W32 => true
    | Mk_CmmType GcPtrCat W32 => true
    | _other => false
    end.

Definition isVecType : CmmType -> bool :=
  fun arg_0__ =>
    match arg_0__ with
    | Mk_CmmType (VecCat _ _) _ => true
    | _ => false
    end.

Definition isGcPtrType : CmmType -> bool :=
  fun arg_0__ =>
    match arg_0__ with
    | Mk_CmmType GcPtrCat _ => true
    | _other => false
    end.

Definition isFloatType : CmmType -> bool :=
  fun arg_0__ =>
    match arg_0__ with
    | Mk_CmmType FloatCat _ => true
    | _other => false
    end.

Definition isFloat64 : CmmType -> bool :=
  fun arg_0__ =>
    match arg_0__ with
    | Mk_CmmType FloatCat W64 => true
    | _other => false
    end.

Definition isFloat32 : CmmType -> bool :=
  fun arg_0__ =>
    match arg_0__ with
    | Mk_CmmType FloatCat W32 => true
    | _other => false
    end.

Definition halfWordWidth : DynFlags.DynFlags -> Width :=
  fun dflags =>
    if DynFlags.wORD_SIZE dflags GHC.Base.== #4 : bool then W16 else
    if DynFlags.wORD_SIZE dflags GHC.Base.== #8 : bool then W32 else
    Panic.panic (GHC.Base.hs_string__ "MachOp.halfWordRep: Unknown word size").

Definition halfWordMask : DynFlags.DynFlags -> GHC.Num.Integer :=
  fun dflags =>
    if DynFlags.wORD_SIZE dflags GHC.Base.== #4 : bool then #65535 else
    if DynFlags.wORD_SIZE dflags GHC.Base.== #8 : bool then #4294967295 else
    Panic.panic (GHC.Base.hs_string__ "MachOp.halfWordMask: Unknown word size").

Definition gcWord : DynFlags.DynFlags -> CmmType :=
  fun dflags => Mk_CmmType GcPtrCat (wordWidth dflags).

Definition cmmVec : GHC.Num.Int -> CmmType -> CmmType :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | n, Mk_CmmType cat w =>
        Mk_CmmType (VecCat n cat) (widthFromBytes (n GHC.Num.* widthInBytes w))
    end.

Definition cmmFloat : Width -> CmmType :=
  Mk_CmmType FloatCat.

Definition f32 : CmmType :=
  cmmFloat W32.

Definition vec4f32 : CmmType :=
  vec #4 f32.

Definition f64 : CmmType :=
  cmmFloat W64.

Definition vec2f64 : CmmType :=
  vec #2 f64.

Local Definition Eq___CmmCat_op_zeze__ : CmmCat -> CmmCat -> bool :=
  fun x y => true.

Local Definition Eq___CmmCat_op_zsze__ : CmmCat -> CmmCat -> bool :=
  fun x y => negb (Eq___CmmCat_op_zeze__ x y).

Program Instance Eq___CmmCat : GHC.Base.Eq_ CmmCat :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zeze____ := Eq___CmmCat_op_zeze__ ;
           GHC.Base.op_zsze____ := Eq___CmmCat_op_zsze__ |}.

Local Definition Eq___Width_op_zeze__ : Width -> Width -> bool :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | W8, W8 => true
    | W16, W16 => true
    | W32, W32 => true
    | W64, W64 => true
    | W80, W80 => true
    | W128, W128 => true
    | W256, W256 => true
    | W512, W512 => true
    | _, _ => false
    end.

Local Definition Eq___Width_op_zsze__ : Width -> Width -> bool :=
  fun x y => negb (Eq___Width_op_zeze__ x y).

Program Instance Eq___Width : GHC.Base.Eq_ Width :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zeze____ := Eq___Width_op_zeze__ ;
           GHC.Base.op_zsze____ := Eq___Width_op_zsze__ |}.

Definition cmmEqType : CmmType -> CmmType -> bool :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_CmmType c1 w1, Mk_CmmType c2 w2 =>
        andb (c1 GHC.Base.== c2) (w1 GHC.Base.== w2)
    end.

Definition cmmEqType_ignoring_ptrhood : CmmType -> CmmType -> bool :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_CmmType c1 w1, Mk_CmmType c2 w2 =>
        let weak_eq : CmmCat -> CmmCat -> bool :=
          fix weak_eq arg_2__ arg_3__
                := match arg_2__, arg_3__ with
                   | FloatCat, FloatCat => true
                   | FloatCat, _other => false
                   | _other, FloatCat => false
                   | VecCat l1 cat1, VecCat l2 cat2 => andb (l1 GHC.Base.== l2) (weak_eq cat1 cat2)
                   | VecCat _ _, _other => false
                   | _other, VecCat _ _ => false
                   | _word1, _word2 => true
                   end in
        andb (weak_eq c1 c2) (w1 GHC.Base.== w2)
    end.

Definition cmmBits : Width -> CmmType :=
  Mk_CmmType BitsCat.

Definition bWord : DynFlags.DynFlags -> CmmType :=
  fun dflags => cmmBits (wordWidth dflags).

Definition bHalfWord : DynFlags.DynFlags -> CmmType :=
  fun dflags => cmmBits (halfWordWidth dflags).

Definition b8 : CmmType :=
  cmmBits W8.

Definition vec16b8 : CmmType :=
  vec #16 b8.

Definition b64 : CmmType :=
  cmmBits W64.

Definition vec2b64 : CmmType :=
  vec #2 b64.

Definition b512 : CmmType :=
  cmmBits W512.

Definition b32 : CmmType :=
  cmmBits W32.

Definition vec4b32 : CmmType :=
  vec #4 b32.

Definition b256 : CmmType :=
  cmmBits W256.

Definition b16 : CmmType :=
  cmmBits W16.

Definition vec8b16 : CmmType :=
  vec #8 b16.

Definition b128 : CmmType :=
  cmmBits W128.

(* Skipping instance `CmmType.Ord__Width' of class `GHC.Base.Ord' *)

(* Skipping all instances of class `GHC.Show.Show', including
   `CmmType.Show__Width' *)

Local Definition Eq___ForeignHint_op_zeze__
   : ForeignHint -> ForeignHint -> bool :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | NoHint, NoHint => true
    | AddrHint, AddrHint => true
    | SignedHint, SignedHint => true
    | _, _ => false
    end.

Local Definition Eq___ForeignHint_op_zsze__
   : ForeignHint -> ForeignHint -> bool :=
  fun x y => negb (Eq___ForeignHint_op_zeze__ x y).

Program Instance Eq___ForeignHint : GHC.Base.Eq_ ForeignHint :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zeze____ := Eq___ForeignHint_op_zeze__ ;
           GHC.Base.op_zsze____ := Eq___ForeignHint_op_zsze__ |}.

(* Skipping all instances of class `Outputable.Outputable', including
   `CmmType.Outputable__Width' *)

(* Skipping all instances of class `Outputable.Outputable', including
   `CmmType.Outputable__CmmCat' *)

(* Skipping all instances of class `Outputable.Outputable', including
   `CmmType.Outputable__CmmType' *)

(* External variables:
     andb bool false negb true DynFlags.DynFlags DynFlags.wORD_SIZE
     FastString.LitString FastString.sLit GHC.Base.Eq_ GHC.Base.op_zeze__
     GHC.Base.op_zeze____ GHC.Base.op_zsze____ GHC.Err.Build_Default GHC.Err.Default
     GHC.Num.Int GHC.Num.Integer GHC.Num.fromInteger GHC.Num.op_zt__ Panic.panic
     Panic.panicStr Panic.someSDoc
*)