(* Modified Smallstep library to verify dynamic optimizations *)

Require Import Relations.
Require Import Wellfounded.
Require Import Coqlib.
Require Import Events.
Require Import Smallstep.
Require Import IR.
Require Import RTLblock.
Require Import mixed_sem.
Require Import monad_impl.
Require Import customSmallstep.

Set Implicit Arguments.

(** * Reflexivity of our match_states relations  *)
Definition reflexive {index:Type} {state:Type} (match_states: index -> state -> state -> Prop): Prop :=
  forall s, exists i, match_states i s s.

(** * Reflexivity on Call states  *)
Definition p_reflexive {index:Type} (P:mixed_state -> Prop) (match_states: index -> mixed_state -> mixed_state -> Prop):Prop :=
  forall s, P s -> exists i, match_states i s s.

Inductive refl_point: mixed_state -> Prop :=
| refl_call:
    forall loc ms,
      refl_point (S_Call loc, ms).

Definition call_refl {index:Type} (match_states: index -> mixed_state -> mixed_state -> Prop) : Prop :=
  p_reflexive refl_point match_states.

(** * Forward Internal Simulations between two transition semantics. *)
(** The general form of a forward internal simulation. *)
Record forward_internal_simulation (p1 p2:program) (rtl1 rtl2: option (RTLfun+RTLblockfun)) (nc1 nc2: asm_codes) : Type :=
  Forward_internal_simulation {
    fsim_index: Type;
    fsim_order: fsim_index -> fsim_index -> Prop;
    fsim_order_wf: well_founded fsim_order;
    fsim_match_states :> fsim_index -> mixed_state -> mixed_state -> Prop;
    fsim_match_states_refl: call_refl fsim_match_states;
    fsim_match_final_states:
      forall i s1 s2 r,
      fsim_match_states i s1 s2 -> final_mixed_state p1 s1 r -> final_mixed_state p2 s2 r;
    fsim_simulation:
      forall s1 t s1', Step (mixed_sem p1 rtl1 nc1) s1 t s1' ->
      forall i s2, fsim_match_states i s1 s2 ->
      exists i', exists s2',
         (SPlus (mixed_sem p2 rtl2 nc2) s2 t s2' \/ (Star (mixed_sem p2 rtl2 nc2) s2 t s2' /\ fsim_order i' i))
      /\ fsim_match_states i' s1' s2';
  }.

(* Implicit Arguments forward_simulation []. *)
Arguments forward_internal_simulation: clear implicits.

(** An alternate form of the simulation diagram *)

Lemma fsim_simulation':
  forall p1 p2 rtl1 rtl2 nc1 nc2 (S: forward_internal_simulation p1 p2 rtl1 rtl2 nc1 nc2),
  forall i s1 t s1', Step (mixed_sem p1 rtl1 nc1) s1 t s1' ->
  forall s2, S i s1 s2 ->
  (exists i', exists s2', SPlus (mixed_sem p2 rtl2 nc2) s2 t s2' /\ S i' s1' s2')
  \/ (exists i', fsim_order S i' i /\ t = E0 /\ S i' s1' s2).
Proof.
  intros. exploit fsim_simulation; eauto.
  intros [i' [s2' [A B]]]. intuition.
  left; exists i'; exists s2'; auto.
  inv H2.
  right; exists i'; auto.
  left; exists i'; exists s2'; split; auto. econstructor; eauto.
Qed.

(** ** Forward simulation diagrams. *)

(** Various simulation diagrams that imply forward simulation *)
(* not needed *)

(** ** Forward simulation of transition sequences *)
(* not needed *)

(** ** Composing two forward simulations *)
(* We only compose backward simulations now *)

(** * Backward simulations between two transition semantics. *)
(** The general form of a backward internal simulation. *)
(* The one used as an invariant of the JIT execution, on silent semantics *)
Record backward_internal_simulation (p1 p2: program) (rtl1 rtl2:option (RTLfun+RTLblockfun)) (nc1 nc2: asm_codes): Type :=
  Backward_internal_simulation {
    bsim_index: Type;
    bsim_order: bsim_index -> bsim_index -> Prop;
    bsim_order_wf: well_founded bsim_order;
    (* bsim_order_trans: transitive _ bsim_order; *)
    bsim_match_states :> bsim_index -> mixed_state -> mixed_state -> Prop;
    bsim_match_states_refl: call_refl bsim_match_states;
    bsim_match_final_states:
      forall i s1 s2 r,
      bsim_match_states i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 -> final_mixed_state p2 s2 r ->
      exists s1', Star (mixed_sem p1 rtl1 nc1) s1 E0 s1' /\ final_mixed_state p1 s1' r;
    bsim_progress:
      forall i s1 s2,
      bsim_match_states i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
      (exists r, final_mixed_state p2 s2 r) \/
      (exists t, exists s2', Step (mixed_sem p2 rtl2 nc2) s2 t s2');
    bsim_simulation:
      forall s2 t s2', Step (mixed_sem p2 rtl2 nc2) s2 t s2' ->
      forall i s1, bsim_match_states i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
      exists i', exists s1',
         (SPlus (mixed_sem p1 rtl1 nc1) s1 t s1' \/ (Star (mixed_sem p1 rtl1 nc1) s1 t s1' /\ bsim_order i' i))
      /\ bsim_match_states i' s1' s2';
  }.

(** An alternate form of the simulation diagram *)
Lemma bsim_simulation':
  forall p1 p2 rtl1 rtl2 nc1 nc2 (S: backward_internal_simulation p1 p2 rtl1 rtl2 nc1 nc2),
  forall i s2 t s2', Step (mixed_sem p2 rtl2 nc2) s2 t s2' ->
  forall s1, S i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
  (exists i', exists s1', SPlus (mixed_sem p1 rtl1 nc1) s1 t s1' /\ S i' s1' s2')
  \/ (exists i', bsim_order S i' i /\ t = E0 /\ S i' s1 s2').
Proof.
  intros. exploit bsim_simulation; eauto.
  intros [i' [s1' [A B]]]. intuition.
  left; exists i'; exists s1'; auto.
  inv H3.
  right; exists i'; auto.
  left; exists i'; exists s1'; split; auto. econstructor; eauto.
Qed.

(** ** Backward simulation diagrams. *)

(** ** Backward simulation of transition sequences *)
Section BACKWARD_SIMULATION_SEQUENCES.

Variable p1 p2: program.
Variable rtl1 rtl2: option (RTLfun+RTLblockfun).
Variable nc1: asm_codes.
Variable nc2: asm_codes.
Variable S: backward_internal_simulation p1 p2 rtl1 rtl2 nc1 nc2.

Lemma bsim_E0_star:
  forall s2 s2', Star (mixed_sem p2 rtl2 nc2) s2 E0 s2' ->
  forall i s1, S i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
  exists i', exists s1', Star (mixed_sem p1 rtl1 nc1) s1 E0 s1' /\ S i' s1' s2'.
Proof.
  intros s20 s20' STAR0. pattern s20, s20'. eapply star_E0_ind; eauto.
(* base case *)
  intros. exists i; exists s1; split; auto. apply star_refl.
(* inductive case *)
  intros. exploit bsim_simulation; eauto. intros [i' [s1' [A B]]].
  assert (Star (mixed_sem p1 rtl1 nc1) s0 E0 s1'). intuition. apply plus_star; auto.
  exploit H0. eauto. eapply star_safe; eauto. intros [i'' [s1'' [C D]]].
  exists i''; exists s1''; split; auto. eapply star_trans; eauto.
Qed.

Lemma bsim_safe:
  forall i s1 s2,
  S i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 -> safe (mixed_sem p2 rtl2 nc2) s2.
Proof.
  intros; red; intros.
  exploit bsim_E0_star; eauto. intros [i' [s1' [A B]]].
  eapply bsim_progress; eauto. eapply star_safe; eauto.
Qed.

Lemma bsim_E0_plus:
  forall s2 t s2', SPlus (mixed_sem p2 rtl2 nc2) s2 t s2' -> t = E0 ->
  forall i s1, S i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
     (exists i', exists s1', SPlus (mixed_sem p1 rtl1 nc1) s1 E0 s1' /\ S i' s1' s2')
  \/ (exists i', clos_trans _ (bsim_order S) i' i /\ S i' s1 s2').
Proof.
  induction 1 using plus_ind2; intros; subst t.
(* base case *)
  exploit bsim_simulation'; eauto. intros [[i' [s1' [A B]]] | [i' [A [B C]]]].
  left; exists i'; exists s1'; auto.
  right; exists i'; intuition.
(* inductive case *)
  exploit Eapp_E0_inv; eauto. intros [EQ1 EQ2]; subst.
  exploit bsim_simulation'; eauto. intros [[i' [s1' [A B]]] | [i' [A [B C]]]].
  exploit bsim_E0_star. apply plus_star with (s2:=s3); eauto. eauto. eapply star_safe; eauto. apply plus_star; auto.
  intros [i'' [s1'' [P Q]]].
  left; exists i''; exists s1''; intuition. eapply plus_star_trans; eauto.
  exploit IHplus; eauto. intros [P | [i'' [P Q]]].
  left; auto.
  right; exists i''; intuition. eapply t_trans; eauto. apply t_step; auto.
Qed.

Lemma star_non_E0_split:
  forall s2 t s2', Star (mixed_sem p2 rtl2 nc2) s2 t s2' -> (length t = 1)%nat ->
  exists s2x, exists s2y, Star (mixed_sem p2 rtl2 nc2) s2 E0 s2x /\ Step (mixed_sem p2 rtl2 nc2) s2x t s2y /\ Star (mixed_sem p2 rtl2 nc2) s2y E0 s2'.
Proof.
  induction 1; intros.
  simpl in H; discriminate.
  subst t.
  assert (EITHER: t1 = E0 \/ t2 = E0).
    unfold Eapp in H2; rewrite app_length in H2.
    destruct t1; auto. destruct t2; auto. simpl in H2; omegaContradiction.
  destruct EITHER; subst.
  exploit IHstar; eauto. intros [s2x [s2y [A [B C]]]].
  exists s2x; exists s2y; intuition. eapply star_left; eauto.
  rewrite E0_right. exists s1; exists s2; intuition. apply star_refl.
Qed.

End BACKWARD_SIMULATION_SEQUENCES.

(* Transitive closure is transitive *)
Lemma clos_trans_trans :
  forall (X:Type) R, transitive X (clos_trans X R).
Proof.
  intros X R. unfold transitive. intros x y z H. generalize dependent z.
  induction H; intros.
  - apply t_trans with (y:=y). apply t_step. auto. auto.
  - apply IHclos_trans1. apply IHclos_trans2. auto.
Qed.

(** ** Composing two backward simulations *)

Section COMPOSE_INTERNAL_BACKWARD_SIMULATIONS.

Variable p1 p2 p3: program.
Variable rtl1 rtl2 rtl3: option (RTLfun+RTLblockfun).
Variable nc1: asm_codes.
Variable nc2: asm_codes.
Variable nc3: asm_codes.
Hypothesis p3_single_events: single_events (mixed_sem p3 rtl3 nc3).
Variable S12: backward_internal_simulation p1 p2 rtl1 rtl2 nc1 nc2.
Variable S23: backward_internal_simulation p2 p3 rtl2 rtl3 nc2 nc3.

Let bb_index : Type := (bsim_index S12 * bsim_index S23)%type.

Let bb_order : bb_index -> bb_index -> Prop :=
  lex_ord (clos_trans _ (bsim_order S12)) (bsim_order S23).

Inductive bb_match_states: bb_index -> mixed_state -> mixed_state -> Prop :=
  | bb_match_later: forall i1 i2 s1 s3 s2x s2y,
      S12 i1 s1 s2x -> Star (mixed_sem p2 rtl2 nc2) s2x E0 s2y -> S23 i2 s2y s3 ->
      bb_match_states (i1, i2) s1 s3.

Lemma bb_match_at: forall i1 i2 s1 s3 s2,
  S12 i1 s1 s2 -> S23 i2 s2 s3 ->
  bb_match_states (i1, i2) s1 s3.
Proof.
  intros. econstructor; eauto. apply star_refl.
Qed.

Lemma bb_simulation_base:
  forall s3 t s3', Step (mixed_sem p3 rtl3 nc3) s3 t s3' ->
  forall i1 s1 i2 s2, S12 i1 s1 s2 -> S23 i2 s2 s3 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
  exists i', exists s1',
    (SPlus (mixed_sem p1 rtl1 nc1) s1 t s1' \/ (Star (mixed_sem p1 rtl1 nc1) s1 t s1' /\ bb_order i' (i1, i2)))
    /\ bb_match_states i' s1' s3'.
Proof.
  intros.
  exploit (bsim_simulation' S23); eauto. eapply bsim_safe; eauto.
  intros [ [i2' [s2' [PLUS2 MATCH2]]] | [i2' [ORD2 [EQ MATCH2]]]].
  (* 1 L2 makes one or several transitions *)
  assert (EITHER: t = E0 \/ (length t = 1)%nat).
  exploit p3_single_events; eauto.
    destruct t; auto. destruct t; auto. simpl. intros. omegaContradiction.
  destruct EITHER.
  (* 1.1 these are silent transitions *)
  subst t. exploit bsim_E0_plus; eauto.
  intros [ [i1' [s1' [PLUS1 MATCH1]]] | [i1' [ORD1 MATCH1]]].
  (* 1.1.1 L1 makes one or several transitions *)
  exists (i1', i2'); exists s1'; split. auto. eapply bb_match_at; eauto.
  (* 1.1.2 L1 makes no transitions *)
  exists (i1', i2'); exists s1; split.
  right; split. apply star_refl. left; auto.
  eapply bb_match_at; eauto.
  (* 1.2 non-silent transitions *)
  exploit star_non_E0_split. apply plus_star; eauto. auto.
  intros [s2x [s2y [P [Q R]]]].
  exploit bsim_E0_star. eexact P. eauto. auto. intros [i1' [s1x [X Y]]].
  exploit bsim_simulation'. eexact Q. eauto. eapply star_safe; eauto.
  intros [[i1'' [s1y [U V]]] | [i1'' [U [V W]]]]; try (subst t; discriminate).
  exists (i1'', i2'); exists s1y; split.
  left. eapply star_plus_trans; eauto. eapply bb_match_later; eauto.
  (* 2. L2 makes no transitions *)
  subst. exists (i1, i2'); exists s1; split.
  right; split. apply star_refl. right; auto.
  eapply bb_match_at; eauto.
Qed.

Lemma bb_simulation:
  forall s3 t s3', Step (mixed_sem p3 rtl3 nc3) s3 t s3' ->
  forall i s1, bb_match_states i s1 s3 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
  exists i', exists s1',
    (SPlus (mixed_sem p1 rtl1 nc1) s1 t s1' \/ (Star (mixed_sem p1 rtl1 nc1) s1 t s1' /\ bb_order i' i))
    /\ bb_match_states i' s1' s3'.
Proof.
  intros. inv H0.
  exploit star_inv; eauto. intros [[EQ1 EQ2] | PLUS].
  (* 1. match at *)
  subst. eapply bb_simulation_base; eauto.
  (* 2. match later *)
  exploit bsim_E0_plus; eauto.
  intros [[i1' [s1' [A B]]] | [i1' [A B]]].
  (* 2.1 one or several silent transitions *)
  exploit bb_simulation_base. eauto. auto. eexact B. eauto.
    eapply star_safe; eauto. eapply plus_star; eauto.
  intros [i'' [s1'' [C D]]].
  exists i''; exists s1''; split; auto.
  left. eapply plus_star_trans; eauto.
  destruct C as [P | [P Q]]. apply plus_star; eauto. eauto.
  traceEq.
  (* 2.2 no silent transition *)
  exploit bb_simulation_base. eauto. auto. eexact B. eauto. auto.
  intros [i'' [s1'' [C D]]].
  exists i''; exists s1''; split; auto.
  intuition. right; intuition.
  inv H6. left. eapply t_trans; eauto. left; auto.
Qed.

Lemma compose_backward_simulation: backward_internal_simulation p1 p3 rtl1 rtl3 nc1 nc3.
Proof.
  apply Backward_internal_simulation with (bsim_order := bb_order) (bsim_match_states := bb_match_states).
(* well founded *)
  unfold bb_order. apply wf_lex_ord. apply wf_clos_trans. apply bsim_order_wf. apply bsim_order_wf.
  (* transitivity *)
  (* { unfold bb_order. apply transitive_lex_ord. *)
  (*   - apply clos_trans_trans. *)
  (*   - apply (bsim_order_trans S23). }   *)
  (* reflexivity *)
  { unfold call_refl, p_reflexive. intros s REFL.
    specialize (bsim_match_states_refl S12). intros H. unfold call_refl, p_reflexive in H.
    specialize (H s REFL). destruct H as [i2 MATCH1].
    specialize (bsim_match_states_refl S23). intros H. unfold call_refl, p_reflexive in H.
    specialize (H s REFL). destruct H as [i3 MATCH2].
    exists (i2, i3). eapply bb_match_at; eauto. }
(* match final states *)
  intros i s1 s3 r MS SAFE FIN. inv MS.
  exploit (bsim_match_final_states S23); eauto.
    eapply star_safe; eauto. eapply bsim_safe; eauto.
  intros [s2' [A B]].
  exploit bsim_E0_star. eapply star_trans. eexact H0. eexact A. auto. eauto. auto.
  intros [i1' [s1' [C D]]].
  exploit (bsim_match_final_states S12); eauto. eapply star_safe; eauto.
  intros [s1'' [P Q]].
  exists s1''; split; auto. eapply star_trans; eauto.
(* progress *)
  intros i s1 s3 MS SAFE. inv MS.
  eapply (bsim_progress S23). eauto. eapply star_safe; eauto. eapply bsim_safe; eauto.
(* simulation *)
  exact bb_simulation.
Qed.

End COMPOSE_INTERNAL_BACKWARD_SIMULATIONS.

Section FORWARD_TO_BACKWARD.

Variable p1 p2: program.
Variable rtl1 rtl2: option (RTLfun+RTLblockfun).
Variable nc1: asm_codes.
Variables nc2: asm_codes.
Variable FS: forward_internal_simulation p1 p2 rtl1 rtl2 nc1 nc2.
Hypothesis p1_receptive: receptive (mixed_sem p1 rtl1 nc1).
Hypothesis p2_determinate: determinate (mixed_sem p2 rtl2 nc2).

(** Exploiting forward simulation *)

Inductive f2b_transitions: mixed_state -> mixed_state -> Prop :=
  | f2b_trans_final: forall s1 s2 s1' r,
      Star (mixed_sem p1 rtl1 nc1) s1 E0 s1' ->
      final_mixed_state p1 s1' r ->
      final_mixed_state p2 s2 r ->
      f2b_transitions s1 s2
  | f2b_trans_step: forall s1 s2 s1' t s1'' s2' i' i'',
      Star (mixed_sem p1 rtl1 nc1) s1 E0 s1' ->
      Step (mixed_sem p1 rtl1 nc1) s1' t s1'' ->
      SPlus (mixed_sem p2 rtl2 nc2) s2 t s2' ->
      FS i' s1' s2 ->
      FS i'' s1'' s2' ->
      f2b_transitions s1 s2.

Lemma f2b_progress:
  forall i s1 s2, FS i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 -> f2b_transitions s1 s2.
Proof.
  intros i0; pattern i0. apply well_founded_ind with (R := fsim_order FS).
  apply fsim_order_wf.
  intros i REC s1 s2 MATCH SAFE.
  destruct (SAFE s1) as [[r FINAL] | [t [s1' STEP1]]]. apply star_refl.
  (* final state reached *)
  eapply f2b_trans_final; eauto.
  apply star_refl.
  eapply fsim_match_final_states; eauto.
  (* L1 can make one step *)
  exploit (fsim_simulation FS); eauto. intros [i' [s2' [A MATCH']]].
  assert (B: SPlus (mixed_sem p2 rtl2 nc2) s2 t s2' \/ (s2' = s2 /\ t = E0 /\ fsim_order FS i' i)).
    intuition.
    destruct (star_inv H0); intuition.
  clear A. destruct B as [PLUS2 | [EQ1 [EQ2 ORDER]]].
  eapply f2b_trans_step; eauto. apply star_refl.
  subst. exploit REC; eauto. eapply star_safe; eauto. apply star_one; auto.
  intros TRANS; inv TRANS.
  eapply f2b_trans_final with (s1':=s1'0); eauto. eapply star_left; eauto.
  eapply f2b_trans_step; eauto. eapply star_left; eauto.
Qed.

Lemma fsim_simulation_not_E0:
  forall s1 t s1', Step (mixed_sem p1 rtl1 nc1) s1 t s1' -> t <> E0 ->
  forall i s2, FS i s1 s2 ->
  exists i', exists s2', SPlus (mixed_sem p2 rtl2 nc2) s2 t s2' /\ FS i' s1' s2'.
Proof.
  intros. exploit (fsim_simulation FS); eauto. intros [i' [s2' [A B]]].
  exists i'; exists s2'; split; auto.
  destruct A. auto. destruct H2. exploit star_inv; eauto. intros [[EQ1 EQ2] | P]; auto.
  congruence.
Qed.

(** Exploiting determinacy *)

Remark silent_or_not_silent:
  forall t, t = E0 \/ t <> E0.
Proof.
  intros; unfold E0; destruct t; auto; right; congruence.
Qed.

Remark not_silent_length:
  forall t1 t2, (length (t1 ** t2) <= 1)%nat -> t1 = E0 \/ t2 = E0.
Proof.
  unfold Eapp, E0; intros. rewrite app_length in H.
  destruct t1; destruct t2; auto. simpl in H. omegaContradiction.
Qed.

Lemma f2b_determinacy_inv:
  forall s2 t' s2' t'' s2'',
  Step (mixed_sem p2 rtl2 nc2) s2 t' s2' -> Step (mixed_sem p2 rtl2 nc2) s2 t'' s2'' ->
  (t' = E0 /\ t'' = E0 /\ s2' = s2'')
  \/ (t' <> E0 /\ t'' <> E0 /\ match_traces (* (symbolenv L1) *) t' t'').
Proof.
  intros.
  assert (match_traces (* (symbolenv L2) *) t' t'').
    eapply sd_determ_1; eauto.
  destruct (silent_or_not_silent t').
  subst. inv H1.
  left; intuition. eapply sd_determ_2; eauto.
  destruct (silent_or_not_silent t'').
  subst. inv H1. elim H2; auto.
  right; intuition.
Qed.

Lemma f2b_determinacy_star:
  forall s s1, Star (mixed_sem p2 rtl2 nc2) s E0 s1 ->
  forall t s2 s3,
  Step (mixed_sem p2 rtl2 nc2) s1 t s2 -> t <> E0 ->
  Star (mixed_sem p2 rtl2 nc2) s t s3 ->
  Star (mixed_sem p2 rtl2 nc2) s1 t s3.
Proof.
  intros s0 s01 ST0. pattern s0, s01. eapply star_E0_ind; eauto.
  intros. inv H3. congruence.
  exploit f2b_determinacy_inv. eexact H. eexact H4.
  intros [[EQ1 [EQ2 EQ3]] | [NEQ1 [NEQ2 MT]]].
  subst. simpl in *. eauto.
  congruence.
Qed.

(** Orders *)

Inductive f2b_index : Type :=
  | F2BI_before (n: nat)
  | F2BI_after (n: nat).

Inductive f2b_order: f2b_index -> f2b_index -> Prop :=
  | f2b_order_before: forall n n',
      (n' < n)%nat ->
      f2b_order (F2BI_before n') (F2BI_before n)
  | f2b_order_after: forall n n',
      (n' < n)%nat ->
      f2b_order (F2BI_after n') (F2BI_after n)
  | f2b_order_switch: forall n n',
      f2b_order (F2BI_before n') (F2BI_after n).

Lemma wf_f2b_order:
  well_founded f2b_order.
Proof.
  assert (ACC1: forall n, Acc f2b_order (F2BI_before n)).
    intros n0; pattern n0; apply lt_wf_ind; intros.
    constructor; intros. inv H0. auto.
  assert (ACC2: forall n, Acc f2b_order (F2BI_after n)).
    intros n0; pattern n0; apply lt_wf_ind; intros.
    constructor; intros. inv H0. auto. auto.
  red; intros. destruct a; auto.
Qed.

Lemma trans_f2b_order:
  transitive _ f2b_order.
Proof.
  unfold transitive. intros x y z HXY HYZ.
  inv HXY; inv HYZ.
  - constructor. omega.
  - constructor.
  - constructor. omega.
  - constructor.
Qed.

(** Constructing the backward simulation *)

Inductive f2b_match_states: f2b_index -> mixed_state -> mixed_state -> Prop :=
  | f2b_match_at: forall i s1 s2,
      FS i s1 s2 ->
      f2b_match_states (F2BI_after O) s1 s2
  | f2b_match_before: forall s1 t s1' s2b s2 n s2a i,
      Step (mixed_sem p1 rtl1 nc1) s1 t s1' ->  t <> E0 ->
      Star (mixed_sem p2 rtl2 nc2) s2b E0 s2 ->
      starN (step (mixed_sem p2 rtl2 nc2)) (globalenv (mixed_sem p2 rtl2 nc2)) n s2 t s2a ->
      FS i s1 s2b ->
      f2b_match_states (F2BI_before n) s1 s2
  | f2b_match_after: forall n s2 s2a s1 i,
      starN (step (mixed_sem p2 rtl2 nc2)) (globalenv (mixed_sem p2 rtl2 nc2)) (S n) s2 E0 s2a ->
      FS i s1 s2a ->
      f2b_match_states (F2BI_after (S n)) s1 s2.

Remark f2b_match_after':
  forall n s2 s2a s1 i,
  starN (step (mixed_sem p2 rtl2 nc2)) (globalenv (mixed_sem p2 rtl2 nc2)) n s2 E0 s2a ->
  FS i s1 s2a ->
  f2b_match_states (F2BI_after n) s1 s2.
Proof.
  intros. inv H.
  econstructor; eauto.
  econstructor; eauto. econstructor; eauto.
Qed.

(** Backward simulation of L2 steps *)

Lemma f2b_simulation_step:
  forall s2 t s2', Step (mixed_sem p2 rtl2 nc2) s2 t s2' ->
  forall i s1, f2b_match_states i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
  exists i', exists s1',
    (SPlus (mixed_sem p1 rtl1 nc1) s1 t s1' \/ (Star (mixed_sem p1 rtl1 nc1) s1 t s1' /\ f2b_order i' i))
     /\ f2b_match_states i' s1' s2'.
Proof.
  intros s2 t s2' STEP2 i s1 MATCH SAFE.
  inv MATCH.
(* 1. At matching states *)
  exploit f2b_progress; eauto. intros TRANS; inv TRANS.
  (* 1.1  L1 can reach final state and L2 is at final state: impossible! *)
  exploit (sd_final_nostep p2_determinate); eauto. contradiction.
  (* 1.2  L1 can make 0 or several steps; L2 can make 1 or several matching steps. *)
  inv H2.
  exploit f2b_determinacy_inv. eexact H5. eexact STEP2.
  intros [[EQ1 [EQ2 EQ3]] | [NOT1 [NOT2 MT]]].
  (* 1.2.1  L2 makes a silent transition *)
  destruct (silent_or_not_silent t2).
  (* 1.2.1.1  L1 makes a silent transition too: perform transition now and go to "after" state *)
  subst. simpl in *. destruct (star_starN H6) as [n STEPS2].
  exists (F2BI_after n); exists s1''; split.
  left. eapply plus_right; eauto.
  eapply f2b_match_after'; eauto.
  (* 1.2.1.2 L1 makes a non-silent transition: keep it for later and go to "before" state *)
  subst. simpl in *. destruct (star_starN H6) as [n STEPS2].
  exists (F2BI_before n); exists s1'; split.
  right; split. auto. constructor.
  econstructor. eauto. auto. apply star_one; eauto. eauto. eauto.
  (* 1.2.2 L2 makes a non-silent transition, and so does L1 *)
  exploit not_silent_length. eapply (sr_traces p1_receptive); eauto. intros [EQ | EQ].
  congruence.
  subst t2. rewrite E0_right in H1.
  (* Use receptiveness to equate the traces *)
  exploit (sr_receptive p1_receptive). apply H1. apply MT. eauto. intros [s1''' STEP1].
  exploit fsim_simulation_not_E0. eexact STEP1. auto. eauto.
  intros [i''' [s2''' [P Q]]]. inv P.
  (* Exploit determinacy *)
  exploit not_silent_length. eapply (sr_traces p1_receptive); eauto. intros [EQ | EQ].
  subst t0. simpl in *. exploit sd_determ_1. eauto. eexact STEP2. eexact H2.
  intros. elim NOT2. inv H8. auto.
  subst t2. rewrite E0_right in *.
  assert (s4 = s2'). eapply sd_determ_2; eauto. subst s4.
  (* Perform transition now and go to "after" state *)
  destruct (star_starN H7) as [n STEPS2]. exists (F2BI_after n); exists s1'''; split.
  left. eapply plus_right; eauto.
  eapply f2b_match_after'; eauto.

(* 2. Before *)
  inv H2. congruence.
  exploit f2b_determinacy_inv. eexact H4. eexact STEP2.
  intros [[EQ1 [EQ2 EQ3]] | [NOT1 [NOT2 MT]]].
  (* 2.1 L2 makes a silent transition: remain in "before" state *)
  subst. simpl in *. exists (F2BI_before n0); exists s1; split.
  right; split. apply star_refl. constructor. omega.
  econstructor; eauto. eapply star_right; eauto.
  (* 2.2 L2 make a non-silent transition *)
  exploit not_silent_length. eapply (sr_traces p1_receptive); eauto. intros [EQ | EQ].
  congruence.
  subst. rewrite E0_right in *.
  (* Use receptiveness to equate the traces *)
  exploit (sr_receptive p1_receptive). apply H. apply MT. intros [s1''' STEP1].
  exploit fsim_simulation_not_E0. eexact STEP1. auto. eauto.
  intros [i''' [s2''' [P Q]]].
  (* Exploit determinacy *)
  exploit f2b_determinacy_star. eauto. eexact STEP2. auto. apply plus_star; eauto.
  intro R. inv R. congruence.
  exploit not_silent_length. eapply (sr_traces p1_receptive); eauto. intros [EQ | EQ].
  subst. simpl in *. exploit sd_determ_1. eauto. eexact STEP2. eexact H2.
  intros. elim NOT2. inv H7; auto.
  subst. rewrite E0_right in *.
  assert (s3 = s2'). eapply sd_determ_2; eauto. subst s3.
  (* Perform transition now and go to "after" state *)
  destruct (star_starN H6) as [n STEPS2]. exists (F2BI_after n); exists s1'''; split.
  left. apply plus_one; auto.
  eapply f2b_match_after'; eauto.

(* 3. After *)
  inv H. exploit Eapp_E0_inv; eauto. intros [EQ1 EQ2]; subst.
  exploit f2b_determinacy_inv. eexact H2. eexact STEP2.
  intros [[EQ1 [EQ2 EQ3]] | [NOT1 [NOT2 MT]]].
  subst. exists (F2BI_after n); exists s1; split.
  right; split. apply star_refl. constructor; omega.
  eapply f2b_match_after'; eauto.
  congruence.
Qed.

(** The backward simulation *)

Lemma forward_to_backward_simulation: backward_internal_simulation p1 p2 rtl1 rtl2 nc1 nc2.
Proof.
  eapply Backward_internal_simulation.
   (* with (bsiml_order := f2b_order). (bsiml_match_states := f2b_match_states). *)
  apply wf_f2b_order.
  (* transitivity *)
  (* apply trans_f2b_order. *)
  (* reflexivity *)
  { unfold call_refl, p_reflexive. intros s REFL.
    specialize (fsim_match_states_refl FS). intros H. unfold call_refl, p_reflexive in H.
    specialize (H s REFL). destruct H as [i MATCH].
    exists (F2BI_after 0). eapply f2b_match_at. eauto. }
(* final states *)
  intros. inv H.
  exploit f2b_progress; eauto. intros TRANS; inv TRANS.
  assert (r0 = r) by (eapply (sd_final_determ p2_determinate); eauto). subst r0.
  exists s1'; auto.
  inv H4. exploit (sd_final_nostep p2_determinate); eauto. contradiction.
  inv H5. congruence. exploit (sd_final_nostep p2_determinate); eauto. contradiction.
  inv H2. exploit (sd_final_nostep p2_determinate); eauto. contradiction.
(* progress *)
  intros. inv H.
  exploit f2b_progress; eauto. intros TRANS; inv TRANS.
  left; exists r; auto.
  inv H3. right; econstructor; econstructor; eauto.
  inv H4. congruence. right; econstructor; econstructor; eauto.
  inv H1. right; econstructor; econstructor; eauto.
(* simulation *)
  exact f2b_simulation_step.
Qed.

End FORWARD_TO_BACKWARD.

(** * Alernate internal backward definition  *)
(* Where the order and match_states relation are made parameters *)
(* This helps writing the external simulation invariant *)

Record backward_internal_simulation' (p1 p2: program) (rtl1 rtl2:option (RTLfun+RTLblockfun)) (nc1 nc2: asm_codes)
       (idxt: Type)
       (order: idxt -> idxt -> Prop)
       (match_states: idxt -> mixed_state -> mixed_state -> Prop)
  : Type :=
  Backward_internal_simulation' {
    order_wf: well_founded order;
    (* order_trans: transitive _ order;   *)
    match_states_refl: call_refl match_states;
    match_final_states:
      forall i s1 s2 r,
      match_states i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 -> final_mixed_state p2 s2 r ->
      exists s1', Star (mixed_sem p1 rtl1 nc1) s1 E0 s1' /\ final_mixed_state p1 s1' r;
    progress:
      forall i s1 s2,
      match_states i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
      (exists r, final_mixed_state p2 s2 r) \/
      (exists t, exists s2', Step (mixed_sem p2 rtl2 nc2) s2 t s2');
    simulation:
      forall s2 t s2', Step (mixed_sem p2 rtl2 nc2) s2 t s2' ->
      forall i s1, match_states i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
      exists i', exists s1',
         (SPlus (mixed_sem p1 rtl1 nc1) s1 t s1' \/ (Star (mixed_sem p1 rtl1 nc1) s1 t s1' /\ order i' i))
      /\ match_states i' s1' s2';
  }.

Lemma bsim_simulation'':
  forall p1 p2 rtl1 rtl2 nc1 nc2 idx (ord:idx->idx->Prop) ms
    (S: backward_internal_simulation' p1 p2 rtl1 rtl2 nc1 nc2 ord ms),
  forall i s2 t s2', Step (mixed_sem p2 rtl2 nc2) s2 t s2' ->
  forall s1, ms i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
  (exists i', exists s1', SPlus (mixed_sem p1 rtl1 nc1) s1 t s1' /\ ms i' s1' s2')
  \/ (exists i', ord i' i /\ t = E0 /\ ms i' s1 s2').
Proof.
  intros. exploit simulation; eauto.
  intros [i' [s1' [A B]]]. intuition.
  left; exists i'; exists s1'; auto.
  inv H3.
  right; exists i'; auto.
  left; exists i'; exists s1'; split; auto. econstructor; eauto.
Qed.

(* Equivalence between the two definition *)
Theorem backward_eq:
  forall p1 p2 rtl1 rtl2 nc1 nc2,
    backward_internal_simulation p1 p2 rtl1 rtl2 nc1 nc2 ->
    exists idxt (order:idxt->idxt->Prop) ms, backward_internal_simulation' p1 p2 rtl1 rtl2 nc1 nc2 order ms.
Proof.
  intros p1 p2 rtl1 rtl2 nc1 nc2 X. exists (bsim_index X). exists (bsim_order X). exists (bsim_match_states X).
  apply Backward_internal_simulation'; destruct X; auto.
Qed.

Theorem eq_backward:
  forall p1 p2 rtl1 rtl2 nc1 nc2,
  forall idxt (order:idxt->idxt->Prop) ms, backward_internal_simulation' p1 p2 rtl1 rtl2 nc1 nc2 order ms ->
                                 backward_internal_simulation p1 p2 rtl1 rtl2 nc1 nc2.
Proof.
  intros p1 p2 rtl1 rtl2 nc1 nc2 idxt order ms H.
  apply Backward_internal_simulation with (bsim_order:=order) (bsim_match_states:=ms);
    destruct H; auto.
Qed.

(** * Backward simulation reflexivity  *)
(* This is used at the very beginning of the JIT proof, to show that there is an internal simulation between the initial program and itself *)
Definition refl_type := unit.
Inductive refl_order: unit -> unit -> Prop := .
Inductive refl_match_states: refl_type -> mixed_state -> mixed_state -> Prop :=
| match_same: forall s, refl_match_states tt s s.

Theorem wf_refl: well_founded refl_order.
Proof.
  unfold well_founded. intros. destruct a. constructor. intros. inv H.
Qed.

Theorem refl_refl: reflexive refl_match_states.
Proof.
  unfold reflexive. intros. exists tt. constructor.
Qed.

Theorem trans_refl: transitive _ refl_order.
Proof.
  unfold transitive. intros. inv H.
Qed.

Lemma backward_refl:
  forall p nc rtl,
    backward_internal_simulation' p p rtl rtl nc nc refl_order refl_match_states.
Proof.
  intros p rtl nc. apply Backward_internal_simulation'.
  - apply wf_refl.
  (* - apply trans_refl. *)
  - unfold call_refl, p_reflexive. intros s REFL. exists tt. split; auto.
  - intros i s1 s2 r H H0 H1. inv H. exists s2. split. apply star_refl. auto.
  - intros i s1 s2 H H0. inv H. unfold safe in H0. apply H0. apply star_refl.
  - intros s2 t s2' H i s1 H0 H1. inv H0. exists tt. exists s2'. split.
    left. apply plus_one. auto. constructor.
Qed.

(* non-explicit version *)
Lemma backward_internal_reflexivity:
  forall p rtl nc, backward_internal_simulation p p rtl rtl nc nc.
Proof.
  intros p rtl nc. eapply eq_backward. eapply backward_refl.
Qed.

(** * Exploiting Sequences  *)

(* Exploiting silent stars *)
Lemma bsim_E0_star':
  forall (p1 p2: program) (rtl1 rtl2:option (RTLfun+RTLblockfun)) (nc1 nc2:asm_codes) idxt (ord:idxt->idxt->Prop) ms
    (S: backward_internal_simulation' p1 p2 rtl1 rtl2 nc1 nc2 ord ms),
  forall s2 s2', Star (mixed_sem p2 rtl2 nc2) s2 E0 s2' ->
  forall i s1, ms i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
  exists i', exists s1', Star (mixed_sem p1 rtl1 nc1) s1 E0 s1' /\ ms i' s1' s2'.
Proof.
  intros p1 p2 rtl1 rtl2 nc1 nc2 idxt ord ms S.
  intros s20 s20' STAR0. pattern s20, s20'. eapply star_E0_ind; eauto.
(* base case *)
  intros. exists i; exists s1; split; auto. apply star_refl.
(* inductive case *)
  intros. exploit simulation; eauto. intros [i' [s1' [A B]]].
  assert (Star (mixed_sem p1 rtl1 nc1) s0 E0 s1'). intuition. apply plus_star; auto.
  exploit H0. eauto. eapply star_safe; eauto. intros [i'' [s1'' [C D]]].
  exists i''; exists s1''; split; auto. eapply star_trans; eauto.
Qed.

(* Exploiting silent plus *)
(* We use the transitivity of the order to make this possible *)
(* This shows that on a PLUS we can have a simulation diagram without changing orders *)
(* Lemma bsim_E0_plus': *)
(*   forall (p1 p2: program) (rtl1 rtl2: option RTLfun) (nc1 nc2: asm_codes) idxt (ord:idxt->idxt->Prop) ms *)
(*     (S: backward_internal_simulation' p1 p2 rtl1 rtl2 nc1 nc2 ord ms), *)
(*   forall s2 t s2', SPlus (mixed_sem p2 rtl2 nc2) s2 t s2' -> t = E0 -> *)
(*   forall i s1, ms i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 -> *)
(*      (exists i', exists s1', SPlus (mixed_sem p1 rtl1 nc1) s1 E0 s1' /\ ms i' s1' s2') *)
(*   \/ (exists i', ord i' i /\ ms i' s1 s2'). *)
(* Proof. *)
(*   intros p1 p2 rtl1 rtl2 nc1 nc2 idxt ord ms S. *)
(*   induction 1 using plus_ind2; intros; subst t. *)
(* (* base case *) *)
(*   exploit bsim_simulation''; eauto. intros [[i' [s1' [A B]]] | [i' [A [B C]]]]. *)
(*   left; exists i'; exists s1'; auto. *)
(*   right; exists i'; intuition. *)
(* (* inductive case *) *)
(*   exploit Eapp_E0_inv; eauto. intros [EQ1 EQ2]; subst. *)
(*   exploit bsim_simulation''; eauto. *)
(*   intros [[i' [s1' [A B]]] | [i' [A [B C]]]]. *)
(*   exploit bsim_E0_star'. eauto. apply plus_star with (s1:=s2); eauto. eauto.  *)
(*   eapply star_safe; eauto. apply plus_star; eauto. *)
(*   intros [i'' [s1'' [P Q]]]. *)
(*   left; exists i''; exists s1''; intuition. eapply plus_star_trans; eauto. *)
(*   exploit IHplus; eauto. intros [P | [i'' [P Q]]]. *)
(*   left; auto. *)
(*   right; exists i''; intuition. assert (OT: transitive _ ord) by apply (order_trans S). *)
(*   unfold transitive in OT. eapply OT; eauto. *)
(* Qed. *)

Lemma star_E0:
  forall p rtl nc s1 s2,
    Star (mixed_sem p rtl nc) s1 E0 s2 ->
    SPlus (mixed_sem p rtl nc) s1 E0 s2 \/ s1 = s2.
Proof.
  intros. inv H.
  right. auto. left. econstructor; eauto.
Qed.

(* Lemma exploit_starstep: *)
(*   forall (p1 p2: program) (rtl1 rtl2:option RTLfun) (nc1 nc2:asm_codes) idxt (ord:idxt->idxt->Prop) ms *)
(*     (S: backward_internal_simulation' p1 p2 rtl1 rtl2 nc1 nc2 ord ms), *)
(*   forall s2 t s2' s2'', Star (mixed_sem p2 rtl2 nc2) s2 E0 s2' -> *)
(*                    Step (mixed_sem p2 rtl2 nc2) s2' t s2'' -> *)
(*   forall i s1, ms i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 -> *)
(*           exists i', exists s1', (SPlus (mixed_sem p1 rtl1 nc1) s1 t s1' \/ (Star (mixed_sem p1 rtl1 nc1) s1 t s1' /\ ord i' i) ) /\ *)
(*                        ms i' s1' s2''. *)
(* Proof. *)
(*   intros p1 p2 rtl1 rtl2 nc1 nc2 idxt ord ms S s2 t s2' s2'' STAR STEP i s1 MATCH SAFE. *)
(*   apply star_E0 in STAR. destruct STAR as [PLUS | EQ]. *)
(*   - specialize (bsim_E0_plus' S PLUS eq_refl i MATCH SAFE). *)
(*     intros [[i' [s1' [PLUSSRC MATCH']]]|[i' [ORD MATCH']]]. *)
(*     + assert (SAFE': safe (mixed_sem p1 rtl1 nc1) s1'). *)
(*       { eapply star_safe; eauto. apply plus_star. auto. } *)
(*       specialize ((simulation S) s2' t s2'' STEP i' s1' MATCH' SAFE'). *)
(*       intros [i'' [s1'' [[PLUS' | [STAR ORD]] MATCH'']]]. *)
(*       * exists i''. exists s1''. split; auto. left. eapply plus_trans; eauto. *)
(*       * exists i''. exists s1''. split; auto. left. eapply plus_star_trans; eauto. *)
(*     + specialize ((simulation S) s2' t s2'' STEP i' s1 MATCH' SAFE). *)
(*       intros [i'' [s1'' [[PLUS' | [STAR ORD']] MATCH'']]]. *)
(*       * exists i''. exists s1''. split; auto. *)
(*       * exists i''. exists s1''. split; auto. right. split; auto. *)
(*         assert (TRANS: transitive _ ord) by apply (order_trans S). unfold transitive in TRANS. *)
(*         eapply TRANS; eauto. *)
(*   - subst. *)
(*     specialize ((simulation S) s2' t s2'' STEP i s1 MATCH SAFE). *)
(*     intros [i' [s1' [[PLUS | [STAR ORD]] MATCH']]]. *)
(*     + exists i'. exists s1'. split; auto. *)
(*     + exists i'. exists s1'. split; auto. *)
(* Qed. *)

(** * Composing simulations explicitely  *)
Lemma bsim_E0_star'':
  forall p1 p2 rtl1 rtl2 nc1 nc2 i (ord:i->i->Prop) ms
    (SIM: backward_internal_simulation' p1 p2 rtl1 rtl2 nc1 nc2 ord ms),
  forall s2 s2', Star (mixed_sem p2 rtl2 nc2) s2 E0 s2' ->
  forall i s1, ms i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
  exists i', exists s1', Star (mixed_sem p1 rtl1 nc1) s1 E0 s1' /\ ms i' s1' s2'.
Proof.
  intros p1 p2 rtl1 rtl2 nc1 nc2 idx ord ms SIM.
  intros s20 s20' STAR0. pattern s20, s20'. eapply star_E0_ind; eauto.
(* base case *)
  intros. exists i; exists s1; split; auto. apply star_refl.
(* inductive case *)
  intros. exploit simulation; eauto. intros [i' [s1' [A B]]].
  assert (Star (mixed_sem p1 rtl1 nc1) s0 E0 s1'). intuition. apply plus_star; auto.
  exploit H0. eauto. eapply star_safe; eauto. intros [i'' [s1'' [C D]]].
  exists i''; exists s1''; split; auto. eapply star_trans; eauto.
Qed.

Lemma bsim_E0_plus'':
  forall p1 p2 rtl1 rtl2 nc1 nc2 i (ord:i->i->Prop) ms
    (SIM: backward_internal_simulation' p1 p2 rtl1 rtl2 nc1 nc2 ord ms),
  forall s2 t s2', SPlus (mixed_sem p2 rtl2 nc2) s2 t s2' -> t = E0 ->
  forall i s1, ms i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
     (exists i', exists s1', SPlus (mixed_sem p1 rtl1 nc1) s1 E0 s1' /\ ms i' s1' s2')
  \/ (exists i', clos_trans _ (ord) i' i /\ ms i' s1 s2').
Proof.
  intros p1 p2 rtl1 rtl2 nc1 nc2 idx ord ms SIM.
  induction 1 using plus_ind2; intros; subst t.
(* base case *)
  exploit bsim_simulation''; eauto. intros [[i' [s1' [A B]]] | [i' [A [B C]]]].
  left; exists i'; exists s1'; auto.
  right; exists i'; intuition.
(* inductive case *)
  exploit Eapp_E0_inv; eauto. intros [EQ1 EQ2]; subst.
  exploit bsim_simulation''; eauto. intros [[i' [s1' [A B]]] | [i' [A [B C]]]].
  exploit bsim_E0_star''. apply SIM. apply plus_star with (s1:=s2); eauto. eauto.
  eapply star_safe; eauto. apply plus_star; auto.
  intros [i'' [s1'' [P Q]]].
  left; exists i''; exists s1''; intuition. eapply plus_star_trans; eauto.
  exploit IHplus; eauto. intros [P | [i'' [P Q]]].
  left; auto.
  right; exists i''; intuition. eapply t_trans; eauto. apply t_step; auto.
Qed.

Section COMPOSE_INTERNAL_BACKWARD_SIMULATIONS_EXPLICIT.

Variable p1 p2 p3: program.
Variable rtl1 rtl2 rtl3:option (RTLfun+RTLblockfun).
Variable nc1: asm_codes.
Variable nc2: asm_codes.
Variable nc3: asm_codes.
Hypothesis p3_single_events: single_events (mixed_sem p3 rtl3 nc3).
Variable i12: Type.
Variable i23: Type.
Variable ord12: i12 -> i12 -> Prop.
Variable ord23: i23 -> i23 -> Prop.
Variable ms12: i12 -> mixed_state -> mixed_state -> Prop.
Variable ms23: i23 -> mixed_state -> mixed_state -> Prop.
Variable S12: backward_internal_simulation' p1 p2 rtl1 rtl2 nc1 nc2 ord12 ms12.
Variable S23: backward_internal_simulation' p2 p3 rtl2 rtl3 nc2 nc3 ord23 ms23.

Let bb_index: Type := (i12 * i23)%type.

Let bb_order: bb_index -> bb_index -> Prop :=
  lex_ord (clos_trans _ ord12) (ord23).

Inductive bb_ms: bb_index -> mixed_state -> mixed_state -> Prop :=
  | bb_later: forall i1 i2 s1 s3 s2x s2y,
      ms12 i1 s1 s2x -> Star (mixed_sem p2 rtl2 nc2) s2x E0 s2y -> ms23 i2 s2y s3 ->
      bb_ms (i1, i2) s1 s3.

Lemma bb_match_at':
  forall i1 i2 s1 s2 s3,
  ms12 i1 s1 s2 -> ms23 i2 s2 s3 ->
  bb_ms (i1, i2) s1 s3.
Proof.
  intros. econstructor; eauto. apply star_refl.
Qed.

Lemma bsim_safe':
  forall p1 p2 rtl1 rtl2 nc1 nc2 i (ord:i->i->Prop) ms
    (SIM: backward_internal_simulation' p1 p2 rtl1 rtl2 nc1 nc2 ord ms),
  forall i s1 s2,
  ms i s1 s2 -> safe (mixed_sem p1 rtl1 nc1) s1 -> safe (mixed_sem p2 rtl2 nc2) s2.
Proof.
  intros; red; intros.
  exploit bsim_E0_star''; eauto. intros [i' [s1' [A B]]].
  eapply progress; eauto. eapply star_safe; eauto.
Qed.

Lemma bb_simulation_base':
  forall s3 t s3', Step (mixed_sem p3 rtl3 nc3) s3 t s3' ->
  forall i1 s1 i2 s2, ms12 i1 s1 s2 -> ms23 i2 s2 s3 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
  exists i', exists s1',
    (SPlus (mixed_sem p1 rtl1 nc1) s1 t s1' \/ (Star (mixed_sem p1 rtl1 nc1) s1 t s1' /\ bb_order i' (i1, i2)))
    /\ bb_ms i' s1' s3'.
Proof.
  intros.
  exploit (bsim_simulation'' S23); eauto. eapply bsim_safe'; eauto.
  intros [ [i2' [s2' [PLUS2 MATCH2]]] | [i2' [ORD2 [EQ MATCH2]]]].
  (* 1 L2 makes one or several transitions *)
  assert (EITHER: t = E0 \/ (length t = 1)%nat).
  exploit p3_single_events; eauto.
    destruct t; auto. destruct t; auto. simpl. intros. omegaContradiction.
  destruct EITHER.
  (* 1.1 these are silent transitions *)
  subst t. exploit bsim_E0_plus''. apply S12. eauto. auto. eauto. auto.
  intros [ [i1' [s1' [PLUS1 MATCH1]]] | [i1' [ORD1 MATCH1]]].
  (* 1.1.1 L1 makes one or several transitions *)
  exists (i1', i2'); exists s1'; split. auto. eapply bb_match_at'; eauto.
  (* 1.1.2 L1 makes no transitions *)
  exists (i1', i2'); exists s1; split.
  right; split. apply star_refl. left; auto.
  eapply bb_match_at'; eauto.
  (* 1.2 non-silent transitions *)
  exploit star_non_E0_split. apply plus_star; eauto. auto.
  intros [s2x [s2y [P [Q R]]]].
  exploit bsim_E0_star''. apply S12. eexact P. eauto. auto. intros [i1' [s1x [X Y]]].
  exploit bsim_simulation''. apply S12. eexact Q. eauto. eapply star_safe; eauto.
  intros [[i1'' [s1y [U V]]] | [i1'' [U [V W]]]]; try (subst t; discriminate).
  exists (i1'', i2'); exists s1y; split.
  left. eapply star_plus_trans; eauto. eapply bb_later; eauto.
  (* 2. L2 makes no transitions *)
  subst. exists (i1, i2'); exists s1; split.
  right; split. apply star_refl. right; auto.
  eapply bb_match_at'; eauto.
Qed.

Lemma bb_simulation':
  forall s3 t s3', Step (mixed_sem p3 rtl3 nc3) s3 t s3' ->
  forall i s1, bb_ms i s1 s3 -> safe (mixed_sem p1 rtl1 nc1) s1 ->
  exists i', exists s1',
    (SPlus (mixed_sem p1 rtl1 nc1) s1 t s1' \/ (Star (mixed_sem p1 rtl1 nc1) s1 t s1' /\ bb_order i' i))
    /\ bb_ms i' s1' s3'.
Proof.
  intros. inv H0.
  exploit star_inv; eauto. intros [[EQ1 EQ2] | PLUS].
  (* 1. match at *)
  subst. eapply bb_simulation_base'; eauto.
  (* 2. match later *)
  exploit bsim_E0_plus''. apply S12. eauto. auto. eauto. auto.
  intros [[i1' [s1' [A B]]] | [i1' [A B]]].
  (* 2.1 one or several silent transitions *)
  exploit bb_simulation_base'. apply H.  eexact B. eauto.
    eapply star_safe; eauto. eapply plus_star; eauto.
  intros [i'' [s1'' [C D]]].
  exists i''; exists s1''; split; auto.
  left. eapply plus_star_trans; eauto.
  destruct C as [P | [P Q]]. apply plus_star; eauto. eauto.
  traceEq.
  (* 2.2 no silent transition *)
  exploit bb_simulation_base'. apply H.  eexact B. eauto. auto.
  intros [i'' [s1'' [C D]]].
  exists i''; exists s1''; split; auto.
  intuition. right; intuition.
  inv H6. left. eapply t_trans; eauto. left; auto.
Qed.

Theorem compose_backward_simulation':
  backward_internal_simulation' p1 p3 rtl1 rtl3 nc1 nc3 (bb_order) (bb_ms).
Proof.
  apply Backward_internal_simulation'.
(* well founded *)
  unfold bb_order. apply wf_lex_ord. apply wf_clos_trans. apply (order_wf S12). apply (order_wf S23).
  (* transitivity *)
  (* { unfold bb_order. apply transitive_lex_ord. *)
  (*   - apply clos_trans_trans. *)
  (*   - apply (order_trans S23). }   *)
  (* reflexivity *)
  { unfold call_refl, p_reflexive. intros s REFL.
    specialize (match_states_refl S12). intros H. unfold call_refl, p_reflexive in H.
    specialize (H s REFL). destruct H as [i2 MATCH1].
    specialize (match_states_refl S23). intros H. unfold call_refl, p_reflexive in H.
    specialize (H s REFL). destruct H as [i3 MATCH2].
    exists (i2, i3). eapply bb_match_at'; eauto. }
(* match final states *)
  intros i s1 s3 r MS SAFE FIN. inv MS.
  exploit (match_final_states S23 ); eauto.
    eapply star_safe; eauto. eapply bsim_safe'; eauto.
  intros [s2' [A B]].
  exploit bsim_E0_star''. apply S12. eapply star_trans. eexact H0. eexact A. auto. eauto. auto.
  intros [i1' [s1' [C D]]].
  exploit (match_final_states S12); eauto. eapply star_safe; eauto.
  intros [s1'' [P Q]].
  exists s1''; split; auto. eapply star_trans; eauto.
(* progress *)
  intros i s1 s3 MS SAFE. inv MS.
  eapply (progress S23). eauto. eapply star_safe; eauto. eapply bsim_safe'; eauto.
  (* simulation *)
  exact bb_simulation'.
Qed.

End COMPOSE_INTERNAL_BACKWARD_SIMULATIONS_EXPLICIT.


From mathcomp Require Import
  ssreflect ssrfun ssrbool ssrnat seq eqtype fintype.
From extructures Require Import ord fset fmap fperm.
From CoqUtils Require Import word nominal.

Require Import lib.utils lib.fmap_utils common.types symbolic.symbolic symbolic.exec.
Require Import memory_safety.property memory_safety.symbolic memory_safety.abstract.
Require Import memory_safety.refinementAS.
Require Import memory_safety.classes memory_safety.executable memory_safety.propertyA.

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

Section MemorySafety.

Local Open Scope fset_scope.

Import Abstract.

Variable mt : machine_types.
Variable ops : machine_ops mt.
Variable sr : syscall_regs mt.
Variable addrs : memory_syscall_addrs mt.

Local Notation sstate := (@Symbolic.state mt (Sym.sym_memory_safety mt)).
Local Notation sstepf :=
  (@stepf _ ops (Sym.sym_memory_safety mt) (@Sym.memsafe_syscalls _ ops _ addrs)).
Local Notation astate := (Abstract.state mt).
Local Notation astepf := (AbstractE.step ops _ addrs).

Lemma noninterference sst1 sst1' sst2 sst2' mi1 mi2 ast m1 m2 pm n :
  stepn sstepf n sst1 = Some sst1' ->
  stepn sstepf n sst2 = Some sst2' ->
  refine_state mi1 (add_mem m1 ast) sst1 ->
  refine_state mi2 (add_mem m2 (rename pm ast)) sst2 ->
  fdisjoint (names ast) (domm m1) ->
  fdisjoint (names (rename pm ast)) (domm m2) ->
  exists ast' pm' mi1' mi2',
    [/\ refine_state mi1' (add_mem m1 ast') sst1',
        refine_state mi2' (add_mem m2 (rename pm' ast')) sst2',
        fdisjoint (names ast') (domm m1) &
        fdisjoint (names (rename pm' ast')) (domm m2) ].
Proof.
move=> ex1 ex2 ref1 ref2 dis1 dis2.
have [mi1' [ast1' [ex1' ref1']]] := refinement ref1 ex1.
have [mi2' [ast2' [ex2' ref2']]] := refinement ref2 ex2.
have := noninterference ops sr addrs n dis1 dis2.
rewrite ex1' ex2'.
case=> pm' [ast' [e1 dis1' e2 dis2']].
exists ast', pm', mi1', mi2'; split=> //.
  by rewrite -e1.
by rewrite -e2.
Qed.

End MemorySafety.


Require Import Coq.Strings.String Coq.Strings.HexString.
Require Import Coq.Init.Byte coqutil.Byte.
Require Import Coq.Lists.List.
Require Import coqutil.Map.Interface.
Require Import coqutil.Map.Z_keyed_SortedListMap.
Local Open Scope string_scope.
Local Open Scope list_scope.
Import ListNotations.

(* USAGE:
Definition mysymbols := Symbols.symbols myfinfo.
./etc/bytedump.py MyRepo.MyFile.mysymbols > /tmp/l.s
riscv64-elf-gcc -T mylinkerscript.lds -g -nostdlib /tmp/l.s -o /tmp/l
*)

Definition LF : string := String (Coq.Strings.Ascii.Ascii false true false true false false false false) "".

Definition symbols_string (finfo : list (string * BinInt.Z)) : string :=
  ".globl _start" ++ LF ++
  "_start:" ++ LF ++
  String.concat "" (List.map (fun '(a, s) =>
    ".org " ++ HexString.of_Z a ++ LF ++
    ".local " ++ s ++ LF ++
    s ++ ":" ++ LF)%string
    (SortedList.value (List.fold_right (fun '(k, v) m => map.put m v k) map.empty finfo))).

Definition symbols (finfo : list (string * BinInt.Z)) : list byte :=
  String.list_byte_of_string (symbols_string finfo).


Require Import UNIVERSE.
(* Require Import Events. *)
(* Require Import Values. *)
(* Require Import AST. *)
(* Require Import Memory. *)
(* Require Import Globalenvs. *)
(* Require Import Smallstep. *)
Require Import CoqlibC.
(* Require Import Skeleton. *)
(* Require Import Integers. *)
(* Require Import ASTC. *)
(* Require Import Maps. *)

Require Import ModSem.

Set Implicit Arguments.

Module Mod.
  (* TRANSLATION UNIT *)

  (* I intentionally left "datatype" in to_skel and to_moduleenv. *)
  (* 1) defining translation becomes more lightweight. *)
  (* Consider RTL -> RTL. to_skel/to_moduleenv remains the same *)
  (* 2) This definition will give an error when datatype is changed. *)
  Record t: Type := mk {
    datatype: Type;
    get_sk: datatype -> Sk.t;
    get_modsem: SkEnv.t -> datatype -> ModSem.t;
    data: datatype;
    get_modsem_skenv_spec: forall skenv,
        <<PROJECTED: SkEnv.project skenv data.(get_sk) = data.(get_modsem skenv).(ModSem.skenv)>>;
    get_modsem_skenv_link_spec: forall skenv_link,
        <<EQ: data.(get_modsem skenv_link).(ModSem.skenv_link) = skenv_link>>
  }.

  Lemma get_modsem_projected_sk
        (md: t) skenv
        (INCL: SkEnv.includes skenv (get_sk md (data md))):
      <<PROJECTED: SkEnv.project_spec skenv ((md.(get_sk) md.(data)))
                                      ((md.(get_modsem) skenv) md.(data)).(ModSem.skenv)>>.
  Proof.
    erewrite <- get_modsem_skenv_spec. eapply SkEnv.project_impl_spec; et.
  Qed.

  Definition sk (md: t): Sk.t := md.(get_sk) md.(data).

  Definition modsem (md: t) (skenv: SkEnv.t): ModSem.t := md.(get_modsem) skenv md.(data).

  (* Module Atomic. *)
  (* Section Atomic. *)

  (*   Variable m: t. *)

  (*   Program Definition trans: t := *)
  (*     mk m.(get_sk) (fun ske dat => ModSem.Atomic.trans (m.(get_modsem) ske dat)) m.(data) _ _. *)
  (*   Next Obligation. exploit get_modsem_skenv_spec; eauto. Qed. *)
  (*   Next Obligation. exploit get_modsem_skenv_link_spec; eauto. Qed. *)

  (* End Atomic. *)
  (* End Atomic. *)

End Mod.

Coercion Mod.sk: Mod.t >-> Sk.t.
Coercion Mod.modsem: Mod.t >-> Funclass.

Hint Unfold Mod.sk Mod.modsem.


Require Import LayerDeps.
Require Import Ident.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import BaremoreHandler.Spec.
Require Import RmiSMC.Spec.
Require Import CtxtSwitch.Spec.
Require Import RunAux.Spec.
Require Import RunComplete.Spec.

Local Open Scope Z_scope.

Section Layer.

  Context `{real_params: RealParams}.

  Section InvDef.

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

    Global Instance RunComplete_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 RunComplete_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 complete_mmio_emulation_inv: PreservesInvariants complete_mmio_emulation_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance complete_hvc_exit_inv: PreservesInvariants complete_hvc_exit_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance addr_to_idx_inv: PreservesInvariants addr_to_idx_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 set_wi_index_inv: PreservesInvariants set_wi_index_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_refcount_inc_inv: PreservesInvariants granule_refcount_inc_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 ns_buffer_read_rec_run_inv: PreservesInvariants ns_buffer_read_rec_run_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_put_inv: PreservesInvariants granule_put_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 measurement_extend_data_inv: PreservesInvariants measurement_extend_data_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 entry_is_table_inv: PreservesInvariants entry_is_table_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance barrier_inv: PreservesInvariants barrier_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance atomic_granule_put_release_inv: PreservesInvariants atomic_granule_put_release_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 configure_realm_stage2_inv: PreservesInvariants configure_realm_stage2_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rd_g_rtt_inv: PreservesInvariants get_rd_g_rtt_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_memzero_inv: PreservesInvariants granule_memzero_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 granule_refcount_dec_inv: PreservesInvariants granule_refcount_dec_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance measurement_extend_data_header_inv: PreservesInvariants measurement_extend_data_header_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_lock_inv: PreservesInvariants granule_lock_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance ns_buffer_unmap_inv: PreservesInvariants ns_buffer_unmap_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_memzero_mapped_inv: PreservesInvariants granule_memzero_mapped_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance atomic_granule_put_inv: PreservesInvariants atomic_granule_put_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 run_realm_inv: PreservesInvariants run_realm_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_g_rtt_refcount_inv: PreservesInvariants get_g_rtt_refcount_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance restore_hcr_el2_inv: PreservesInvariants restore_hcr_el2_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance reset_disposed_info_inv: PreservesInvariants reset_disposed_info_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 set_mapping_inv: PreservesInvariants set_mapping_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_runnable_inv: PreservesInvariants get_rec_runnable_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance ns_granule_map_inv: PreservesInvariants ns_granule_map_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_get_inv: PreservesInvariants granule_get_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 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 save_ns_state_inv: PreservesInvariants save_ns_state_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 null_ptr_inv: PreservesInvariants null_ptr_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_wi_g_llt_inv: PreservesInvariants get_wi_g_llt_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance reset_last_run_info_inv: PreservesInvariants reset_last_run_info_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 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 set_g_rtt_rd_inv: PreservesInvariants set_g_rtt_rd_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance pgte_read_inv: PreservesInvariants pgte_read_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance ns_buffer_read_data_inv: PreservesInvariants ns_buffer_read_data_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance pgte_write_inv: PreservesInvariants pgte_write_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_wi_g_llt_inv: PreservesInvariants set_wi_g_llt_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 restore_realm_state_inv: PreservesInvariants restore_realm_state_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 find_lock_unused_granule_inv: PreservesInvariants find_lock_unused_granule_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance entry_to_phys_inv: PreservesInvariants entry_to_phys_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance stage2_tlbi_ipa_inv: PreservesInvariants stage2_tlbi_ipa_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance atomic_granule_get_inv: PreservesInvariants atomic_granule_get_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 get_wi_index_inv: PreservesInvariants get_wi_index_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance link_table_inv: PreservesInvariants link_table_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.

    Global Instance addr_is_level_aligned_inv: PreservesInvariants addr_is_level_aligned_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

  End InvProof.

  Section LayerDef.

    Definition RunComplete_fresh : compatlayer (cdata RData) :=
      _complete_mmio_emulation ↦ gensem complete_mmio_emulation_spec
        ⊕ _complete_hvc_exit ↦ gensem complete_hvc_exit_spec
      .

    Definition RunComplete_passthrough : compatlayer (cdata RData) :=
      _addr_to_idx ↦ gensem addr_to_idx_spec
        ⊕ _el3_sync_lel ↦ gensem el3_sync_lel_spec
        ⊕ _set_wi_index ↦ gensem set_wi_index_spec
        ⊕ _granule_refcount_inc ↦ gensem granule_refcount_inc_spec
        ⊕ _granule_unlock ↦ gensem granule_unlock_spec
        ⊕ _ns_buffer_read_rec_run ↦ gensem ns_buffer_read_rec_run_spec
        ⊕ _granule_put ↦ gensem granule_put_spec
        ⊕ _exit_rmm ↦ gensem exit_rmm_spec
        ⊕ _measurement_extend_data ↦ gensem measurement_extend_data_spec
        ⊕ _smc_granule_undelegate ↦ gensem smc_granule_undelegate_spec
        ⊕ _entry_is_table ↦ gensem entry_is_table_spec
        ⊕ _barrier ↦ gensem barrier_spec
        ⊕ _atomic_granule_put_release ↦ gensem atomic_granule_put_release_spec
        ⊕ _smc_rec_destroy ↦ gensem smc_rec_destroy_spec
        ⊕ _configure_realm_stage2 ↦ gensem configure_realm_stage2_spec
        ⊕ _get_rd_g_rtt ↦ gensem get_rd_g_rtt_spec
        ⊕ _granule_memzero ↦ gensem granule_memzero_spec
        ⊕ _read_reg ↦ gensem read_reg_spec
        ⊕ _granule_refcount_dec ↦ gensem granule_refcount_dec_spec
        ⊕ _measurement_extend_data_header ↦ gensem measurement_extend_data_header_spec
        ⊕ _granule_lock ↦ gensem granule_lock_spec
        ⊕ _ns_buffer_unmap ↦ gensem ns_buffer_unmap_spec
        ⊕ _granule_memzero_mapped ↦ gensem granule_memzero_mapped_spec
        ⊕ _atomic_granule_put ↦ gensem atomic_granule_put_spec
        ⊕ _get_rd_state ↦ gensem get_rd_state_spec
        ⊕ _run_realm ↦ gensem run_realm_spec
        ⊕ _get_g_rtt_refcount ↦ gensem get_g_rtt_refcount_spec
        ⊕ _restore_hcr_el2 ↦ gensem restore_hcr_el2_spec
        ⊕ _reset_disposed_info ↦ gensem reset_disposed_info_spec
        ⊕ _smc_realm_activate ↦ gensem smc_realm_activate_spec
        ⊕ _set_mapping ↦ gensem set_mapping_spec
        ⊕ _get_rec_runnable ↦ gensem get_rec_runnable_spec
        ⊕ _ns_granule_map ↦ gensem ns_granule_map_spec
        ⊕ _granule_get ↦ gensem granule_get_spec
        ⊕ _buffer_unmap ↦ gensem buffer_unmap_spec
        ⊕ _enter_rmm ↦ gensem enter_rmm_spec
        ⊕ _smc_granule_delegate ↦ gensem smc_granule_delegate_spec
        ⊕ _save_ns_state ↦ gensem save_ns_state_spec
        ⊕ _granule_set_state ↦ gensem granule_set_state_spec
        ⊕ _null_ptr ↦ gensem null_ptr_spec
        ⊕ _get_wi_g_llt ↦ gensem get_wi_g_llt_spec
        ⊕ _reset_last_run_info ↦ gensem reset_last_run_info_spec
        ⊕ _smc_rec_create ↦ gensem smc_rec_create_spec
        ⊕ _granule_map ↦ gensem granule_map_spec
        ⊕ _find_lock_granule ↦ gensem find_lock_granule_spec
        ⊕ _is_null ↦ gensem is_null_spec
        ⊕ _assert_cond ↦ gensem assert_cond_spec
        ⊕ _set_g_rtt_rd ↦ gensem set_g_rtt_rd_spec
        ⊕ _pgte_read ↦ gensem pgte_read_spec
        ⊕ _ns_buffer_read_data ↦ gensem ns_buffer_read_data_spec
        ⊕ _pgte_write ↦ gensem pgte_write_spec
        ⊕ _set_wi_g_llt ↦ gensem set_wi_g_llt_spec
        ⊕ _find_granule ↦ gensem find_granule_spec
        ⊕ _restore_realm_state ↦ gensem restore_realm_state_spec
        ⊕ _smc_realm_create ↦ gensem smc_realm_create_spec
        ⊕ _find_lock_unused_granule ↦ gensem find_lock_unused_granule_spec
        ⊕ _entry_to_phys ↦ gensem entry_to_phys_spec
        ⊕ _stage2_tlbi_ipa ↦ gensem stage2_tlbi_ipa_spec
        ⊕ _atomic_granule_get ↦ gensem atomic_granule_get_spec
        ⊕ _user_step ↦ gensem user_step_spec
        ⊕ _get_wi_index ↦ gensem get_wi_index_spec
        ⊕ _link_table ↦ gensem link_table_spec
        ⊕ _smc_realm_destroy ↦ gensem smc_realm_destroy_spec
        ⊕ _addr_is_level_aligned ↦ gensem addr_is_level_aligned_spec
      .

    Definition RunComplete := RunComplete_fresh ⊕ RunComplete_passthrough.

  End LayerDef.

End Layer.


From machine_program_logic.program_logic Require Import weakestpre.
From HypVeri Require Import lifting rules.rules_base machine_extra.
From HypVeri.algebra Require Import base reg mem pagetable mailbox base_extra.
From HypVeri.lang Require Import lang_extra reg_extra.

Section br.

Context `{hypparams: HypervisorParameters}.
Context `{vmG: !gen_VMG Σ}.

Lemma br {E i w1 w2 q s p} ai  ra :
  decode_instruction w1 = Some(Br ra) ->
  tpa ai ∈ s ->
  tpa ai ≠ p ->
    {SS{{  ▷ (PC @@ i ->r ai)
           ∗ ▷ (ai ->a w1)
           ∗ ▷ (ra @@ i ->r w2)
           ∗ ▷ (i -@{q}A> s)
           ∗ ▷ (TX@ i := p) }}} ExecI @ i; E
    {{{ RET (false, ExecI);  (PC @@ i ->r  w2)
                    ∗ (ai ->a w1 ∗ ra @@ i ->r w2)
                    ∗ (i -@{q}A> s)
                    ∗ (TX@ i := p)}}}.
Proof.
  iIntros (Hdecode Hin Hne ϕ) "( >Hpc & >Hapc & >Hra & >Hacc & >HTX) Hϕ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche Hσ".
  rewrite /scheduled in Hsche.
  simpl in Hsche.
  rewrite /scheduler in Hsche.
  apply bool_decide_unpack in Hsche as Hcur.
  clear Hsche.
  apply fin_to_nat_inj in Hcur.
  iModIntro.
  iDestruct "Hσ" as "(#Hneq & Hmem & Hreg & Hmb & Hrx & Hown & Haccess & Hrest)".
  pose proof (decode_instruction_valid w1 (Br ra) Hdecode) as Hvalidinstr.
  inversion Hvalidinstr as [ | | | | | | | | | |src Hvalidra |] .
  subst src .
  inversion Hvalidra as [ HneqPCa HneqNZa ].
  (* valid regs *)
  iDestruct ((gen_reg_valid2 i PC ai ra w2 Hcur) with "Hreg Hpc Hra") as "[%HPC %Hra]";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "Haccess Hacc") as %Hacc;first set_solver + Hin.
  (* valid mem *)
  iDestruct (gen_mem_valid ai w1  with "Hmem Hapc") as %Hmem.
  iDestruct (mb_valid_tx i p with "Hmb HTX") as %Htx.
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i (Br ra) ai w1);eauto.
    by rewrite Htx.
  - (* step *)
    iModIntro.
    iIntros (m2 σ2) "[%P PAuth] %HstepP".
    apply (step_ExecI_normal i (Br ra) ai w1 ) in HstepP;eauto.
    remember (exec (Br ra) σ1) as c2 eqn:Heqc2.
    rewrite /exec  /br Hra /= /update_incr_PC /update_reg in Heqc2;eauto.
    destruct ra. contradiction. contradiction.
    destruct HstepP;subst m2 σ2; subst c2; simpl.
    rewrite /gen_vm_interp.
    (* unchanged part *)
    rewrite (preserve_get_mb_gmap σ1).
    rewrite (preserve_get_rx_gmap σ1).
    rewrite (preserve_get_own_gmap σ1).
    rewrite (preserve_get_access_gmap σ1).
    rewrite (preserve_get_excl_gmap σ1).
    rewrite (preserve_get_trans_gmap σ1).
    rewrite (preserve_get_hpool_gset σ1).
    rewrite (preserve_get_retri_gmap σ1).
    rewrite (preserve_inv_trans_pgt_consistent σ1).
    rewrite (preserve_inv_trans_wellformed σ1).
    rewrite (preserve_inv_trans_ps_disj σ1).
    all: eauto.
    iFrame.
    (* updated part *)
    iDestruct ((gen_reg_update1_global PC i ai w2) with "Hreg Hpc") as ">[Hreg Hpc]";eauto.
    iModIntro.
    rewrite /update_reg /=.
    rewrite ->u_upd_reg_regs.
    rewrite Hcur.
    iFrame "Hreg".
    iSplitL "PAuth".
    by iExists P.
    rewrite /just_scheduled_vms.
    rewrite /just_scheduled.
    assert (filter
              (λ id : vmid,
                      base.negb (scheduled σ1 id) && scheduled (update_reg_global σ1 i PC w2) id = true)
              (seq 0 n) = []) as ->.
    {
      rewrite /scheduled /machine.scheduler //= /scheduler Hcur.
      rewrite p_upd_reg_current_vm.
      rewrite Hcur.
      induction n.
      - simpl.
        rewrite filter_nil //=.
      - rewrite seq_S.
        rewrite filter_app.
        rewrite IHn.
        simpl.
        rewrite filter_cons_False //=.
        rewrite andb_negb_l.
        done.
    }
    iSimpl.
    iFrame "Hneq".
    iSplitL "";first done.
    assert ((scheduled (update_reg_global σ1 i PC w2) i) = true) as ->.
    rewrite /scheduled.
    simpl.
    rewrite /scheduler.
    rewrite p_upd_reg_current_vm.
    rewrite Hcur.
    rewrite bool_decide_eq_true.
    reflexivity.
    simpl.
    iApply ("Hϕ" with "[Hpc Hapc Hacc Hra HTX]").
    iFrame.
    by rewrite Htx.
Qed.
End br.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef1.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition table_destroy2_spec (g_rd: Pointer) (map_addr: Z64) (rtt_addr: Z64) (level: Z64) (adt: RData) : option (RData * Z64) :=
    match map_addr, level, rtt_addr with
    | VZ64 map_addr, VZ64 level, VZ64 rtt_addr =>
      rely is_int64 map_addr; rely is_int64 rtt_addr; rely GRANULE_ALIGNED map_addr; rely is_int64 level;
      let idx0 := __addr_to_idx map_addr 0 in
      let idx1 := __addr_to_idx map_addr 1 in
      let idx2 := __addr_to_idx map_addr 2 in
      let idx3 := __addr_to_idx map_addr 3 in
      let ret_idx := (if level =? 1 then idx0 else if level =? 2 then idx1 else if level =? 3 then idx2 else idx3) in
      rely is_int64 idx0; rely is_int64 idx1; rely is_int64 idx2; rely is_int64 idx3;
      let rtt_gidx := __addr_to_gidx rtt_addr in
      rely is_gidx rtt_gidx;
      rely (peq (base g_rd) ginfo_loc);
      rely prop_dec ((buffer (priv adt)) @ SLOT_RD = None);
      rely prop_dec ((buffer (priv adt)) @ SLOT_TABLE = None);
      rely prop_dec ((buffer (priv adt)) @ SLOT_RTT2 = None);
      let rd_gidx := (offset g_rd) in
      let grd := (gs (share adt)) @ rd_gidx in
      rely (g_tag (ginfo grd) =? GRANULE_STATE_RD);
      rely prop_dec (glock grd = Some CPU_ID);
      let root_gidx := (g_rtt (gnorm grd)) in
      rely is_gidx rd_gidx;
      when adt == query_oracle adt;
      (* hold root lock *)
      rely is_gidx root_gidx;
      let groot := (gs (share adt)) @ root_gidx in
      rely (tbl_level (gaux groot) =? 0);
      rely prop_dec (glock groot = None);
      rely (g_tag (ginfo groot) =? GRANULE_STATE_TABLE);
      rely (gtype groot =? GRANULE_STATE_TABLE);
      if level =? 1 then
        (* walk until root *)
        let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 0) :: log adt} in
        let adt :=  adt {priv: (priv adt) {wi_llt: root_gidx} {wi_index: idx0}} in
        destroy_table root_gidx idx0 rtt_addr rtt_gidx 1 map_addr adt
      else
        (* walk deeper root *)
        rely (level >? 1);
        let entry0 := (g_data (gnorm groot)) @ idx0 in
          rely is_int64 entry0;
          let phys0 := __entry_to_phys entry0 3 in
          let lv1_gidx := __addr_to_gidx phys0 in
          rely is_int64 phys0;
          if (__entry_is_table entry0) && (GRANULE_ALIGNED phys0) && (is_gidx lv1_gidx) then
            (* level 1 valid, hold level 1 lock *)
            let glv1 := (gs (share adt)) @ lv1_gidx in
            rely prop_dec (glock glv1 = None);
            rely (tbl_level (gaux glv1) =? 1);
            if level =? 2 then
              (* walk until level 1 *)
              let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 1) :: log adt} in
              let adt :=  adt {priv: (priv adt) {wi_llt: lv1_gidx} {wi_index: idx1}} in
              destroy_table lv1_gidx idx1 rtt_addr rtt_gidx 2 map_addr adt
            else
              (* walk deeper level 1 *)
              rely (level >? 2);
              rely (g_tag (ginfo glv1) =? GRANULE_STATE_TABLE);
              rely (gtype glv1 =? GRANULE_STATE_TABLE);
              let entry1 := (g_data (gnorm glv1)) @ idx1 in
              rely is_int64 entry1;
              let phys1 := __entry_to_phys entry1 3 in
              let lv2_gidx := __addr_to_gidx phys1 in
              rely is_int64 phys1;
              if (__entry_is_table entry1) && (GRANULE_ALIGNED phys1) && (is_gidx lv2_gidx) then
                (* level 2 valid, hold level 2 lock *)
                let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 2) :: log adt} in
                let glv2 := (gs (share adt)) @ lv2_gidx in
                rely (tbl_level (gaux glv2) =? 2);
                rely prop_dec (glock glv2 = None);
                if level =? 3 then
                  (* walk until level 2 *)
                  let adt :=  adt {priv: (priv adt) {wi_llt: lv2_gidx} {wi_index: idx2}} in
                  destroy_table lv2_gidx idx2 rtt_addr rtt_gidx 3 map_addr adt
                else None
              else
                (* level 2 invalid *)
                rely is_int lv2_gidx;
                Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
          else
            (* level 1 invalid *)
            rely is_int lv1_gidx;
            Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
    end.

End Spec.


Monomorphic Definition U1 := Type.
Monomorphic Definition U2 := Type.

Set Printing Universes.
Definition foo : True.
let t1 := type of U1 in
let t2 := type of U2 in
idtac t1 t2;
pose (t1 : t2). exact I.
Defined.


Require Import String.
Require Import NPeano.
Require Import PeanoNat.
Require Import Coq.Strings.Ascii.
Require FMapWeakList.
Require Export Coq.Structures.OrderedTypeEx.
Require Import Coq.Program.Equality.

Require Import Lists.List.
Import ListNotations.
Require Import JaSyntax.
Require Import JaProgram.
Require Import JaSubtype.
Require Import JaProgramWf.
Require Import Jafun.
Require Import JaTactics.
Require Import JaUnique.
Open Scope list_scope.
Open Scope nat_scope.

From Hammer Require Import Reconstr.

Module VarName <: Name.
  Definition name := JFVal.
  Definition name_dec := JFVal_dec.
End VarName.

Module VarInEnv <: Declaration.
  Include VarName.
  Definition decl := (JFVal * JFACId)%type.
  Definition name_of_decl : decl -> name := fst.
End VarInEnv.

Module Env := VarInEnv <+ ListUniq.

Definition JFEnv := Env.t.

Definition JFExEnv := list JFACId.

Section EnvsInProgram.

  Variable P : JFProgram.
  Variable cdecl: JFClassDeclaration.
  Variable md : JFMethodDeclaration.

(**
   The operation of ⊎ as defined in Section {sec:type-system}.
   TODO: definicja zgodna z papierem, ale w papierze wyrażenie poprawne,
         ale źle przedstawiające intencje.
*)
Fixpoint sumPlus (exs:JFExEnv) (ext:JFACId) :=
  match ext with
  | (C, cmod) =>
    match exs with
    | [] => [ext]
    | (D, dmod) :: tl =>
      if subtype_bool P D C
      then sumPlus tl ext
      else (D, dmod) :: (sumPlus tl ext)
    end
  end.

Fixpoint sumPlus' (exs:JFExEnv) (ext:JFACId) :=
  match exs with
  | [] => [ext]
  | ext' :: tl =>
    if JFACId_dec ext ext'
    then ext :: tl
    else ext' :: (sumPlus tl ext)
  end.

Fixpoint sumPlusCtx (exs:JFExEnv) (Ctx:JFContext) :=
  match Ctx with
  | [] => exs
  | cnode :: Ctx' => match cnode with
                     | JFCtxLet cn x _ E2 => sumPlusCtx exs Ctx'
                     | JFCtxTry _ mu cn x E2 => sumPlus (sumPlusCtx exs Ctx') (JFClass cn, mu)
                     end
  end.

Lemma sumPlusCtxLet:
  forall Ctx Xi cn x E,
    sumPlusCtx Xi (Ctx ++ [JFCtxLet cn x __ E]) = sumPlusCtx Xi Ctx.
Proof.
  induction Ctx.
  * intros.
    simpl.
    auto.
  * intros.
    destruct a.
    ** simpl.
       eauto.
    ** simpl.
       rewrite IHCtx.
       eauto.
Qed.

Lemma sumPlusCtxTry:
  forall Ctx Xi mu cn x E,
    sumPlusCtx Xi (Ctx ++ [JFCtxTry __ mu cn x E]) = sumPlusCtx (sumPlus Xi (JFClass cn, mu)) Ctx.
Proof.
  induction Ctx.
  * intros.
    simpl.
    auto.
  * intros.
    simpl.
    destruct a;eauto 2.
    rewrite (IHCtx Xi);eauto 2.
Qed.

(**
   The operation of ⊕ as defined in Appendix {sec:metatheory}.
*)
Fixpoint oPlus (env:JFEnv) (l:Loc) (acid:JFACId) {struct env} :=
  match l with
  | null => env
  | JFLoc _ =>
    match env with
    | [] => [((JFVLoc l), acid)]
    | (v, acid') :: tl => if JFVal_dec v (JFVLoc l)
                        then
                          (v, infACId P acid acid') :: tl
                        else
                          (v, acid') :: (oPlus tl l acid)
    end
  end.

Lemma oplus_decompose_eq:
  forall l acid1 acid2 Gamma,
    l <> null ->
    oPlus ((JFVLoc l, acid1) :: Gamma) l acid2 = (JFVLoc l, infACId P acid2 acid1) :: Gamma.
Proof.
  intros.
  destruct l; try contradiction.
  unfold oPlus.
  destruct (JFVal_dec (JFVLoc (JFLoc n)) (JFVLoc (JFLoc n)));try contradiction.
  trivial.
Qed.

Lemma oPlus_neq:
  forall l l' a a' Gamma,
    JFVLoc l <> l' ->
    oPlus ((l', a') :: Gamma) l a =
    (l', a') :: (oPlus Gamma l a).
Proof.
  destruct Gamma.
  + intros.
    destruct l.
    ++ simpl. trivial.
    ++ destruct l'.
       +++ unfold oPlus.
           destruct (JFVal_dec (JFVLoc l) (JFVLoc (JFLoc n))); try congruence.
       +++ unfold oPlus.
           destruct (JFVal_dec (JFSyn x) (JFVLoc (JFLoc n))); try congruence.
  + intros.
    destruct l.
    ++ simpl. trivial.
    ++ destruct l'.
       +++ unfold oPlus.
           destruct (JFVal_dec (JFVLoc l) (JFVLoc (JFLoc n))); try congruence.
       +++ unfold oPlus.
           destruct  (JFVal_dec (JFSyn x) (JFVLoc (JFLoc n))); try congruence.
Qed.

Lemma In_oPlus_Gamma:
  forall Gamma v C mu D nu,
    Env.names_unique Gamma ->
    In (JFVLoc v, (C, mu)) (oPlus Gamma v (D, nu)) ->
    exists mu', In (JFVLoc v, (C,mu')) Gamma \/
                C = D \/ C = JFBotClass.
Proof.
  induction Gamma.
  + intros.
    simpl in H0.
    destruct v.
    ++ inversion H0.
    ++ simpl in H0.
       destruct H0;try contradiction.
       injection H0;intros;subst.
       eauto.
  + intros.
    simpl in H0.
    destruct v.
    ++ eauto.
    ++ destruct a.
       destruct (JFVal_dec j (JFVLoc (JFLoc n))).
       +++ subst.
           destruct j0.
           eapply Env.names_unique_zero in H;simpl;trivial.
           pose (infClass_trichotomy P D j) as Tricho.
           destruct Tricho as [Tricho|Tricho] ;try destruct Tricho as [Tricho|Tricho].
           ++++ simpl in H0.
                destruct H0;eauto.
                injection H0;intros.
                eexists. right;left.
                congruence.
           ++++ simpl in H0.
                destruct H0;eauto.
                injection H0;intros.
                exists j0;left;left.
                rewrite <- H2.
                rewrite <- Tricho at 1.
                auto.
           ++++ simpl in H0.
                destruct H0;eauto.
                injection H0;intros.
                eexists;right;right.
                rewrite <- H2.
                rewrite Tricho.
                auto.
       +++ simpl in H0.
           destruct H0;try congruence.
           eapply IHGamma in H0;eauto.
           destruct H0.
           exists x.
           simpl.
           destruct H0;eauto.
           Unshelve. auto. auto. auto.
Qed.

Lemma in_oplus_eq:
  forall l acid1 Gamma acid2 Cid Cn cdecl mid,
    names_unique P ->
    subtype_well_founded P ->
    Cid = JFClass Cn ->
    find_class P Cn = Some cdecl ->
    Env.names_unique Gamma ->
    l <> null ->
    In (JFVLoc l, acid1) (oPlus Gamma l acid2) ->
    leqIsLS P Cid mid acid1 acid2.
Proof.
  induction Gamma.
  + intros * ? ? ? ? ? ? HIn.
    simpl in HIn.
    destruct l.
    ++ eapply in_nil in HIn; contradiction.
    ++ apply in_inv in HIn.
       destruct HIn as [ [= ->] | HIn].
       +++ eauto.
       +++ sauto.
  + intros * ? ? ? ? Heu ? HIn.
    destruct a as (x, Acid).
    destruct (JFVal_dec x (JFVLoc l)).
    ++ subst.
       rewrite oplus_decompose_eq in HIn;eauto 2.
       simpl in HIn.
       destruct HIn as [ [=] | HIn]; eauto 2.
       +++ eapply infACId_leqIsLS_L; eauto.
       +++ eapply Env.names_unique_zero in Heu; eauto 1.
           simpl in Heu.
           eapply Env.name_noocc_In_decl_neq in Heu; eauto 1.
           simpl in Heu.
           contradiction.
    ++ rewrite oPlus_neq in HIn;eauto 1.
       simpl in HIn.
       destruct HIn as [ [=] | HIn]; try congruence.
       eapply IHGamma in HIn; eauto 1.
Qed.

Lemma in_oplus_neq:
  forall Gamma l l' acid1 acid2,
    l <> l' ->
    In (JFVLoc l, acid1) (oPlus Gamma l' acid2) ->
    In (JFVLoc l, acid1) Gamma.
Proof.
  induction Gamma.
  + intros.
    simpl in H0.
    destruct l'.
    ++ inversion H0.
    ++ simpl in H0.
       simpl.
       destruct H0.
       +++ congruence.
       +++ auto.
  + intros.
    simpl in H0.
    destruct l'.
    ++ simpl.
       simpl in H0.
       auto.
    ++ destruct a.
       destruct (JFVal_dec j (JFVLoc (JFLoc n))).
       +++ subst j.
           simpl.
           simpl in H0.
           destruct H0; try congruence.
           right;auto.
       +++ destruct H0.
           ++++ rewrite <- H0.
                simpl;left;auto.
           ++++ eapply IHGamma in H0;auto.
                simpl;right;auto.
Qed.

Hint Resolve in_oplus_eq in_oplus_neq oPlus_neq oplus_decompose_eq.

Fixpoint loc2env_aux (cn:JFClassName) (mdecl:JFMethodDeclaration)
         (vs:list JFVal) (num:nat) (res:JFEnv) {struct vs} :=
  match vs with
  | [] => res
  | (JFVLoc lhd) :: tl =>
    let acidpt := parTypM P (JFClass cn) (name_of_md mdecl) num in
    (* parTypM returns rwr annotation for non-LS methods *)
    match acidpt with
    | None => res
    | Some acid => loc2env_aux cn mdecl tl (num+1) (oPlus res lhd acid)
    end
  | (JFSyn x) :: tl => res
end.

Definition loc2env (cn:JFClassName) (mdecl:JFMethodDeclaration)
           (vs:list JFVal)  :=
  loc2env_aux cn mdecl vs 0 [].

(*
  (x,Acid) ∈ (oPlus Gamma x Acid')  ∧  Acid ≤: Acid'
*)
Lemma In_oPlus : forall Gamma n D muD,
    names_unique P ->
    subtype_well_founded P ->
    exists D' muD', In (JFVLoc (JFLoc n), (D', muD')) (oPlus Gamma (JFLoc n) (D, muD)) /\
             leqACId P (D',muD') (D,muD).
Proof.
  intros.
  induction Gamma.
  + do 2 eexists.
    simpl.
    repeat split; auto with myhints.
  + simpl.
    destruct a as (x,(Dx,mux)).
    destruct (JFVal_dec x (JFVLoc (JFLoc n))).
    ++
      subst.
      do 2 eexists.
      split.
      +++ simpl; eauto 2.
      +++ split.
          ++++ eapply infClass_subL; eauto 1.
          ++++ eapply infAnn_leq_l; eauto 1.
    ++
      simpl.
      decompose_ex IHGamma.
      decompose_and IHGamma.
      do 2 eexists; eauto 3.
Qed.

Hint Resolve In_oPlus.

(**
  The operation par2env as defined in Section {sec:type-system}.
  Here, the definition does not use ParTypM, but is equivalent.
*)
Definition par2env :=
match md with
| JFMDecl _ mu _ vs _ _ =>
      (JFSyn JFThis, (JFClass (name_of_cd cdecl), mu))
       :: map
            (fun H0 : JFXId * JFACId =>
             let (x, acid) := H0 in (JFSyn (JFVar x), acid)) vs
| JFMDecl0 _ _ vs _ _ =>
      (JFSyn JFThis, (JFClass (name_of_cd cdecl), JFrwr))
       :: map
            (fun H0 : JFXId * JFCId =>
             let (x, cid) := H0 in (JFSyn (JFVar x), (cid, JFrwr))) vs
end.

Lemma par2env_equiv_parTypM : forall i,
    nth i par2env (JFnull, (JFObject, JFrwr)) =
    (nth i (JFSyn JFThis :: map (fun x => JFSyn (JFVar x)) (params_of_md md)) JFnull,
     parTypM_of_md (JFClass (name_of_cd cdecl)) md i).
Proof.
  destruct i.
  + simpl.
    unfold par2env.
    unfold parTypM_of_md.
    unfold name_of_cd.
    sauto.
  + unfold par2env.
    unfold parTypM_of_md.
    unfold name_of_cd.
    replace (S i - 1) with i by auto with arith.
    revert i.
    destruct md; simpl.
    * induction vs; sauto.
    * induction vs; sauto.
Qed.

Definition subenv (Gamma1 Gamma2: JFEnv) : Prop :=
  forall x Acid2, In (x,Acid2) Gamma2 ->
                 exists Acid1,
                   In (x,Acid1) Gamma1 /\ leqIsLS P (JFClass (name_of_cd cdecl)) (name_of_md md) Acid1 Acid2.

Lemma subenv_cons :
  forall Gamma1 Gamma2 x Acid,
    subenv Gamma1 Gamma2 ->
    subenv ((x,Acid)::Gamma1) ((x,Acid)::Gamma2).
Proof.
  unfold subenv.
  intros until 0.
  intros ? ? ? H0.
  inversion H0 as [H1|?].
  + injection H1; intros; subst.
    eexists.
    split.
    ++ sauto.
    ++ eapply leqIsLS_refl; eauto.
  + simpl In; firstorder.
Qed.

Lemma subenv_cons_sub:
  forall Gamma1 Gamma2 x Acid1 Acid2,
    leqIsLS P (JFClass (name_of_cd cdecl)) (name_of_md md) Acid1 Acid2 ->
    subenv Gamma1 Gamma2 ->
    subenv ((x,Acid1)::Gamma1) ((x,Acid2)::Gamma2).
Proof.
  unfold subenv.
  intros until 0.
  intros ? ? ? ? H0.
  inversion H0 as [H2|?].
  + injection H2; intros; subst.
    eexists.
    sauto.
  + simpl In; firstorder.
Qed.

Lemma subenv_refl:
  forall Gamma,
    subenv Gamma Gamma.
Proof.
  induction Gamma.
  + sauto.
  + destruct a.
    eauto using subenv_cons.
Qed.

Lemma subenv_oPlus:
  forall Gamma x acid,
    names_unique P ->
    subtype_well_founded P ->
    subenv (oPlus Gamma x acid) Gamma.
Proof.
  induction Gamma.
  + sauto.
  + intros.
    destruct x; simpl.
    * apply subenv_refl.
    * destruct a.
      destruct (JFVal_dec j (JFVLoc (JFLoc n))).
      - destruct (infACId P acid j0) eqn:Hinf.
        -- eapply infACId_leqIsLS_R in Hinf;eauto.
           eapply subenv_cons_sub;eauto using subenv_refl.
      - auto using subenv_cons.
Qed.

Hint Resolve subenv_cons subenv_cons_sub subenv_refl subenv_oPlus.

Lemma oPlus_non_null :
  forall Gamma l Acid,
    Forall (fun '(v, _) => isNonNullLoc v) Gamma ->
    Forall (fun '(v, _) => isNonNullLoc v) (oPlus Gamma l Acid).
Proof.
  destruct l.
  * induction Gamma; simpl; trivial.
  * induction Gamma; simpl.
    ** intros ? _.
       repeat constructor.
    ** intros (v1, Acid1) H.
       destruct a as (v2, Acid2).
       ***
         inversion_clear H.
         destruct (JFVal_dec v2 (JFVLoc (JFLoc n))).
         ****
           subst.
           destruct (infACId P (v1, Acid1) Acid2); repeat constructor; assumption.
         ****
           constructor; auto.
Qed.

Hint Resolve oPlus_non_null.

Lemma oPlus_null : forall Gamma Acid,
    oPlus Gamma null Acid = Gamma.
Proof.
  induction Gamma; sauto.
Qed.

Hint Rewrite oPlus_non_null.

Lemma name_occ_oPlus_eq:
  forall Gamma v l acid,
    v <> JFVLoc l ->
    Env.name_occ (oPlus Gamma l acid) v = Env.name_occ Gamma v.
Proof.
  induction Gamma.
  + intros * Hne.
    simpl.
    Env.uniq v.
    destruct l.
    ++ trivial.
    ++ unfold Env.NU.name_occ.
       simpl map.
       unfold count_occ.
       destruct VarInEnv.name_dec; intuition.
  + intros * Hne.
    destruct a as (v1,acid1).
    destruct v1 as [l'|x].
    ++ destruct (JFVal_dec (JFVLoc l') (JFVLoc l)) as [e|e].
       +++ injection e;intros;subst.
           destruct l.
           ++++ rewrite oPlus_null;auto.
           ++++ rewrite oplus_decompose_eq;eauto 1.
                congruence.
       +++ rewrite oPlus_neq by auto.
           destruct (JFVal_dec v (JFVLoc l)); Env.uniq v; intuition.
    ++ rewrite oPlus_neq; try congruence.
       destruct (JFVal_dec v (JFSyn x)); Env.uniq v; intuition.
Qed.

Import Env.

Lemma name_occ_oPlus :
  forall Gamma v l acid n,
    v <> JFVLoc l ->
    name_occ Gamma v = n ->
    name_occ (oPlus Gamma l acid) v = n.
Proof.
  intros.
  now rewrite name_occ_oPlus_eq.
Qed.

Hint Resolve name_occ_oPlus.

Lemma names_unique_env_oPlus:
  forall Gamma l acid,
    Env.names_unique Gamma ->
    Env.names_unique (oPlus Gamma l acid).
Proof.
  induction Gamma.
  + unfold names_unique.
    intros.
    intro v.
    destruct l.
    ++ simpl.
       auto.
    ++ simpl oPlus.
       uniq v.
       apply name_xi_small.
  + intros.
    destruct a as (v1,acid1).
    destruct (JFVal_dec v1 (JFVLoc l)).
    ++ subst.
       destruct (Loc_dec l null).
       +++ subst.
           rewrite oPlus_null;eauto 1.
       +++ rewrite oplus_decompose_eq;eauto 1.
    ++ destruct (Loc_dec l null).
       +++ subst.
           rewrite oPlus_null;eauto 1.
       +++ destruct v1.
           ++++
             rewrite oPlus_neq by eauto 2.
             eapply names_unique_cons; eauto 3.
           ++++
             rewrite oPlus_neq by eauto 2.
             eapply names_unique_cons; eauto 3.
Qed.

Hint Resolve names_unique_env_oPlus.

(* TODO: Hack, żeby odsłonić zasłonięte names_unique... *)
Notation names_unique := JaProgram.names_unique.

Lemma In_in_oPlus:
  forall Gamma n D' muD' D'' muD'',
  names_unique P ->
  Env.names_unique Gamma ->
  subtype_well_founded P ->
  In (JFVLoc (JFLoc n), (D', muD')) Gamma ->
  exists (D : JFCId) (muD : JFAMod),
    In (JFVLoc (JFLoc n), (D, muD)) (oPlus Gamma (JFLoc n) (D'', muD'')) /\
    leqACId P (D, muD) (D', muD') /\ leqACId P (D, muD) (D'', muD'').
Proof.
  intros * ? Hun ? HIn.
  induction Gamma.
  + do 2 eexists.
    simpl.
    repeat split; auto with myhints.
  + simpl oPlus.
    destruct a as (x,(Dx,mux)).
    destruct (JFVal_dec x (JFVLoc (JFLoc n))).
    ++
      subst.
      do 2 eexists.
      split.
      +++ simpl; eauto 2.
      +++ assert (In (JFVLoc (JFLoc n), (Dx, mux))
                 ((JFVLoc (JFLoc n), (Dx, mux)) :: Gamma)) as HInx.
          { simpl; auto. }
          eapply Env.name_once_In_unique in HIn; eauto 3.
          (* {simpl; left; reflexivity.} *)
          injection HIn.
          intros; subst.
          do 2 split; eauto 2 using infClass_subL, infClass_subR, infAnn_leq_l, infAnn_leq_r.
    ++
      simpl In in *.
      destruct HIn; try congruence.
      destruct IHGamma as (? & ? & ? & ? & ?); eauto 1; sauto.
Qed.

Lemma In_oPlus_other : forall x Acid l Acid' Gamma,
      x <> JFVLoc l ->
      In (x, Acid) Gamma ->
      In (x, Acid) (oPlus Gamma l Acid').
Proof.
  intros * Hneq.
  induction Gamma.
  { intros []. }
  destruct a as (v,Acid1).
  intros HIn.
  simpl.
  destruct l; trivial.
  destruct JFVal_dec.
  + destruct HIn; try congruence.
    red; auto.
  + destruct HIn as [ -> | H].
    * red; auto.
    * right; auto.
Qed.

Hint Resolve In_oPlus_other.

Definition get_mu phi Gamma n : JFAMod :=
  match phi with
  | true =>
    match find Gamma (JFVLoc (JFLoc n)) with
    | None => JFatm
    | Some (_,(DD,mu')) => mu'
    end
  | false => JFatm
  end.

End EnvsInProgram.