(** * SHL and SHR instructions *)
Require Import x86proved.x86.instrrules.core.
Import x86.instrrules.core.instrruleconfig.

Require Import x86proved.bitsopsprops (* for [dropmsb_iter_shlB] *).

(** Lazy man's proof *)
Lemma SmallCount : forall count, count < 32 -> toNat (n:=8) (andB #x"1f" (fromNat count)) = count.
Proof. do 32 case => //.
Qed.

Lemma SHL_RI_rule s (r:VReg s) (v:VWORD s) (count:nat):
  count < n32 ->
  |-- basic (r~=v ** OSZCP?) (SHL r, count)
            (r~=iter count shlB v ** OSZCP?).
Proof.
  move => BOUND.
  (** We don't want to spin forever if something goes wrong, so we
      only allow [count] to be destructed 5 times.  We do it in the
      middle of the proof to reduce proof term size. *)
  destruct s;
  do 5?[do ![ progress instrrule_triple_bazooka using sbazooka
            | progress rewrite (SmallCount BOUND)
            | progress rewrite /stateIsAny ]
       | destruct count as [|count]; rewrite /(iter 0) ?dropmsb_iter_shlB ].
Qed.

Lemma SHR_RI_rule s (r:VReg s) (v:VWORD s) (count:nat):
  count < n32 ->
  |-- basic (r~=v ** OSZCP?) (SHR r, count)
            (r~=iter count shrB v ** OSZCP?).
Proof.
  move => BOUND.
  (** We don't want to spin forever if something goes wrong, so we
      only allow [count] to be destructed 5 times.  We do it in the
      middle of the proof to reduce proof term size. *)
  destruct s;
  do 5?[do ![ progress instrrule_triple_bazooka using sbazooka
            | progress rewrite (SmallCount BOUND)
            | progress rewrite /stateIsAny ]
       | destruct count as [|count]; rewrite /(iter 0) ?droplsb_iter_shrB ].
Qed.

(** We make this rule an instance of the typeclass, and leave
    unfolding things like [specAtDstSrc] to the getter tactic
    [get_instrrule_of]. *)
Global Instance: forall s (r : VReg s) (count : nat), instrrule (SHL r, count) := fun s r count v => @SHL_RI_rule s r v count.
Global Instance: forall s (r : VReg s) (count : nat), instrrule (SHR r, count) := fun s r count v => @SHR_RI_rule s r v count.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import PSCIAux2.Spec.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition psci_system_reset_spec (rec: Pointer) (adt: RData) : option RData :=
    when adt == system_off_reboot_spec rec adt;
    Some adt {priv: (priv adt) {psci_forward_psci_call: 1}}.

End Spec.


Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.
From PromisingLib Require Import Event.

Require Import Time.
Require Import View.
Require Import BoolMap.
Require Import Promises.
Require Import Cell.
Require Import Memory.
Require Import Global.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import SimLocal.
Require Import SimMemory.
Require Import SimGlobal.

Set Implicit Arguments.

Section SimulationThread.
  Definition SIM_TERMINAL (lang_src lang_tgt:language) :=
    forall (st_src:(Language.state lang_src)) (st_tgt:(Language.state lang_tgt)), Prop.

  Definition SIM_THREAD :=
    forall (lang_src lang_tgt:language) (sim_terminal: SIM_TERMINAL lang_src lang_tgt)
      (st1_src:(Language.state lang_src)) (lc1_src:Local.t) (gl0_src:Global.t)
      (st1_tgt:(Language.state lang_tgt)) (lc1_tgt:Local.t) (gl0_tgt:Global.t), Prop.

  Definition _sim_thread_step
             (lang_src lang_tgt:language)
             (sim_thread:
               forall (st1_src:(Language.state lang_src)) (lc1_src:Local.t) (gl0_src:Global.t)
                 (st1_tgt:(Language.state lang_tgt)) (lc1_tgt:Local.t) (gl0_tgt:Global.t), Prop)
             st1_src lc1_src gl1_src
             st1_tgt lc1_tgt gl1_tgt
    :=
    forall e_tgt st3_tgt lc3_tgt gl3_tgt
      (STEP_TGT: Thread.step e_tgt
                             (Thread.mk _ st1_tgt lc1_tgt gl1_tgt)
                             (Thread.mk _ st3_tgt lc3_tgt gl3_tgt)),
      (<<FAILURE: Thread.steps_failure (Thread.mk _ st1_src lc1_src gl1_src)>>) \/
      exists e_src st2_src lc2_src gl2_src st3_src lc3_src gl3_src,
        (<<FAILURE: ThreadEvent.get_machine_event e_tgt <> MachineEvent.failure>>) /\
        (<<STEPS: rtc (@Thread.tau_step _)
                      (Thread.mk _ st1_src lc1_src gl1_src)
                      (Thread.mk _ st2_src lc2_src gl2_src)>>) /\
        (<<STEP_SRC: Thread.opt_step e_src
                                     (Thread.mk _ st2_src lc2_src gl2_src)
                                     (Thread.mk _ st3_src lc3_src gl3_src)>>) /\
        (<<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>>) /\
        (<<GLOBAL3: sim_global gl3_src gl3_tgt>>) /\
        (<<SIM: sim_thread st3_src lc3_src gl3_src st3_tgt lc3_tgt gl3_tgt>>).

  Definition _sim_thread
             (sim_thread: SIM_THREAD)
             (lang_src lang_tgt:language)
             (sim_terminal: SIM_TERMINAL lang_src lang_tgt)
             (st1_src:(Language.state lang_src)) (lc1_src:Local.t) (gl0_src:Global.t)
             (st1_tgt:(Language.state lang_tgt)) (lc1_tgt:Local.t) (gl0_tgt:Global.t): Prop :=
    forall
      gl1_src gl1_tgt
      (GLOBAL: sim_global gl1_src gl1_tgt)
      (GL_FUTURE_SRC: Global.strong_le gl0_src gl1_src)
      (GL_FUTURE_TGT: Global.le gl0_tgt gl1_tgt)
      (LC_WF_SRC: Local.wf lc1_src gl1_src)
      (LC_WF_TGT: Local.wf lc1_tgt gl1_tgt)
      (GL_WF_SRC: Global.wf gl1_src)
      (GL_WF_TGT: Global.wf gl1_tgt),
      (<<TERMINAL:
        forall (TERMINAL_TGT: (Language.is_terminal lang_tgt) st1_tgt),
          (<<FAILURE: Thread.steps_failure (Thread.mk _ st1_src lc1_src gl1_src)>>) \/
          exists st2_src lc2_src gl2_src,
            (<<STEPS: rtc (@Thread.tau_step _)
                          (Thread.mk _ st1_src lc1_src gl1_src)
                          (Thread.mk _ st2_src lc2_src gl2_src)>>) /\
            (<<GLOBAL: sim_global gl2_src gl1_tgt>>) /\
            (<<TERMINAL_SRC: (Language.is_terminal lang_src) st2_src>>) /\
            (<<LOCAL: sim_local lc2_src lc1_tgt>>) /\
            (<<TERMINAL: sim_terminal st2_src st1_tgt>>)>>) /\
      (<<PROMISES:
        forall (PROMISES_TGT: Local.promises lc1_tgt = BoolMap.bot),
          (<<FAILURE: Thread.steps_failure (Thread.mk _ st1_src lc1_src gl1_src)>>) \/
          exists st2_src lc2_src gl2_src,
            (<<STEPS: rtc (@Thread.tau_step _)
                          (Thread.mk _ st1_src lc1_src gl1_src)
                          (Thread.mk _ st2_src lc2_src gl2_src)>>) /\
            (<<PROMISES_SRC: Local.promises lc2_src = BoolMap.bot>>)>>) /\
      (<<STEP: _sim_thread_step _ _ (@sim_thread lang_src lang_tgt sim_terminal)
                                st1_src lc1_src gl1_src
                                st1_tgt lc1_tgt gl1_tgt>>).

  Lemma _sim_thread_mon: monotone9 _sim_thread.
  Proof.
    ii. exploit IN; eauto. i. des.
    splits; eauto. ii.
    exploit STEP; eauto. i. des; eauto.
    right. esplits; eauto.
  Qed.
  #[local] Hint Resolve _sim_thread_mon: paco.

  Definition sim_thread: SIM_THREAD := paco9 _sim_thread bot9.

  Lemma sim_thread_mon
        (lang_src lang_tgt:language)
        (sim_terminal1 sim_terminal2: SIM_TERMINAL lang_src lang_tgt)
        (SIM: sim_terminal1 <2= sim_terminal2):
    sim_thread sim_terminal1 <6= sim_thread sim_terminal2.
  Proof.
    pcofix CIH. i. punfold PR. pfold. ii.
    exploit PR; eauto. i. des.
    splits; auto.
    - i. exploit TERMINAL; eauto. i. des; eauto.
      right. esplits; eauto.
    - ii. exploit STEP; eauto. i. des; eauto.
      inv SIM0; [|done].
      right. esplits; eauto.
  Qed.
End SimulationThread.
#[export] Hint Resolve _sim_thread_mon: paco.

Lemma sim_thread_step
      lang_src lang_tgt
      sim_terminal
      e_tgt
      st1_src lc1_src gl1_src
      st1_tgt lc1_tgt gl1_tgt
      st3_tgt lc3_tgt gl3_tgt
      (STEP: @Thread.step lang_tgt e_tgt
                          (Thread.mk _ st1_tgt lc1_tgt gl1_tgt)
                          (Thread.mk _ st3_tgt lc3_tgt gl3_tgt))
      (GLOBAL: sim_global gl1_src gl1_tgt)
      (LC_WF_SRC: Local.wf lc1_src gl1_src)
      (LC_WF_TGT: Local.wf lc1_tgt gl1_tgt)
      (GL_WF_SRC: Global.wf gl1_src)
      (GL_WF_TGT: Global.wf gl1_tgt)
      (SIM: sim_thread sim_terminal st1_src lc1_src gl1_src st1_tgt lc1_tgt gl1_tgt):
  (<<FAILURE: Thread.steps_failure (Thread.mk lang_src st1_src lc1_src gl1_src)>>) \/
  exists e_src st2_src lc2_src gl2_src st3_src lc3_src gl3_src,
    (<<FAILURE: ThreadEvent.get_machine_event e_tgt <> MachineEvent.failure>>) /\
    (<<STEPS: rtc (@Thread.tau_step lang_src)
                  (Thread.mk _ st1_src lc1_src gl1_src)
                  (Thread.mk _ st2_src lc2_src gl2_src)>>) /\
    (<<STEP: Thread.opt_step e_src
                             (Thread.mk _ st2_src lc2_src gl2_src)
                             (Thread.mk _ st3_src lc3_src gl3_src)>>) /\
    (<<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>>) /\
    (<<GLOBAL: sim_global gl3_src gl3_tgt>>) /\
    (<<LC_WF_SRC: Local.wf lc3_src gl3_src>>) /\
    (<<LC_WF_TGT: Local.wf lc3_tgt gl3_tgt>>) /\
    (<<GL_WF_SRC: Global.wf gl3_src>>) /\
    (<<GL_WF_TGT: Global.wf gl3_tgt>>) /\
    (<<SIM: sim_thread sim_terminal st3_src lc3_src gl3_src st3_tgt lc3_tgt gl3_tgt>>).
Proof.
  punfold SIM. exploit SIM; eauto; try refl. i. des.
  exploit STEP0; eauto. i. des; eauto.
  inv SIM0; [|done]. right.
  exploit Thread.step_future; eauto. s. i. des.
  exploit Thread.rtc_tau_step_future; eauto. s. i. des.
  exploit Thread.opt_step_future; eauto. s. i. des.
  esplits; eauto.
Qed.

Lemma sim_thread_opt_step
      lang_src lang_tgt
      sim_terminal
      e_tgt
      st1_src lc1_src gl1_src
      st1_tgt lc1_tgt gl1_tgt
      st3_tgt lc3_tgt gl3_tgt
      (STEP: @Thread.opt_step lang_tgt e_tgt
                              (Thread.mk _ st1_tgt lc1_tgt gl1_tgt)
                              (Thread.mk _ st3_tgt lc3_tgt gl3_tgt))
      (GLOBAL: sim_global gl1_src gl1_tgt)
      (LC_WF_SRC: Local.wf lc1_src gl1_src)
      (LC_WF_TGT: Local.wf lc1_tgt gl1_tgt)
      (GL_WF_SRC: Global.wf gl1_src)
      (GL_WF_TGT: Global.wf gl1_tgt)
      (SIM: sim_thread sim_terminal st1_src lc1_src gl1_src st1_tgt lc1_tgt gl1_tgt):
  (<<FAILURE: Thread.steps_failure (Thread.mk lang_src st1_src lc1_src gl1_src)>>) \/
  exists e_src st2_src lc2_src gl2_src st3_src lc3_src gl3_src,
    (<<FAILURE: ThreadEvent.get_machine_event e_tgt <> MachineEvent.failure>>) /\
    (<<STEPS: rtc (@Thread.tau_step lang_src)
                  (Thread.mk _ st1_src lc1_src gl1_src)
                  (Thread.mk _ st2_src lc2_src gl2_src)>>) /\
    (<<STEP: Thread.opt_step e_src
                             (Thread.mk _ st2_src lc2_src gl2_src)
                             (Thread.mk _ st3_src lc3_src gl3_src)>>) /\
    (<<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>>) /\
    (<<GLOBAL: sim_global gl3_src gl3_tgt>>) /\
    (<<LC_WF_SRC: Local.wf lc3_src gl3_src>>) /\
    (<<LC_WF_TGT: Local.wf lc3_tgt gl3_tgt>>) /\
    (<<GL_WF_SRC: Global.wf gl3_src>>) /\
    (<<GL_WF_TGT: Global.wf gl3_tgt>>) /\
    (<<SIM: sim_thread sim_terminal st3_src lc3_src gl3_src st3_tgt lc3_tgt gl3_tgt>>).
Proof.
  inv STEP.
  - right. esplits; eauto; ss.
  - eapply sim_thread_step; eauto.
Qed.

Lemma sim_thread_rtc_step
      lang_src lang_tgt
      sim_terminal
      st1_src lc1_src gl1_src
      th1_tgt th2_tgt
      (STEPS: rtc (@Thread.tau_step lang_tgt) th1_tgt th2_tgt)
      (GLOBAL: sim_global gl1_src (Thread.global th1_tgt))
      (LC_WF_SRC: Local.wf lc1_src gl1_src)
      (LC_WF_TGT: Local.wf (Thread.local th1_tgt) (Thread.global th1_tgt))
      (GL_WF_SRC: Global.wf gl1_src)
      (GL_WF_TGT: Global.wf (Thread.global th1_tgt))
      (SIM: sim_thread sim_terminal
                       st1_src lc1_src gl1_src
                       (Thread.state th1_tgt) (Thread.local th1_tgt) (Thread.global th1_tgt)):
  (<<FAILURE: Thread.steps_failure (Thread.mk lang_src st1_src lc1_src gl1_src)>>) \/
  exists st2_src lc2_src gl2_src,
    (<<STEPS: rtc (@Thread.tau_step lang_src)
                  (Thread.mk _ st1_src lc1_src gl1_src)
                  (Thread.mk _ st2_src lc2_src gl2_src)>>) /\
    (<<GLOBAL: sim_global gl2_src (Thread.global th2_tgt)>>) /\
    (<<LC_WF_SRC: Local.wf lc2_src gl2_src>>) /\
    (<<LC_WF_TGT: Local.wf (Thread.local th2_tgt) (Thread.global th2_tgt)>>) /\
    (<<GL_WF_SRC: Global.wf gl2_src>>) /\
    (<<GL_WF_TGT: Global.wf (Thread.global th2_tgt)>>) /\
    (<<SIM: sim_thread sim_terminal
                       st2_src lc2_src gl2_src
                       (Thread.state th2_tgt) (Thread.local th2_tgt) (Thread.global th2_tgt)>>).
Proof.
  revert GLOBAL LC_WF_SRC LC_WF_TGT GL_WF_SRC GL_WF_TGT SIM.
  revert st1_src lc1_src gl1_src.
  induction STEPS; i.
  { right. esplits; eauto. }
  inv H. destruct x, y. ss.
  exploit Thread.step_future; eauto. s. i. des.
  exploit sim_thread_step; eauto. i. des; eauto.
  exploit IHSTEPS; eauto. i. des.
  - left. inv FAILURE0. des.
    econs; [|eauto|eauto].
    etrans; eauto. inv STEP; eauto.
    econs 2; eauto. econs.
    + eauto.
    + destruct e, e_src; ss.
  - right. destruct z. ss.
    esplits; try apply GLOBAL1; eauto.
    etrans; [eauto|]. etrans; [|eauto]. inv STEP; eauto.
    econs 2; eauto. econs.
    + eauto.
    + destruct e, e_src; ss.
Qed.

Lemma sim_thread_plus_step
      lang_src lang_tgt
      sim_terminal
      e_tgt
      st1_src lc1_src gl1_src
      th1_tgt th2_tgt th3_tgt
      (STEPS: rtc (@Thread.tau_step lang_tgt) th1_tgt th2_tgt)
      (STEP: @Thread.step lang_tgt e_tgt th2_tgt th3_tgt)
      (GLOBAL: sim_global gl1_src (Thread.global th1_tgt))
      (LC_WF_SRC: Local.wf lc1_src gl1_src)
      (LC_WF_TGT: Local.wf (Thread.local th1_tgt) (Thread.global th1_tgt))
      (GL_WF_SRC: Global.wf gl1_src)
      (GL_WF_TGT: Global.wf (Thread.global th1_tgt))
      (SIM: sim_thread sim_terminal
                       st1_src lc1_src gl1_src
                       (Thread.state th1_tgt) (Thread.local th1_tgt) (Thread.global th1_tgt)):
  (<<FAILURE: Thread.steps_failure (Thread.mk lang_src st1_src lc1_src gl1_src)>>) \/
  exists e_src st2_src lc2_src gl2_src st3_src lc3_src gl3_src,
    (<<STEPS: rtc (@Thread.tau_step lang_src)
                  (Thread.mk _ st1_src lc1_src gl1_src)
                  (Thread.mk _ st2_src lc2_src gl2_src)>>) /\
    (<<STEP: Thread.opt_step e_src
                             (Thread.mk _ st2_src lc2_src gl2_src)
                             (Thread.mk _ st3_src lc3_src gl3_src)>>) /\
    (<<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>>) /\
    (<<GLOBAL: sim_global gl3_src (Thread.global th3_tgt)>>) /\
    (<<LC_WF_SRC: Local.wf lc3_src gl3_src>>) /\
    (<<LC_WF_TGT: Local.wf (Thread.local th3_tgt) (Thread.global th3_tgt)>>) /\
    (<<GL_WF_SRC: Global.wf gl3_src>>) /\
    (<<GL_WF_TGT: Global.wf (Thread.global th3_tgt)>>) /\
    (<<SIM: sim_thread sim_terminal
                       st3_src lc3_src gl3_src
                       (Thread.state th3_tgt) (Thread.local th3_tgt) (Thread.global th3_tgt)>>).
Proof.
  destruct th1_tgt, th2_tgt, th3_tgt. ss.
  exploit Thread.rtc_tau_step_future; eauto. s. i. des.
  exploit sim_thread_rtc_step; eauto. s. i. des; eauto.
  exploit Thread.rtc_tau_step_future; try exact STEPS0; eauto. s. i. des.
  exploit sim_thread_step; try exact STEP; try exact SIM0; eauto. s. i. des.
  - left. inv FAILURE. des.
    econs; [|eauto|eauto].
    etrans; eauto.
  - right. rewrite STEPS1 in STEPS0.
    esplits; try exact STEPS0; try exact STEP0; eauto.
Qed.

Lemma sim_thread_steps_failure
      lang_src lang_tgt
      sim_terminal
      e_src e_tgt
      (FAILURE: Thread.steps_failure e_tgt)
      (GLOBAL: sim_global (Thread.global e_src) (Thread.global e_tgt))
      (LC_WF_SRC: Local.wf (Thread.local e_src) (Thread.global e_src))
      (LC_WF_TGT: Local.wf (Thread.local e_tgt) (Thread.global e_tgt))
      (GL_WF_SRC: Global.wf (Thread.global e_src))
      (GL_WF_TGT: Global.wf (Thread.global e_tgt))
      (SIM: @sim_thread lang_src lang_tgt sim_terminal
                        (Thread.state e_src) (Thread.local e_src) (Thread.global e_src)
                        (Thread.state e_tgt) (Thread.local e_tgt) (Thread.global e_tgt)):
  (<<FAILURE: Thread.steps_failure e_src>>).
Proof.
  destruct e_src, e_tgt. ss. inv FAILURE.
  exploit sim_thread_plus_step; eauto. i. des; eauto.
  rewrite EVENT_FAILURE in *. inv STEP; ss.
  esplits; eauto.
Qed.

Lemma sim_thread_future
      lang_src lang_tgt
      sim_terminal
      st_src lc_src gl1_src gl2_src
      st_tgt lc_tgt gl1_tgt gl2_tgt
      (SIM: @sim_thread lang_src lang_tgt sim_terminal st_src lc_src gl1_src st_tgt lc_tgt gl1_tgt)
      (GL_FUTURE_SRC: Global.strong_le gl1_src gl2_src)
      (GL_FUTURE_TGT: Global.le gl1_tgt gl2_tgt):
  sim_thread sim_terminal st_src lc_src gl2_src st_tgt lc_tgt gl2_tgt.
Proof.
  pfold. ii.
  punfold SIM. exploit SIM; (try by etrans; eauto); eauto.
Qed.

Lemma sim_thread_cap
      lang_src lang_tgt
      sim_terminal
      st_src lc_src gl_src
      st_tgt lc_tgt gl_tgt
      (SIM: @sim_thread lang_src lang_tgt sim_terminal st_src lc_src gl_src st_tgt lc_tgt gl_tgt):
  sim_thread sim_terminal
             st_src lc_src (Global.cap_of gl_src)
             st_tgt lc_tgt (Global.cap_of gl_tgt).
Proof.
  eapply sim_thread_future; eauto.
  { eapply Global.cap_strong_le; eauto. }
  { eapply Global.cap_le; eauto. }
Qed.

Lemma sim_thread_consistent
      lang_src lang_tgt
      sim_terminal
      st_src lc_src gl_src
      st_tgt lc_tgt gl_tgt
      (SIM: sim_thread sim_terminal st_src lc_src gl_src st_tgt lc_tgt gl_tgt)
      (GLOBAL: sim_global gl_src gl_tgt)
      (LC_WF_SRC: Local.wf lc_src gl_src)
      (LC_WF_TGT: Local.wf lc_tgt gl_tgt)
      (GL_WF_SRC: Global.wf gl_src)
      (GL_WF_TGT: Global.wf gl_tgt)
      (CONSISTENT: Thread.consistent (Thread.mk lang_tgt st_tgt lc_tgt gl_tgt)):
  Thread.consistent (Thread.mk lang_src st_src lc_src gl_src).
Proof.
  generalize SIM. intro X.
  exploit sim_memory_max_timemap; try eapply GLOBAL; try apply GL_WF_SRC; try apply GL_WF_TGT. i.
  exploit Local.cap_wf; try exact LC_WF_SRC. i.
  exploit Local.cap_wf; try exact LC_WF_TGT. i.
  exploit Global.cap_wf; try exact GL_WF_SRC. i.
  exploit Global.cap_wf; try exact GL_WF_TGT. i.
  hexploit sim_thread_cap; eauto. intros CAP.
  hexploit sim_global_cap; eauto. intros GL.
  inv CONSISTENT.
  - exploit sim_thread_steps_failure; try exact x2; eauto; s; eauto.
  - exploit sim_thread_rtc_step; eauto.
    i. des; eauto. destruct th2. ss.
    punfold SIM0. exploit SIM0; try exact x0; eauto; try refl. i. des.
    exploit PROMISES0; eauto. i. des.
    + econs 1. inv FAILURE.
      econs; [|eauto|eauto]. etrans; eauto.
    + econs 2; [etrans; eauto|]. ss.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Typing rules and a type inference algorithm for RTL. *)

Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Op.
Require Import Registers.
Require Import Globalenvs.
Require Import Values.
Require Import Memory.
Require Import Integers.
Require Import Events.
Require Import Smallstep.
Require Import RTL.
Require Import Conventions.

(** * The type system *)

(** Like Cminor and all intermediate languages, RTL can be equipped with
  a simple type system that statically guarantees that operations
  and addressing modes are applied to the right number of arguments
  and that the arguments are of the correct types.  The type algebra
  is trivial, consisting of the two types [Tint] (for integers and pointers)
  and [Tfloat] (for floats).

  Additionally, we impose that each pseudo-register has the same type
  throughout the function.  This requirement helps with register allocation,
  enabling each pseudo-register to be mapped to a single hardware register
  or stack location of the correct type.

  Finally, we also check that the successors of instructions
  are valid, i.e. refer to non-empty nodes in the CFG.

  The typing judgement for instructions is of the form [wt_instr f env
  instr], where [f] is the current function (used to type-check
  [Ireturn] instructions) and [env] is a typing environment
  associating types to pseudo-registers.  Since pseudo-registers have
  unique types throughout the function, the typing environment does
  not change during type-checking of individual instructions.  One
  point to note is that we have one polymorphic operator, [Omove],
  which can work over both integers and floats.
*)

Definition regenv := reg -> typ.

Section WT_INSTR.

Variable env: regenv.
Variable funct: function.

Definition valid_successor (s: node) : Prop :=
  exists i, funct.(fn_code)!s = Some i.

Inductive wt_instr : instruction -> Prop :=
  | wt_Inop:
      forall s,
      valid_successor s ->
      wt_instr (Inop s)
  | wt_Iopmove:
      forall r1 r s,
      env r1 = env r ->
      valid_successor s ->
      wt_instr (Iop Omove (r1 :: nil) r s)
  | wt_Iop:
      forall op args res s,
      op <> Omove ->
      (List.map env args, env res) = type_of_operation op ->
      valid_successor s ->
      wt_instr (Iop op args res s)
  | wt_Iload:
      forall chunk addr args dst s,
      List.map env args = type_of_addressing addr ->
      env dst = type_of_chunk chunk ->
      valid_successor s ->
      wt_instr (Iload chunk addr args dst s)
  | wt_Istore:
      forall chunk addr args src s,
      List.map env args = type_of_addressing addr ->
      env src = type_of_chunk chunk ->
      valid_successor s ->
      wt_instr (Istore chunk addr args src s)
  | wt_Icall:
      forall sig ros args res s,
      match ros with inl r => env r = Tint | inr s => True end ->
      List.map env args = sig.(sig_args) ->
      env res = proj_sig_res sig ->
      valid_successor s ->
      wt_instr (Icall sig ros args res s)
  | wt_Itailcall:
      forall sig ros args,
      match ros with inl r => env r = Tint | inr s => True end ->
      sig.(sig_res) = funct.(fn_sig).(sig_res) ->
      List.map env args = sig.(sig_args) ->
      tailcall_possible sig ->
      wt_instr (Itailcall sig ros args)
  | wt_Ibuiltin:
      forall ef args res s,
      List.map env args = (ef_sig ef).(sig_args) ->
      env res = proj_sig_res (ef_sig ef) ->
      arity_ok (ef_sig ef).(sig_args) = true \/ ef_reloads ef = false ->
      valid_successor s ->
      wt_instr (Ibuiltin ef args res s)
  | wt_Icond:
      forall cond args s1 s2,
      List.map env args = type_of_condition cond ->
      valid_successor s1 ->
      valid_successor s2 ->
      wt_instr (Icond cond args s1 s2)
  | wt_Ijumptable:
      forall arg tbl,
      env arg = Tint ->
      (forall s, In s tbl -> valid_successor s) ->
      list_length_z tbl * 4 <= Int.max_unsigned ->
      wt_instr (Ijumptable arg tbl)
  | wt_Ireturn:
      forall optres,
      option_map env optres = funct.(fn_sig).(sig_res) ->
      wt_instr (Ireturn optres).

End WT_INSTR.

(** A function [f] is well-typed w.r.t. a typing environment [env],
   written [wt_function env f], if all instructions are well-typed,
   parameters agree in types with the function signature, and
   parameters are pairwise distinct. *)

Record wt_function (f: function) (env: regenv): Prop :=
  mk_wt_function {
    wt_params:
      List.map env f.(fn_params) = f.(fn_sig).(sig_args);
    wt_norepet:
      list_norepet f.(fn_params);
    wt_instrs:
      forall pc instr,
      f.(fn_code)!pc = Some instr -> wt_instr env f instr;
    wt_entrypoint:
      valid_successor f f.(fn_entrypoint)
}.

Inductive wt_fundef: fundef -> Prop :=
  | wt_fundef_external: forall ef,
      wt_fundef (External ef)
  | wt_function_internal: forall f env,
      wt_function f env ->
      wt_fundef (Internal f).

Definition wt_program (p: program): Prop :=
  forall i f, In (i, f) (prog_funct p) -> wt_fundef f.

(** * Type inference *)

(** There are several ways to ensure that RTL code is well-typed and
  to obtain the typing environment (type assignment for pseudo-registers)
  needed for register allocation.  One is to start with well-typed Cminor
  code and show type preservation for RTL generation and RTL optimizations.
  Another is to start with untyped RTL and run a type inference algorithm
  that reconstructs the typing environment, determining the type of
  each pseudo-register from its uses in the code.  We follow the second
  approach.

  We delegate the task of determining the type of each pseudo-register
  to an external ``oracle'': a function written in Caml and not
  proved correct.  We verify the returned type environment using
  the following Coq code, which we will prove correct. *)

Parameter infer_type_environment:
  function -> list (node * instruction) -> option regenv.

(** ** Algorithm to check the correctness of a type environment *)

Section TYPECHECKING.

Variable funct: function.
Variable env: regenv.

Definition check_reg (r: reg) (ty: typ): bool :=
  if typ_eq (env r) ty then true else false.

Fixpoint check_regs (rl: list reg) (tyl: list typ) {struct rl}: bool :=
  match rl, tyl with
  | nil, nil => true
  | r1::rs, ty::tys => check_reg r1 ty && check_regs rs tys
  | _, _ => false
  end.

Definition check_op (op: operation) (args: list reg) (res: reg): bool :=
  let (targs, tres) := type_of_operation op in
  check_regs args targs && check_reg res tres.

Definition check_successor (s: node) : bool :=
  match funct.(fn_code)!s with None => false | Some i => true end.

Definition check_instr (i: instruction) : bool :=
  match i with
  | Inop s =>
      check_successor s
  | Iop Omove (arg::nil) res s =>
      if typ_eq (env arg) (env res)
      then check_successor s
      else false
  | Iop Omove args res s =>
      false
  | Iop op args res s =>
      check_op op args res && check_successor s
  | Iload chunk addr args dst s =>
      check_regs args (type_of_addressing addr)
      && check_reg dst (type_of_chunk chunk)
      && check_successor s
  | Istore chunk addr args src s =>
      check_regs args (type_of_addressing addr)
      && check_reg src (type_of_chunk chunk)
      && check_successor s
  | Icall sig ros args res s =>
      match ros with inl r => check_reg r Tint | inr s => true end
      && check_regs args sig.(sig_args)
      && check_reg res (proj_sig_res sig)
      && check_successor s
  | Itailcall sig ros args =>
      match ros with inl r => check_reg r Tint | inr s => true end
      && check_regs args sig.(sig_args)
      && opt_typ_eq sig.(sig_res) funct.(fn_sig).(sig_res)
      && tailcall_is_possible sig
  | Ibuiltin ef args res s =>
      check_regs args (ef_sig ef).(sig_args)
      && check_reg res (proj_sig_res (ef_sig ef))
      && (if ef_reloads ef then arity_ok (ef_sig ef).(sig_args) else true)
      && check_successor s
  | Icond cond args s1 s2 =>
      check_regs args (type_of_condition cond)
      && check_successor s1
      && check_successor s2
  | Ijumptable arg tbl =>
      check_reg arg Tint
      && List.forallb check_successor tbl
      && zle (list_length_z tbl * 4) Int.max_unsigned
  | Ireturn optres =>
      match optres, funct.(fn_sig).(sig_res) with
      | None, None => true
      | Some r, Some t => check_reg r t
      | _, _ => false
      end
  end.

Definition check_params_norepet (params: list reg): bool :=
  if list_norepet_dec Reg.eq params then true else false.

Fixpoint check_instrs (instrs: list (node * instruction)) : bool :=
  match instrs with
  | nil => true
  | (pc, i) :: rem => check_instr i && check_instrs rem
  end.

(** ** Correctness of the type-checking algorithm *)

Ltac elimAndb :=
  match goal with
  | [ H: _ && _ = true |- _ ] =>
      elim (andb_prop _ _ H); clear H; intros; elimAndb
  | _ =>
      idtac
  end.

Lemma check_reg_correct:
  forall r ty, check_reg r ty = true -> env r = ty.
Proof.
  unfold check_reg; intros.
  destruct (typ_eq (env r) ty). auto. discriminate.
Qed.

Lemma check_regs_correct:
  forall rl tyl, check_regs rl tyl = true -> List.map env rl = tyl.
Proof.
  induction rl; destruct tyl; simpl; intros.
  auto. discriminate. discriminate.
  elimAndb.
  rewrite (check_reg_correct _ _ H). rewrite (IHrl tyl H0). auto.
Qed.

Lemma check_op_correct:
  forall op args res,
  check_op op args res = true ->
  (List.map env args, env res) = type_of_operation op.
Proof.
  unfold check_op; intros.
  destruct (type_of_operation op) as [targs tres].
  elimAndb.
  rewrite (check_regs_correct _ _ H).
  rewrite (check_reg_correct _ _ H0).
  auto.
Qed.

Lemma check_successor_correct:
  forall s,
  check_successor s = true -> valid_successor funct s.
Proof.
  intro; unfold check_successor, valid_successor.
  destruct (fn_code funct)!s; intro.
  exists i; auto.
  discriminate.
Qed.

Lemma check_instr_correct:
  forall i, check_instr i = true -> wt_instr env funct i.
Proof.
  unfold check_instr; intros; destruct i; elimAndb.
  (* nop *)
  constructor. apply check_successor_correct; auto.
  (* op *)
  destruct o; elimAndb;
  try (apply wt_Iop; [ congruence
                     | apply check_op_correct; auto
                     | apply check_successor_correct; auto ]).
  destruct l; try discriminate. destruct l; try discriminate.
  destruct (typ_eq (env r0) (env r)); try discriminate.
  apply wt_Iopmove; auto. apply check_successor_correct; auto.
  (* load *)
  constructor. apply check_regs_correct; auto. apply check_reg_correct; auto.
  apply check_successor_correct; auto.
  (* store *)
  constructor. apply check_regs_correct; auto. apply check_reg_correct; auto.
  apply check_successor_correct; auto.
  (* call *)
  constructor.
  destruct s0; auto. apply check_reg_correct; auto.
  apply check_regs_correct; auto.
  apply check_reg_correct; auto.
  apply check_successor_correct; auto.
  (* tailcall *)
  constructor.
  destruct s0; auto. apply check_reg_correct; auto.
  eapply proj_sumbool_true; eauto.
  apply check_regs_correct; auto.
  apply tailcall_is_possible_correct; auto.
  (* builtin *)
  constructor.
  apply check_regs_correct; auto.
  apply check_reg_correct; auto.
  auto.
  destruct (ef_reloads e); auto.
  apply check_successor_correct; auto.
  (* cond *)
  constructor. apply check_regs_correct; auto.
  apply check_successor_correct; auto.
  apply check_successor_correct; auto.
  (* jumptable *)
  constructor. apply check_reg_correct; auto.
  rewrite List.forallb_forall in H1. intros. apply check_successor_correct; auto.
  eapply proj_sumbool_true. eauto.
  (* return *)
  constructor.
  destruct o; simpl; destruct funct.(fn_sig).(sig_res); try discriminate.
  rewrite (check_reg_correct _ _ H); auto.
  auto.
Qed.

Lemma check_instrs_correct:
  forall instrs,
  check_instrs instrs = true ->
  forall pc i, In (pc, i) instrs -> wt_instr env funct i.
Proof.
  induction instrs; simpl; intros.
  elim H0.
  destruct a as [pc' i']. elimAndb.
  elim H0; intro.
  inversion H2; subst pc' i'. apply check_instr_correct; auto.
  eauto.
Qed.

End TYPECHECKING.

(** ** The type inference function **)

Open Scope string_scope.

Definition type_function (f: function): res regenv :=
  let instrs := PTree.elements f.(fn_code) in
  match infer_type_environment f instrs with
  | None => Error (msg "RTL type inference error")
  | Some env =>
      if check_regs env f.(fn_params) f.(fn_sig).(sig_args)
      && check_params_norepet f.(fn_params)
      && check_instrs f env instrs
      && check_successor f f.(fn_entrypoint)
      then OK env
      else Error (msg "RTL type checking error")
  end.

Lemma type_function_correct:
  forall f env,
  type_function f = OK env ->
  wt_function f env.
Proof.
  unfold type_function; intros until env.
  set (instrs := PTree.elements f.(fn_code)).
  case (infer_type_environment f instrs).
  intro env'.
  caseEq (check_regs env' f.(fn_params) f.(fn_sig).(sig_args)); intro; simpl; try congruence.
  caseEq (check_params_norepet f.(fn_params)); intro; simpl; try congruence.
  caseEq (check_instrs f env' instrs); intro; simpl; try congruence.
  caseEq (check_successor f (fn_entrypoint f)); intro; simpl; try congruence.
  intro EQ; inversion EQ; subst env'.
  constructor.
  apply check_regs_correct; auto.
  unfold check_params_norepet in H0.
  destruct (list_norepet_dec Reg.eq (fn_params f)). auto. discriminate.
  intros. eapply check_instrs_correct. eauto.
  unfold instrs. apply PTree.elements_correct. eauto.
  apply check_successor_correct. auto.
  congruence.
Qed.

(** * Type preservation during evaluation *)

(** The type system for RTL is not sound in that it does not guarantee
  progress: well-typed instructions such as [Icall] can fail because
  of run-time type tests (such as the equality between callee and caller's
  signatures).  However, the type system guarantees a type preservation
  property: if the execution does not fail because of a failed run-time
  test, the result values and register states match the static
  typing assumptions.  This preservation property will be useful
  later for the proof of semantic equivalence between [Linear] and [Mach].
  Even though we do not need it for [RTL], we show preservation for [RTL]
  here, as a warm-up exercise and because some of the lemmas will be
  useful later. *)

Definition wt_regset (env: regenv) (rs: regset) : Prop :=
  forall r, Val.has_type (rs#r) (env r).

Lemma wt_regset_assign:
  forall env rs v r,
  wt_regset env rs ->
  Val.has_type v (env r) ->
  wt_regset env (rs#r <- v).
Proof.
  intros; red; intros.
  rewrite Regmap.gsspec.
  case (peq r0 r); intro.
  subst r0. assumption.
  apply H.
Qed.

Lemma wt_regset_list:
  forall env rs,
  wt_regset env rs ->
  forall rl, Val.has_type_list (rs##rl) (List.map env rl).
Proof.
  induction rl; simpl.
  auto.
  split. apply H. apply IHrl.
Qed.

Lemma wt_init_regs:
  forall env rl args,
  Val.has_type_list args (List.map env rl) ->
  wt_regset env (init_regs args rl).
Proof.
  induction rl; destruct args; simpl; intuition.
  red; intros. rewrite Regmap.gi. simpl; auto.
  apply wt_regset_assign; auto.
Qed.

Inductive wt_stackframes: list stackframe -> option typ -> Prop :=
  | wt_stackframes_nil:
      wt_stackframes nil (Some Tint)
  | wt_stackframes_cons:
      forall s res f sp pc rs env tyres,
      wt_function f env ->
      wt_regset env rs ->
      env res = match tyres with None => Tint | Some t => t end ->
      wt_stackframes s (sig_res (fn_sig f)) ->
      wt_stackframes (Stackframe res f sp pc rs :: s) tyres.

Inductive wt_state: state -> Prop :=
  | wt_state_intro:
      forall s f sp pc rs m env
        (WT_STK: wt_stackframes s (sig_res (fn_sig f)))
        (WT_FN: wt_function f env)
        (WT_RS: wt_regset env rs),
      wt_state (State s f sp pc rs m)
  | wt_state_call:
      forall s f args m,
      wt_stackframes s (sig_res (funsig f)) ->
      wt_fundef f ->
      Val.has_type_list args (sig_args (funsig f)) ->
      wt_state (Callstate s f args m)
  | wt_state_return:
      forall s v m tyres,
      wt_stackframes s tyres ->
      Val.has_type v (match tyres with None => Tint | Some t => t end) ->
      wt_state (Returnstate s v m).

Section SUBJECT_REDUCTION.

Variable p: program.

Hypothesis wt_p: wt_program p.

Let ge := Genv.globalenv p.

Lemma subject_reduction:
  forall st1 t st2, step ge st1 t st2 ->
  forall (WT: wt_state st1), wt_state st2.
Proof.
  induction 1; intros; inv WT;
  try (generalize (wt_instrs _ _ WT_FN pc _ H);
       intro WT_INSTR;
       inv WT_INSTR).
  (* Inop *)
  econstructor; eauto.
  (* Iop *)
  econstructor; eauto.
  apply wt_regset_assign. auto.
  simpl in H0. inv H0. rewrite <- H3. apply WT_RS.
  econstructor; eauto.
  apply wt_regset_assign. auto.
  replace (env res) with (snd (type_of_operation op)).
  eapply type_of_operation_sound; eauto.
  rewrite <- H6. reflexivity.
  (* Iload *)
  econstructor; eauto.
  apply wt_regset_assign. auto. rewrite H8.
  eapply type_of_chunk_correct; eauto.
  (* Istore *)
  econstructor; eauto.
  (* Icall *)
  assert (wt_fundef fd).
    destruct ros; simpl in H0.
    pattern fd. apply Genv.find_funct_prop with fundef unit p (rs#r).
    exact wt_p. exact H0.
    caseEq (Genv.find_symbol ge i); intros; rewrite H1 in H0.
    pattern fd. apply Genv.find_funct_ptr_prop with fundef unit p b.
    exact wt_p. exact H0.
    discriminate.
  econstructor; eauto.
  econstructor; eauto.
  rewrite <- H7. apply wt_regset_list. auto.
  (* Itailcall *)
  assert (wt_fundef fd).
    destruct ros; simpl in H0.
    pattern fd. apply Genv.find_funct_prop with fundef unit p (rs#r).
    exact wt_p. exact H0.
    caseEq (Genv.find_symbol ge i); intros; rewrite H1 in H0.
    pattern fd. apply Genv.find_funct_ptr_prop with fundef unit p b.
    exact wt_p. exact H0.
    discriminate.
  econstructor; eauto.
  rewrite H6; auto.
  rewrite <- H7. apply wt_regset_list. auto.
  (* Ibuiltin *)
  econstructor; eauto.
  apply wt_regset_assign. auto.
  rewrite H6. eapply external_call_well_typed; eauto.
  (* Icond *)
  econstructor; eauto.
  (* Ijumptable *)
  econstructor; eauto.
  (* Ireturn *)
  econstructor; eauto.
  destruct or; simpl in *.
  rewrite <- H2. apply WT_RS. exact I.
  (* internal function *)
  simpl in *. inv H5. inversion H1; subst.
  econstructor; eauto.
  apply wt_init_regs; auto. rewrite wt_params0; auto.
  (* external function *)
  simpl in *. inv H5.
  econstructor; eauto.
  change (Val.has_type res (proj_sig_res (ef_sig ef))).
  eapply external_call_well_typed; eauto.
  (* return *)
  inv H1. econstructor; eauto.
  apply wt_regset_assign; auto. congruence.
Qed.

End SUBJECT_REDUCTION.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Recognition of combined operations, addressing modes and conditions
  during the [CSE] phase. *)

Require Import FunInd.
Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Memory.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import CSEdomain.
Require Import CombineOp.

Section COMBINE.

Variable ge: genv.
Variable sp: val.
Variable m: mem.
Variable get: valnum -> option rhs.
Variable valu: valnum -> val.
Hypothesis get_sound: forall v rhs, get v = Some rhs -> rhs_eval_to valu ge sp m rhs (valu v).

Lemma get_op_sound:
  forall v op vl, get v = Some (Op op vl) -> eval_operation ge sp op (map valu vl) m = Some (valu v).
Proof.
  intros. exploit get_sound; eauto. intros REV; inv REV; auto.
Qed.

Ltac UseGetSound :=
  match goal with
  | [ H: get _ = Some _ |- _ ] =>
      let x := fresh "EQ" in (generalize (get_op_sound _ _ _ H); intros x; simpl in x; FuncInv)
  end.

Lemma combine_compimm_ne_0_sound:
  forall x cond args,
  combine_compimm_ne_0 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.zero) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.zero).
Proof.
  intros until args. functional induction (combine_compimm_ne_0 get x); intros EQ; inv EQ.
  (* of cmp *)
  UseGetSound. rewrite <- H.
  destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Lemma combine_compimm_eq_0_sound:
  forall x cond args,
  combine_compimm_eq_0 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.zero) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.zero).
Proof.
  intros until args. functional induction (combine_compimm_eq_0 get x); intros EQ; inv EQ.
  (* of cmp *)
  UseGetSound. rewrite <- H.
  rewrite eval_negate_condition.
  destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Lemma combine_compimm_eq_1_sound:
  forall x cond args,
  combine_compimm_eq_1 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.one) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.one).
Proof.
  intros until args. functional induction (combine_compimm_eq_1 get x); intros EQ; inv EQ.
  (* of cmp *)
  UseGetSound. rewrite <- H.
  destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Lemma combine_compimm_ne_1_sound:
  forall x cond args,
  combine_compimm_ne_1 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.one) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.one).
Proof.
  intros until args. functional induction (combine_compimm_ne_1 get x); intros EQ; inv EQ.
  (* of cmp *)
  UseGetSound. rewrite <- H.
  rewrite eval_negate_condition.
  destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Theorem combine_cond_sound:
  forall cond args cond' args',
  combine_cond get cond args = Some(cond', args') ->
  eval_condition cond' (map valu args') m = eval_condition cond (map valu args) m.
Proof.
  intros. functional inversion H; subst.
  (* compimm ne zero *)
  - simpl; eapply combine_compimm_ne_0_sound; eauto.
  (* compimm ne one *)
  - simpl; eapply combine_compimm_ne_1_sound; eauto.
  (* compimm eq zero *)
  - simpl; eapply combine_compimm_eq_0_sound; eauto.
  (* compimm eq one *)
  - simpl; eapply combine_compimm_eq_1_sound; eauto.
  (* compuimm ne zero *)
  - simpl; eapply combine_compimm_ne_0_sound; eauto.
  (* compuimm ne one *)
  - simpl; eapply combine_compimm_ne_1_sound; eauto.
  (* compuimm eq zero *)
  - simpl; eapply combine_compimm_eq_0_sound; eauto.
  (* compuimm eq one *)
  - simpl; eapply combine_compimm_eq_1_sound; eauto.
Qed.

Theorem combine_addr_sound:
  forall addr args addr' args',
  combine_addr get addr args = Some(addr', args') ->
  eval_addressing ge sp addr' (map valu args') = eval_addressing ge sp addr (map valu args).
Proof.
  intros. functional inversion H; subst.
- (* indexed - addimm *)
  UseGetSound. simpl. rewrite <- H0. destruct v; auto. simpl; rewrite H7; simpl.
  rewrite Ptrofs.add_assoc. auto.
- (* indexed - addimml *)
  UseGetSound. simpl. rewrite <- H0. destruct v; auto. simpl; rewrite H7; simpl.
  rewrite Ptrofs.add_assoc. auto.
Qed.

Theorem combine_op_sound:
  forall op args op' args',
  combine_op get op args = Some(op', args') ->
  eval_operation ge sp op' (map valu args') m = eval_operation ge sp op (map valu args) m.
Proof.
  intros. functional inversion H; subst.
  (* addimm - addimm *)
  - UseGetSound. FuncInv. simpl.
    rewrite <- H0. rewrite Val.add_assoc. auto.
  (* andimm - andimm *)
  - UseGetSound; simpl.
    generalize (Int.eq_spec p m0); rewrite H7; intros.
    rewrite <- H0. rewrite Val.and_assoc. simpl. fold p. rewrite H1. auto.
  - UseGetSound; simpl.
    rewrite <- H0. rewrite Val.and_assoc. auto.
  (* orimm - orimm *)
  - UseGetSound. simpl. rewrite <- H0. rewrite Val.or_assoc. auto.
  (* xorimm - xorimm *)
  - UseGetSound. simpl. rewrite <- H0. rewrite Val.xor_assoc. auto.
  (* addlimm - addlimm *)
  - UseGetSound. FuncInv. simpl.
    rewrite <- H0. rewrite Val.addl_assoc. auto.
  (* andlimm - andlimm *)
  - UseGetSound; simpl.
    generalize (Int64.eq_spec p m0); rewrite H7; intros.
    rewrite <- H0. rewrite Val.andl_assoc. simpl. fold p. rewrite H1. auto.
  - UseGetSound; simpl.
    rewrite <- H0. rewrite Val.andl_assoc. auto.
  (* orlimm - orlimm *)
  - UseGetSound. simpl. rewrite <- H0. rewrite Val.orl_assoc. auto.
  (* xorlimm - xorlimm *)
  - UseGetSound. simpl. rewrite <- H0. rewrite Val.xorl_assoc. auto.
  (* cmp *)
  - simpl. decEq; decEq. eapply combine_cond_sound; eauto.
Qed.

End COMBINE.


From iris.base_logic.lib Require Import invariants gen_heap wsat ghost_map.
From iris.program_logic Require Import weakestpre adequacy.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Import invariants gen_heap.
From st.STLCmuVS Require Import lang.
From st.STLCmuST Require Import wkpre lang types.
From st.backtranslations.st_sem.correctness.st_le_sem.logrel Require Import definition lift.
From st Require Import resources.

Definition Σ : gFunctors :=
  #[invΣ;
    gen_heapΣ loc val;
    ghost_mapΣ nat STLCmuVS.lang.val;
    ghost_mapΣ nat loc
    ].

Instance st_le_semΣ_inst (H : invGS Σ) (H' : gen_heapGS loc lang.val Σ) : st_le_semΣ Σ :=
  { invGS_inst := _ ;
    genHeapG_inst' := _;
    val_ghost_mapG_inst' := _;
    loc_ghost_mapG_inst' := _;
  }.

(* st_le_ *)
Lemma exprel_adequate (e : expr) (e' : STLCmuVS.lang.expr)
      (Hee' : ∀ {Σ : gFunctors}
                {st_le_semΣ_inst : st_le_semΣ Σ},
          ⊢ exprel_typed [] TUnit e e') :
  STLCmuST_halts e → STLCmuVS_halts e'.
Proof.
  intros He. destruct He as (v & σ & He).
  cut (adequate MaybeStuck e ∅ (fun _ _ => STLCmuVS_halts e')).
  { intro Ha. apply (adequate_result _ _ _ _ Ha [] σ v).
    change ([?e], ?σ) with ((fun p => ([p.2], p.1)) (σ, e)).
    eapply (rtc_congruence (fun p => ([p.2], p.1))); eauto.
    intros [σ1 e1] [σ2 e2] Hstep. rewrite /STLCmuST_step in Hstep.
    rewrite /erased_step /=. exists []. apply (step_atomic e1 σ1 e2 σ2 [] [] []); by simpl. }
  apply (wp_adequacy Σ STLCmuST_lang MaybeStuck e (∅ : gmap loc val) (fun _ => STLCmuVS_halts e')).
  { intros invGS_inst' κs.
    iMod (gen_heap_init (∅ : gmap loc val)) as (gen_heapGS_inst') "(H∅ & _ & _)". iModIntro.
    iExists (fun σ _ => gen_heap_interp σ).
    iExists (fun _ => True%I).
    iFrame "H∅".
    specialize (Hee' Σ _).
    iDestruct Hee' as "Hee'". rewrite /exprel_typed /lift /=.
    iApply (wp_wand with "Hee'").
    iIntros (w) "Hdes". iDestruct "Hdes" as (w') "[%He' _]".
    iPureIntro. by eexists.
  }
Qed.


Set Universe Polymorphism.
Unset Universe Minimization ToSet.

Inductive Unification : Set :=
| UniCoq : Unification
| UniMatch : Unification
| UniMatchNoRed : Unification
| UniEvarconv : Unification.


Require Import RamifyCoq.sample_mark.env_unionfind_iter.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.subgraph2.
Require Import RamifyCoq.graph.graph_relation.
Require Import RamifyCoq.graph.reachable_computable.
Require Import RamifyCoq.msl_application.Graph.
Require Import RamifyCoq.msl_application.UnionFindGraph.
Require Import RamifyCoq.msl_application.GList.
Require Import RamifyCoq.msl_application.GList_UnionFind.
Require Import RamifyCoq.floyd_ext.share.
Require Import RamifyCoq.sample_mark.spatial_graph_uf_iter.

Local Coercion UGraph_LGraph: Graph >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Notation vertices_at sh P g:= (@vertices_at _ _ _ _ _ _ (@SGP pSGG_VST nat unit (sSGG_VST sh)) _ P g).
Notation whole_graph sh g := (vertices_at sh (vvalid g) g).
Notation graph sh x g := (@reachable_vertices_at _ _ _ _ _ _ _ _ _ _ (@SGP pSGG_VST nat unit (sSGG_VST sh)) _ x g).
Notation Graph := (@Graph pSGG_VST).
Existing Instances maGraph finGraph liGraph RGF.

Definition find_spec :=
 DECLARE _find
  WITH sh: wshare, g: Graph, x: pointer_val
  PRE [ _x OF (tptr (Tstruct _Node noattr))]
          PROP  (vvalid g x)
          LOCAL (temp _x (pointer_val_val x))
          SEP   (whole_graph sh g)
  POST [ tptr (Tstruct _Node noattr) ]
        EX g': Graph, EX rt : pointer_val,
        PROP (uf_equiv g g' /\ uf_root g' x rt)
        LOCAL (temp ret_temp (pointer_val_val rt))
        SEP (whole_graph sh g').

Definition Gprog : funspecs := ltac:(with_library prog [find_spec]).

Lemma false_Cne_eq: forall x y, typed_false tint (force_val (sem_cmp_pp Cne (pointer_val_val x) (pointer_val_val y))) -> x = y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; auto. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. subst; auto.
    + simpl in H. inversion H.
  - simpl in H. inversion H.
Qed.

Lemma true_Cne_neq: forall x y, typed_true tint (force_val (sem_cmp_pp Cne (pointer_val_val x) (pointer_val_val y))) -> x <> y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; [|intro; inversion H0..]. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + simpl in H. inversion H.
    + subst b0. pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. intro; apply H0. inversion H1. reflexivity.
  - intro. inversion H0. auto.
Qed.

Lemma graph_local_facts: forall sh x (g: Graph), vvalid g x -> whole_graph sh g |-- valid_pointer (pointer_val_val x).
Proof.
  intros. eapply derives_trans; [apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) x (vgamma g x)); auto |].
  simpl vertex_at at 1. unfold binode. entailer!.
Qed.

Lemma body_find: semax_body Vprog Gprog f_find find_spec.
Proof.
  start_function.
  remember (vgamma g x) as rpa eqn:?H. destruct rpa as [r pa]. symmetry in H0.
  (* tmp = x *)
  Opaque pointer_val_val. forward. Transparent pointer_val_val.
  (* p = x -> parent; *)
  localize [data_at sh node_type (vgamma2cdata (vgamma g x)) (pointer_val_val x)].
  rewrite H0. simpl vgamma2cdata. forward. 1: entailer!; destruct pa; simpl; auto.
  unlocalize [whole_graph sh g].
  1: rewrite H0; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) x (r, pa)); auto.
  forward_while (EX p: pointer_val, EX ppa: pointer_val,
                 PROP (reachable g x p /\ vgamma g p = (vlabel g p, ppa))
                 LOCAL (temp _p (pointer_val_val ppa); temp _tmp (pointer_val_val p); temp _x (pointer_val_val x))
                 SEP (vertices_at sh (vvalid g) g)).
  - Exists x pa. entailer!. split; [apply reachable_refl | f_equal; simpl in H0; inversion H0]; auto.
  - entailer!. destruct H1. apply reachable_foot_valid in H1. pose proof (valid_parent _ _ _ _ H1 H5). apply denote_tc_test_eq_split; apply graph_local_facts; auto.
  - destruct H1. apply true_Cne_neq in HRE.
    Opaque pointer_val_val. forward. Transparent pointer_val_val. remember (vgamma g ppa) as rpa eqn:?H. destruct rpa as [mr mgpa]. symmetry in H3.
    assert (H_VALID_PPA: vvalid g ppa) by (apply (valid_parent _ p (vlabel g p)); [apply reachable_foot_valid in H1 |]; auto).
    localize [data_at sh node_type (vgamma2cdata (vgamma g ppa)) (pointer_val_val ppa)].
    rewrite H3. simpl vgamma2cdata. forward. 1: entailer!; destruct mgpa; simpl; auto.
    unlocalize [whole_graph sh g].
    1: rewrite H3; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) ppa (mr, mgpa)); auto.
    Exists (ppa, mgpa). simpl fst. simpl snd. assert (mr = vlabel g ppa) by (simpl in H3; inversion H3; auto). rewrite <- H4. entailer !.
    apply reachable_edge with p; auto. apply (vgamma_not_edge g p (vlabel g p)); auto. apply reachable_foot_valid in H1; auto.
  - destruct H1. apply false_Cne_eq in HRE. subst ppa. assert (uf_root g x p) by (split; intros; auto; apply (parent_loop g p (vlabel g p) y); auto).
    forward_while (EX g': Graph, EX tmp: pointer_val, EX xv: pointer_val,
                   PROP (uf_equiv g g' /\ uf_root g' xv p)
                   LOCAL (temp _p (pointer_val_val p); temp _tmp (pointer_val_val tmp); temp _x (pointer_val_val xv))
                   SEP (whole_graph sh g')).
    + Exists g p x. entailer!. apply (uf_equiv_refl _  (liGraph g)).
    + entailer!. apply denote_tc_test_eq_split; apply graph_local_facts.
      * destruct H4 as [_ [? _]]. apply reachable_head_valid in H4; assumption.
      * destruct H4 as [[? _] _]. rewrite <- H4. apply reachable_foot_valid in H1; assumption.
    + destruct H4 as [? ?]. apply true_Cne_neq in HRE. remember (vgamma g' xv) as rpa eqn:?H. destruct rpa as [xr xpa]. symmetry in H6.
      assert (H_VALID_XV: vvalid g' xv) by (destruct H5 as [? _]; apply reachable_head_valid in H5; auto).
      localize [data_at sh node_type (vgamma2cdata (vgamma g' xv)) (pointer_val_val xv)].
      rewrite H6. simpl vgamma2cdata. forward. 1: entailer!; destruct xpa; simpl; auto.
      unlocalize [whole_graph sh g'].
      1: rewrite H6; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g' (vvalid g') xv (xr, xpa)); auto.
      assert (weak_valid g' p) by (right; destruct H4; rewrite <- H4; apply reachable_foot_valid in H1; auto).
      assert (vvalid g' xv) by (destruct H5; apply reachable_head_valid in H5; auto).
      assert (~ reachable g' p xv) by (intro; destruct H5 as [_ ?]; specialize (H5 _ H9); auto).
      assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g' xv p H7 H8 H9)) (Graph_gen_redirect_parent g' xv p H7 H8 H9) =
              vertices_at sh (vvalid g') (Graph_gen_redirect_parent g' xv p H7 H8 H9)). {
        apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
      assert (H_P_NOT_NULL: p <> null) by (apply reachable_foot_valid in H1; intro; subst p; apply (valid_not_null g null H1); simpl; auto).
      localize [data_at sh node_type (Vint (Int.repr (Z.of_nat xr)), pointer_val_val xpa) (pointer_val_val xv)].
      forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g' xv p H7 H8 H9)].
      1: rewrite H10; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
      Opaque pointer_val_val. forward. Transparent pointer_val_val.
      Exists (((Graph_gen_redirect_parent g' xv p H7 H8 H9), xpa), xpa). simpl fst. simpl snd. rewrite H10. entailer !. split.
      * apply (graph_gen_redirect_parent_equiv' g g' xv p); auto.
      * apply (uf_root_gen_dst_preserve g' (liGraph g')); auto.
        -- apply (vgamma_not_reachable _ _ xr); auto. pose proof (uf_root_not_eq_root_vgamma g' _ _ _ _ H6 H5 HRE). auto.
        -- apply (vgamma_uf_root g' xv xr xpa p); auto.
    + destruct H4. forward. Exists g' p. entailer!. rewrite <- (uf_equiv_root_the_same g g' x p); auto.
Qed.


Require Import UpperBound_A UpperBound_B LowerBound.
Require Import CompilerC.
Require Import CoqlibC.
Require Import BehaviorsC LinkingC EventsC MapsC ASTC CtypesC.

Theorem separate_compilation_correct
        (srcs: list Csyntax.program) (tgts: list Asm.program) builtins src_link
        (TYPECHECKS: Forall (fun src => CsemC.typechecked builtins src) srcs)
        (TYPECHECKLINK: CsemC.typechecked builtins src_link)
        (LINK: link_list srcs = Some src_link)
        (MAIN: exists main_f,
            (<<INTERNAL: (prog_defmap src_link) ! (src_link.(prog_main)) = Some (Gfun (Ctypes.Internal main_f))>>) /\
            (<<SIG: type_of_function main_f = Tfunction Ctypes.Tnil type_int32s cc_default>>))
        (TR: Errors.mmap transf_c_program srcs = Errors.OK tgts):
    (<<INITUB: program_behaves (Csem.semantics src_link) (Goes_wrong E0)>>) \/
    exists tgt_link, <<LINK: link_list tgts = Some tgt_link>> /\
                     <<IMPROVES: improves (Csem.semantics src_link) (Asm.semantics tgt_link)>>.
Proof.
  hexploit upperbound_b_correct; eauto. { des. esplits; et. } intro A.
  hexploit upperbound_a_correct; eauto. instantiate (1:= []). ss. intro B; des.
  hexploit compiler_correct_full; eauto.
  { do 2 instantiate (1:= []). ss. }
  instantiate (1:= []). ss. rewrite ! app_nil_r. intro C; des.
  hexploit (lower_bound_correct tgts); eauto. intro D. des.
  { left.
    hexploit back_propagate_ub_program; try apply C; et. intro CUB.
    hexploit back_propagate_ub_program; try apply CUB; et. intro BUB.
    hexploit back_propagate_ub_program; try apply BUB; et.
  }
  right. esplits; et. etrans; et. etrans; et. etrans; et.
Qed.


(******************************************************************************)
(** Generic Syntax                                                            *)
(******************************************************************************)

From Bits Require Import bits.

From Coq Require Import ssreflect.
From Coq Require Import List.
Import ListNotations.

From mathcomp Require Import eqtype tuple.

From BIRD Require Import Bits Util.

Declare Scope bird_scope.
Delimit Scope bird_scope with bird.

(******************************************************************************)
(*** Memory                                                                   *)
(******************************************************************************)

Section ADDRESS.

  Local Open Scope bird.

  Let _0 : qword := (#0, #0, #0, #0, #0, #0, #0, #0).
  Let _1 : qword := (#0, #0, #0, #0, #0, #0, #0, #1).
  Let _2 : qword := (#0, #0, #0, #0, #0, #0, #0, #2).
  Let _4 : qword := (#0, #0, #0, #0, #0, #0, #0, #4).
  Let _8 : qword := (#0, #0, #0, #0, #0, #0, #0, #8).

  Variable (Cell : Type).

  Variant scale := scale1 | scale2 | scale4 | scale8.

  Definition qword_scale (v : qword) (s : scale) : qword :=
    match s with
    | scale1 => v
    | scale2 => v + v
    | scale4 => v + v + v + v
    | scale8 => v + v + v + v + v + v + v
    end.

  Definition abs_addr := qword.

  Record addr_expr := mk_addr_expr
    { expr_base   : option Cell
    ; expr_index  : option Cell
    ; expr_scale  : scale
    ; expr_offset : abs_addr
    }.

  Definition addr := (word_size * addr_expr)%type.

  Definition addr_expr_eval (e : addr_expr) (f : Cell -> qword) : abs_addr :=
    let b_val := if expr_base e is Some b_cell then f b_cell else _0 in
    let i_val := if expr_index e is Some i_cell then f i_cell else _0 in
    let d_val := expr_offset e in
    b_val + (qword_scale i_val (expr_scale e)) + d_val.

  Definition addr_word_type (a : addr) : Type :=
    match fst a with
    | BYTE  => byte
    | WORD  => word
    | DWORD => dword
    | QWORD => qword
    end.

End ADDRESS.

Arguments addr_word_type {Cell}.
Arguments addr_expr_eval {Cell}.

(******************************************************************************)
(*** FLAGS                                                                    *)
(******************************************************************************)

Section FLAGS.

  Variant flag := zero_flag | adjust_flag | carry_flag | parity_flag.

  Definition flag_eq_dec (a b : flag) : {a = b} + {a <> b}. decide equality. Defined.
  Definition flag_eqb (a b : flag) := if flag_eq_dec a b is left _ then true else false.

End FLAGS.

(******************************************************************************)
(*** STATE PART                                                               *)
(******************************************************************************)

Section STATEPART.

  Variable (Cell : Type).
  Variable (Annot : Type).

  Variant source :=
    | src_imm  of qword
    | src_addr of addr Cell
    | src_expr of addr_expr Cell
    | src_cell of Cell & Annot
    | src_rip.

  Variant destination :=
    | dst_addr of addr Cell
    | dst_cell of Cell & Annot.

End STATEPART.

(******************************************************************************)
(*** PROGRAM GRAPH                                                            *)
(******************************************************************************)

Section GRAPH.

  Variables (Cell Annot Label : Type).

  Variant opcode_1_1  := op_mov  | op_inc | op_dec | op_neg | op_not.
  Variant opcode_2_0  := op_cmp  | op_test.
  Variant opcode_2_1  := op_add  | op_sub | op_xor | op_or  | op_and.
  Variant opcode_2_2  := op_imul | op_xchg.
  Variant opcode_cond := op_jz   | op_jnz | op_js  | op_jns | op_jg | op_jge | op_jl | op_jle.

  Local Notation the_src  := (source Cell Annot).
  Local Notation the_dst  := (destination Cell Annot).

  Variant instruction (labels : list Label) :=
    | instr_nop  of                                                            { l | In l labels }
    | instr_hlt
    | instr_1_1  of opcode_1_1  & the_dst           & the_src           &      { l | In l labels }
    | instr_2_0  of opcode_2_0                      & the_src & the_src &      { l | In l labels }
    | instr_2_1  of opcode_2_1  & the_dst           & the_src & the_src &      { l | In l labels }
    | instr_2_2  of opcode_2_2  & the_dst & the_dst & the_src & the_src &      { l | In l labels }
    | instr_push of                         Cell    & Cell    & the_src &      { l | In l labels }
    | instr_pop  of               the_dst & Cell    & Cell              &      { l | In l labels }
    | instr_jmp  of                                   the_src           & list { l | In l labels }
    | instr_cjmp of opcode_cond                     & the_src           & list { l | In l labels } & { l | In l labels }
    | instr_call of                         Cell    & Cell    & the_src & list { l | In l labels } & { l | In l labels }
    | instr_ret  of                         Cell    & Cell    &           list { l | In l labels }
  .

  Definition instr_next {labels} (i : instruction labels) : list { l | In l labels } :=
    match i with
    | instr_nop            next        => [next]
    | instr_hlt                        => []
    | instr_1_1  _ _   _   next        => [next]
    | instr_2_0  _ _ _     next        => [next]
    | instr_2_1  _ _ _ _   next        => [next]
    | instr_2_2  _ _ _ _ _ next        => [next]
    | instr_push     _ _ _ next        => [next]
    | instr_pop    _ _ _   next        => [next]
    | instr_jmp        _   next        =>  next
    | instr_cjmp _     _   target next =>  next::target
    | instr_call   _ _ _   next ret    =>  ret::next
    | instr_ret      _ _   next        =>  next
    end.

  Record phi_instruction :=
    { phi_srcs : list Cell
    ; phi_dst  : Cell
    }.

  Definition phi_block := list phi_instruction.

  Definition code    (labels : list Label) := forall l, In l labels -> instruction labels.
  Definition phicode (labels : list Label) := forall l, In l labels -> phi_block.

  Record program :=
    { prog_nodes   : list Label
    ; prog_entry   : Label
    ; prog_code    : code prog_nodes
    ; prog_phicode : phicode prog_nodes
    }.

  Definition prog_nodes_instrs {p} (ns : list Label) (H : forall n, In n ns -> In n (prog_nodes p)) : list (instruction (prog_nodes p)).
    destruct p as [nodes entry code phicode] ; simpl in *.
    induction ns as [|hd tl rec].
    - exact nil.
    - apply cons.
      + apply (code hd). apply H. now left.
      + apply rec ; intros n Hn. apply H. now right.
  Defined.

  Definition prog_instrs p : list (instruction (prog_nodes p)) :=
    prog_nodes_instrs (prog_nodes p) (fun _ H => H).

  Record wf_phi (p : phi_block) : Prop :=
    { wf_phi_n : exists n, forall i, In i p -> length (phi_srcs i) = n
    }.

  Record wf_prog (p : program) : Prop :=
    { wf_prog_entry : In (prog_entry p) (prog_nodes p)
    }.

  Definition node (p : program) := { n | In n (prog_nodes p) }.

  Definition prog_nodes_nodes {p} (ns : list Label) (H : forall n, In n ns -> In  n (prog_nodes p)) : list (node p).
    unfold node.
    destruct p as [nodes entry code phicode] ; simpl in *.
    induction ns as [|hd tl rec].
    - exact nil.
    - apply cons.
      + exists hd. apply H. now left.
      + apply rec ; intros n Hn. apply H. now right.
  Defined.

  Definition prog_nodes' p : list (node p) :=
    prog_nodes_nodes (prog_nodes p) (fun _ H => H).

  Definition instr {p} (n : node p) : instruction (prog_nodes p) :=
    prog_code p (proj1_sig n) (proj2_sig n).

  Definition phi {p} (n : node p) : phi_block :=
    prog_phicode p (proj1_sig n) (proj2_sig n).

  Definition succs {p} (n : node p) : list (node p) :=
    instr_next (prog_code p (proj1_sig n) (proj2_sig n)).

  Definition is_pred {_ : EqDec Label} {p} (pred succ : node p) : bool :=
    List.existsb (fun s => eqb (proj1_sig succ) (proj1_sig s)) (instr_next (instr pred)).

  Definition preds {_ : EqDec Label} {p} (succ : node p) : list (node p) :=
    List.filter (fun pred => is_pred pred succ) (prog_nodes' p).

  Definition is_nth_predb {_ : EqDec Label} {p} (pred succ : node p) (n : nat) : bool :=
    if List.nth_error (preds succ) n is Some pred' then eqb (proj1_sig pred) (proj1_sig pred') else false.

  Definition is_nth_pred {_ : EqDec Label} {p} (pred succ : node p) (n : nat) : Prop :=
    if is_nth_predb pred succ n then True else False.

End GRAPH.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 Term Preservation Proof

*)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Require Export Cyclone_Dynamic_Semantics.
Require Export Cyclone_Classes Cyclone_Inductions Cyclone_LN_Tactics Cyclone_LN_Extra_Lemmas_And_Automation.
Require Export Cyclone_WFC_Lemmas.
Require Export Cyclone_WFU_Lemmas.
Require Export Cyclone_Context_Weakening_Proof.
Require Export Cyclone_Substitutions_Proof.
Require Export Cyclone_LN_Types_Lemmas.
Require Export Cyclone_Get_Lemmas.
Require Export Cyclone_Admit_Environment.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

(* This has serious problems because dynamic semantics, D', is always in
terms of statements but typing relations are in terms of St, E, ... *)
Function A_13_Term_Preservation_prop (In : Type) (H : TypJudgement In)
         (u : Upsilon) (g : Gamma) (s : In) (t : Tau)
         (st : typ' empty u g s t) :=
  forall u g h,
    htyp u g h g ->
    refp h u ->
      forall h', (* s',
         D' h s h' s' -> *)
        exists g' u',
          extends g g' ->
          LVPE.extends u u' ->
          htyp u' g' h' g' /\
          refp h' u' /\
          typ' empty u' g' s(*'*) t.
Hint Unfold A_13_Term_Preservation_prop.
Check A_13_Term_Preservation_prop.

Function PL (h : Heap) (s : St) (h' : Heap) (s' : St) (_ : L h s h' s') :=
  forall u g h,
    htyp u g h g ->
    refp h u ->
    forall t,
      ltyp empty u g s t ->
    exists g' u',
      extends g g' ->
      LVPE.extends u u' ->
      htyp u' g' h' g' /\
      refp h' u' /\
      ltyp empty u' g' s' t.
Hint Unfold PL.

Function PR (d : Delta) (u: Upsilon) (g : Gamma) (e: E) (t : Tau) (_ : rtyp d u g e t) :=
  forall u g h,
    htyp u g h g ->
    refp h u ->
      forall h' e',
        R h (e_s e) h' e' ->
        exists g' u',
          extends g g' ->
          LVPE.extends u u' ->
          htyp u' g' h' g' /\
          refp h' u' /\
          rtyp empty u' g' e t.
Hint Unfold PR.

Function PS (d : Delta) (u: Upsilon) (g : Gamma) (s: St) (t : Tau) (_ : styp d u g s t) :=
  forall u g h,
    htyp u g h g ->
    refp h u ->
      forall h' s',
        S h s h' s' ->
        exists g' u',
          extends g g' ->
          LVPE.extends u u' ->
          htyp u' g' h' g' /\
          refp h' u' /\
          styp empty u' g' s t.
Hint Unfold PS.

Lemma A_13_Term_Preservation_1:
  forall (d : Delta) (u: Upsilon) (g : Gamma) (e: E) (t : Tau),
    d = empty ->
    forall (typ : ltyp d u g e t),
      PL typ.
Proof.
  introv DE.
  unfold PL.
  (* wrong! on S not ltyp! *)
  apply (ltyp_ind_mutual PS PL PR); autounfold in *; intros; subst.
  apply(SRL_ind_mutual
          (fun (h : Heap) (s : St) (h' : Heap) (s' : St) (_ : S h s h' s') =>
             f h s h' s')
          (fun (h : Heap) (s : St) (h' : Heap) (s' : St) (_ : R h s h' s') =>
             f h s h' s')
          (fun (h : Heap) (s : St) (h' : Heap) (s' : St) (_ : L h s h' s') =>
             f h s h' s')); intros.

Lemma A_13_Term_Preservation_2:
  forall u g h,
    htyp u g h g ->
    refp h u ->
    forall e t,
      rtyp empty u g e t ->
      forall h' e',
        R h (e_s e) h' e' ->
        exists g' u',
          extends g g' ->
          LVPE.extends u u' ->
          htyp u' g' h' g' /\
          refp h' u' /\
          rtyp empty u' g' e t.
Admitted.

Lemma A_13_Term_Preservation_3:
  forall u g h,
    htyp u g h g ->
    refp h u ->
    forall e t,
      styp empty u g e t ->
      forall h' e',
        S h e h' e' ->
        exists g' u',
          extends g g' ->
          LVPE.extends u u' ->
          htyp u' g' h' g' /\
          refp h' u' /\
          styp empty u' g' e t.
Admitted.


Require Import DataTypes Useful Channel Cache Compatible L1 Coq.Logic.Classical
Coq.Relations.Operators_Properties Coq.Relations.Relation_Operators List MsiState L1.
(*Require List.*)

Module Type LatestValueAxioms (dt: DataTypes) (ch: ChannelPerAddr dt).
  Import dt ch.

  Axiom toChild: forall {n a t p m}, defined n -> defined p ->
                   parent n p ->
                   mark mch p n a t m -> from m = MsiState.In -> dataM m = data p a t.
  Axiom fromParent: forall {n a t p m}, defined n -> defined p ->
                      parent n p ->
                      recv mch p n a t m -> from m = MsiState.In -> data n a (S t) = dataM m.
  Axiom toParent: forall {n a t c m}, defined n -> defined c ->
                     parent c n ->
                     mark mch c n a t m -> slt Sh (from m) -> dataM m = data c a t.
  Axiom fromChild: forall {n a t c m}, defined n -> defined c ->
                     parent c n ->
                     recv mch c n a t m -> slt Sh (from m) -> data n a (S t) = dataM m.

  Axiom initLatest: forall a, data hier a 0 = initData a /\ state hier a 0 = Mo.

  Axiom deqImpData: forall {a n t i}, defined n -> deqR a n i t ->
                                    desc (reqFn a n i) = St ->
                                    data n a (S t) = dataQ (reqFn a n i).

  Axiom changeData:
    forall {n a t}, defined n ->
      data n a (S t) <> data n a t ->
      (exists m, (exists p, defined p /\ parent n p /\ recv mch p n a t m /\ from m = MsiState.In) \/
                 (exists c, defined c /\ parent c n /\ recv mch c n a t m /\
                            slt Sh (from m))) \/
      exists i, deqR a n i t /\ desc (reqFn a n i) = St.

  Axiom deqImpNoSend: forall {c a i t}, defined c -> deqR a c i t ->
                                      forall {m p}, defined p ->
                                                    ~ mark mch c p a t m.
End LatestValueAxioms.

Module LatestValueTheorems (dt: DataTypes) (ch: ChannelPerAddr dt) (c: BehaviorAxioms dt ch)
       (l1: L1Axioms dt) (comp: CompatBehavior dt ch) (lv: LatestValueAxioms dt ch): L1Theorems dt l1.
  Module mbt := mkBehaviorTheorems dt ch c.
  Module cbt := mkCompat dt ch comp c.
  Import dt ch c l1 comp lv mbt cbt.

  Theorem uniqM:
    forall {c a t}, defined c ->
      leaf c ->
      state c a t = Mo -> forall {co}, defined co -> leaf co -> c <> co -> state co a t = MsiState.In.
  Proof.
    intros c a t defC leaf_c cM co defCo leaf_co c_ne_co.
    pose proof (noLeafsDesc leaf_c leaf_co c_ne_co) as desc1.
    assert (co_ne_c: co <> c) by auto.
    pose proof (noLeafsDesc leaf_co leaf_c co_ne_c) as desc2.
    pose proof (@nonDescCompat c co defC defCo desc1 desc2 a t) as st.
    rewrite cM in st.
    unfold sle in *; destruct (state co a t); firstorder.
  Qed.

  Theorem parentLeafFalse: forall {c p}, leaf c -> parent p c -> False.
  Proof.
    intros c p leafC p_c.
    unfold leaf in *; unfold parent in *.
    destruct c.
    destruct l0.
    unfold List.In in *.
    assumption.
    assumption.
  Qed.

  Theorem leafGood: forall {p n a t}, defined p -> defined n -> parent n p ->
                                      slt MsiState.In (dir p n a t) -> slt (state n a t) Mo ->
                                      forall {c i},
                                        defined c ->
                                        deqR a c i t -> desc (reqFn a c i) = St ->
                                        False.
  Proof.
    unfold not; intros p n a t defP defN n_p pGtI nLtM c i defC deqSt isSt.
    pose proof (deqLeaf deqSt) as leafC.
    pose proof (processDeq deqSt) as st; simpl in st.
    destruct (classic (descendent c p)) as [c_p | c_ne_p].
    destruct (classic (descendent c n)) as [c_n | c_ne_n].
    pose proof (@descSle c n defC defN c_n a t) as low.
    rewrite isSt in st.
    rewrite st in low.
    apply (slt_slei_false nLtM low).
    pose proof (clos_rt_rtn1 Tree parent c p c_p) as trans.
    destruct trans.
    apply (parentLeafFalse leafC n_p).
    pose proof (clos_rtn1_rt Tree parent c y trans) as c_y.
    pose proof (rt_step Tree parent y z H) as y_z.
    pose proof (rt_trans Tree parent y z hier y_z defP) as defY.
    clear trans y_z; fold descendent in *.
    assert (y_ne_n: n = y -> False).
    intros y_eq_n.
    rewrite y_eq_n in *.
    firstorder.
    pose proof (compatible defP a t defY H) as [_ good].
    specialize (good n defN y_ne_n n_p).
    pose proof (@descSle c y defC defY c_y a t) as low.
    rewrite isSt in st.
    rewrite st in low.
    pose proof (conservative defP defY H a t) as stuff.
    unfold sle in *; destruct (dir z y a t); destruct (dir z n a t);
    destruct (state y a t); auto.
    assert (sec: ~ descendent p c).
    unfold not; intros p_c.
    pose proof (clos_rt_rtn1 Tree parent p c p_c) as trans.
    destruct trans.
    firstorder.
    apply (parentLeafFalse leafC H).
    pose proof (@nonDescCompat c p defC defP c_ne_p sec a t) as contra.
    rewrite isSt in st.
    rewrite st in contra.
    pose proof (compatible defP a t defN n_p) as [good _].
    destruct (dir p n a t); destruct (state p a t); unfold slt in *; unfold sle in *;
    auto.
  Qed.

  Theorem leafGood2: forall {p n a t}, defined p -> defined n -> parent n p ->
                                       forall {m}, mark mch p n a t m ->
                                                   forall {c i},
                                                     defined c ->
                                                     deqR a c i t -> desc (reqFn a c i) = St ->
                                                     False.
  Proof.
    unfold not; intros p n a t defP defN n_p m markm c i defC deqSt isSt.
    pose proof (pSendUpgrade defP defN n_p markm) as dir_n_lt_M.
    pose proof (sendCCond defP defN n_p markm) as [st_hg othersCompat].
    pose proof (sendmChange (dt defP defN n_p) markm) as rew.
    rewrite <- rew in *; clear rew.
    pose proof (deqLeaf deqSt) as leafC.
    pose proof (processDeq deqSt) as st; simpl in st.
    destruct (classic (descendent c p)) as [c_p | c_ne_p].
    destruct (classic (descendent c n)) as [c_n | c_ne_n].
    pose proof (@descSle c n defC defN c_n a t) as low.
    pose proof (conservative defP defN n_p a t) as sth.
    rewrite isSt in st.
    rewrite st in *.
    destruct (state n a t); destruct (dir p n a t); destruct (dir p n a (S t));
    unfold sle in *; unfold slt in *; auto.
    pose proof (clos_rt_rtn1 Tree parent c p c_p) as trans.
    destruct trans.
    apply (parentLeafFalse leafC n_p).
    pose proof (clos_rtn1_rt Tree parent c y trans) as c_y.
    pose proof (rt_step Tree parent y z H) as y_z.
    pose proof (rt_trans Tree parent y z hier y_z defP) as defY.
    clear trans y_z; fold descendent in *.
    assert (y_ne_n: y = n -> False).
    intros y_eq_n.
    rewrite y_eq_n in *.
    firstorder.
    specialize (othersCompat y defY y_ne_n H).
    pose proof (@descSle c y defC defY c_y a t) as low.
    pose proof (conservative defP defY H a t) as stuff.
    rewrite isSt in st.
    rewrite st in *.
    unfold sle in *; unfold slt in *; destruct (dir z n a (S t)); destruct (dir z n a t);
    destruct (dir z y a t); destruct (state y a t); auto.
    assert (sec: ~ descendent p c).
    unfold not; intros p_c.
    pose proof (clos_rt_rtn1 Tree parent p c p_c) as trans.
    destruct trans.
    firstorder.
    apply (parentLeafFalse leafC H).
    pose proof (@nonDescCompat c p defC defP c_ne_p sec a t) as contra.
    rewrite isSt in st.
    rewrite st in contra.
    unfold sle in *; unfold slt in *; destruct (dir p n a t); destruct (dir p n a (S t));
    destruct (state p a t); auto.
  Qed.

  Theorem leafGood3: forall {p n a t}, defined p -> defined n -> parent n p ->
                                       forall {m}, mark mch n p a t m ->
                                                   forall {c i},
                                                     defined c ->
                                                     deqR a c i t -> desc (reqFn a c i) = St ->
                                                     False.
  Proof.
    unfold not; intros p n a t defP defN n_p m markm c i defC deqSt isSt.
    destruct (classic (c = n)) as [eq|notEq].
    rewrite eq in *.
    apply (deqImpNoSend defN deqSt defP markm).
    destruct (classic (descendent c n)) as [c_n | c_no_n].
    pose proof (@sendPCond n a t p defN defP n_p m markm) as dirLower.
    pose proof (allDirLower defN dirLower notEq c_n) as condToM.
    pose proof (cSendDowngrade defP defN n_p markm) as dgd.
    pose proof (sendmChange (st defP defN n_p) markm) as stEq.
    rewrite stEq in dgd.
    pose proof (processDeq deqSt) as eqSth; simpl in *.
    rewrite isSt in eqSth.
    rewrite eqSth in *.
    destruct (state n a t); destruct (to m); unfold slt in *; unfold sle in *; auto.
    assert (n_no_c: ~ descendent n c).
    unfold not; intros n_c.
    pose proof (clos_rt_rtn1 Tree parent n c n_c) as trans.
    destruct trans.
    assert (n = n) by reflexivity; firstorder.
    pose proof (deqLeaf deqSt) as leaf_z.
    unfold parent in *; unfold leaf in *. destruct z. destruct l0.
    unfold List.In in H. assumption.
    assumption.
    pose proof (@nonDescCompat n c defN defC n_no_c c_no_n a t) as stNow.
    pose proof (cSendDowngrade defP defN n_p markm) as dgd.
    pose proof (processDeq deqSt) as eqSth; simpl in *;
    rewrite isSt in eqSth.
    rewrite eqSth in *.
    unfold sle in *; unfold slt in *; destruct (state n a t); destruct (state n a (S t));
    auto.
  Qed.

  Theorem allLatestValue:
    forall {a t n}, defined n ->
                    sle Sh (state n a t) ->
                    (forall {c}, defined c -> parent c n -> sle (dir n c a t) Sh) ->
                    (data n a t = initData a /\
                     forall {ti}, 0 <= ti < t ->
                                  forall {ci ii}, defined ci ->
                                                  ~ (deqR a ci ii ti /\
                                                     desc (reqFn a ci ii) = St)) \/
    (exists cb ib tb, defined cb /\ tb < t /\ deqR a cb ib tb /\ desc (reqFn a cb ib) = St /\
                      data n a t = dataQ (reqFn a cb ib) /\
                      forall {ti}, tb < ti < t ->
                                   forall {ci ii},
                                     defined ci ->
                                     ~ (deqR a ci ii ti /\
                                        desc (reqFn a ci ii) = St)
    ).
    Proof.
      intros a.
      pose (fun t => forall n,
              defined n ->
                    sle Sh (state n a t) ->
                    (forall {c}, defined c -> parent c n -> sle (dir n c a t) Sh) ->
                    (data n a t = initData a /\
                     forall {ti}, 0 <= ti < t ->
                                  forall {ci ii}, defined ci ->
                                                  ~ (deqR a ci ii ti /\
                                                     desc (reqFn a ci ii) = St)) \/
    (exists cb ib tb, defined cb /\ tb < t /\ deqR a cb ib tb /\ desc (reqFn a cb ib) = St /\
                      data n a t = dataQ (reqFn a cb ib) /\
                      forall {ti}, tb < ti < t ->
                                   forall {ci ii},
                                     defined ci ->
                                     ~ (deqR a ci ii ti /\
                                        desc (reqFn a ci ii) = St)
           )) as P.
      pose proof (initLatest a) as [hierInit hierM].
      apply (@ind P).
      unfold P in *; clear P.
      intros n defN stCond dirCond.
      destruct (classic (n = hier)) as [eq|notEq].
      rewrite eq.
      rewrite hierInit.
      constructor. constructor. reflexivity.
      intros ti [_ bad].
      assert (f: False) by omega.
      firstorder.
      pose proof (rt_refl Tree parent hier) as defHier.
      pose proof (@initCompat hier) as dir0.
      pose proof (clos_rt_rtn1 Tree parent n hier defN) as trans.
      pose proof @conservative as cons.
      pose proof @descSle as descSle.
      unfold defined in *.
      destruct trans.
      firstorder.
      pose proof (clos_rtn1_rt Tree parent n y trans) as n_y.
      pose proof (rt_step Tree parent y z H) as defY.
      clear dirCond trans; fold descendent in *.
      specialize (dir0 y defHier defY H a).
      pose proof (cons z y defHier defY H a 0) as sleUse.
      pose proof @descSle n y defN defY n_y a 0 as contra.
      rewrite dir0 in sleUse.
      unfold sle in *; destruct (state n a 0); destruct (state y a 0); firstorder.

      unfold P in *; clear P.
      intros t SIHt n defN condSt condDir.

      destruct (classic (sle Sh (state n a t) /\
                         forall c, defined c -> parent c n -> sle (dir n c a t) Sh))
               as [[condSt' condDir']|prevNotLatest].

      assert (triv: t <= t) by omega.
      specialize (SIHt t triv n defN condSt' condDir'); clear triv.

      assert (noneElse: forall co, defined co -> leaf co -> co <> n -> sle (state co a t) Sh).
      intros co defCo leafco co_ne_n.
      destruct (classic (descendent co n)) as [desc|noDesc].
      apply (allDirLower defN condDir' co_ne_n desc).

      assert (not_n_co: ~ descendent n co).
      unfold not; intros n_co.
      assert (no_co_parent: forall p, ~ parent p co) by
          (unfold not; intros p p_co; unfold leaf in *; unfold parent in *;
                                      unfold List.In in *; destruct co; destruct l0; auto).
      pose proof (clos_rt_rtn1 Tree parent n co n_co) as trans.
      destruct trans.
      assert (n = n) by reflexivity; firstorder.
      firstorder.

      pose proof (@nonDescCompat n co defN defCo not_n_co noDesc a t) as condState.
      destruct (state n a t); unfold sle in *; destruct (state co a t); auto.

      assert (noStore: forall co, defined co ->
                                  co <> n -> forall i,
                                               ~ (deqR a co i t /\
                                                  desc (reqFn a co i) = St
             )).
      unfold not; intros co defCo co_ne_n i [deqSt isSt].
      pose proof (deqLeaf deqSt) as leafCo.
      specialize (noneElse co defCo leafCo co_ne_n).
      pose proof (processDeq deqSt) as use; simpl in use.
      rewrite isSt in use.
      rewrite use in noneElse; unfold sle in *; auto.

      destruct (classic (exists i, deqR a n i t /\
               desc (reqFn a n i) = St)) as [[i [deqSt isSt]] | noNStore].

      pose proof (deqImpData defN deqSt) as st.
      rewrite isSt in st.
      rewrite st.
      assert (triv: t < S t) by omega.
      assert (triv2: forall ti, t < ti < S t -> False) by (intros ti cond; omega).
      right.
      exists n; exists i; exists t.
      generalize defN triv deqSt isSt st triv2; clear; firstorder.
      reflexivity.

      assert (good: forall c i, defined c ->
                                ~ (deqR a c i t /\
                                   desc (reqFn a c i) = St)).
      unfold not. intros c i defC [deqc isSt].
      destruct (classic (c = n)) as [eq|notEq].
      rewrite eq in *; generalize noNStore deqc isSt; clear; firstorder.
      generalize noStore defC notEq deqc isSt; clear; firstorder.

      destruct (classic (data n a (S t) = data n a t)) as [dataEq| dataNeq].
      rewrite dataEq.

      destruct SIHt as [[initi condInit]|[resti condResti]].
      left.
      constructor. assumption.
      intros ti cond.
      assert (cases: 0 <= ti < t \/ ti = t) by omega.
      destruct cases as [ind|rew].
      specialize (condInit ti ind).
      assumption.
      rewrite rew.
      assumption.

      destruct condResti as [ib [tb [defCb [tb_lt_t [deqSt [isSt [dEq rest]]]]]]].
      right.
      exists resti; exists ib; exists tb.
      constructor. assumption.
      constructor.
      omega.
      constructor.
      assumption.
      constructor.
      assumption.
      constructor.
      assumption.
      intros ti cond.
      assert (cases: tb < ti < t \/ ti = t) by omega.
      destruct cases as [ind|rew].

      apply (rest ti ind).
      rewrite rew.
      assumption.

      pose proof (changeData defN dataNeq) as someChange.
      destruct someChange as [[m [[p [defP [n_p [recvm mIn]]]] |
                                  [c [defC [c_n [recvm mNotIn]]]]]] | bad].

      pose proof (cRecvmCond defP defN n_p recvm) as currSt.
      rewrite <- currSt in condSt'; rewrite mIn in condSt'.
      unfold sle in condSt'; firstorder.

      pose proof (recvmCond defN defC c_n recvm) as currSt.
      specialize (condDir' c defC c_n).
      rewrite currSt in mNotIn.
      pose proof (slt_slei_false mNotIn condDir') as f.
      firstorder.

      generalize noNStore bad; clear; firstorder.

      destruct (classic (state n a t = MsiState.In \/ exists c, defined c /\ parent c n /\
                                                       slt Sh (dir n c a t)))
               as [hard | easy].
      clear prevNotLatest.

      destruct hard as [stIn | [c [defC [c_n dirM]]]].

      assert (lt: slt (state n a t) (state n a (S t))) by
          (rewrite stIn; unfold sle in *; unfold slt in *; destruct (state n a (S t));
           auto).
      assert (chnge: state n a (S t) <> state n a t) by
          (destruct (state n a (S t)); destruct (state n a t); unfold slt in *;
                                                               unfold sle in *;
                                                               auto; discriminate).
      destruct (classic (exists p, defined p /\ parent n p)) as [[p [defP n_p]] | noP].
      pose proof (change (st defP defN n_p) chnge) as [[m markm] | [m recvm]].
      pose proof (cSendDowngrade defP defN n_p markm) as contra.
      pose proof (slt_slti_false lt contra) as f.
      firstorder.

      pose proof (recvImpMark recvm) as [ts [ts_le_t markm]].
      pose proof (@pSendNonI p n defP defN n_p m ts t a markm recvm) as pHigh.
      pose proof (@cRecvNonM p n defP defN n_p m ts t a markm recvm) as cLow.
      assert (cLow1: forall t0, ts < t0 <= t -> slt (state n a t0) Mo) by
          ( intros t0 cond; assert (H: ts <= t0 <= t) by omega; apply (cLow t0 H)).
      assert (cLow2: slt (state n a ts) Mo) by (assert (H: ts <= ts <= t) by omega;
                                                apply (cLow ts H)).

      assert (noDeq1: forall t0, ts < t0 <= t ->
                                 forall c i, defined c -> ~ (deqR a c i t0
                                                            /\
                                                            desc (reqFn a c i) = St)).
      intros t0 cond.
      specialize (pHigh t0 cond).
      specialize (cLow1 t0 cond).
      pose proof (@leafGood p n a t0 defP defN n_p pHigh cLow1) as H.
      generalize H; clear; firstorder.

      pose proof (@leafGood2 p n a ts defP defN n_p m markm) as noDeq2.

      assert (goodT: forall t0, ts <= t0 <= t ->
                                forall c i, defined c -> ~ (deqR a c i t0 /\
                                                            desc (reqFn a c i) = St)).
      intros t0 cond.
      assert (H: ts < t0 <= t \/ t0 = ts) by omega.
      destruct H as [c1|c2].
      apply (noDeq1 t0 c1).
      rewrite c2 in *.
      generalize noDeq2; clear; firstorder.

      pose proof (cRecvmCond defP defN n_p recvm) as stEq.
      rewrite <- stEq in stIn.
      pose proof (fromParent defN defP n_p recvm stIn) as dataEq.
      pose proof (toChild defN defP n_p markm stIn) as dataEq2.
      rewrite <- dataEq in dataEq2.
      rewrite dataEq2.

      pose proof (sendCCond defP defN n_p markm) as [one two].
      pose proof (pSendUpgrade defP defN n_p markm) as upg.
      pose proof (sendmChange (dt defP defN n_p) markm) as ch.
      rewrite ch in upg.
      assert (p1: sle Sh (state p a ts)) by
          ( unfold sle in *; unfold slt in *; destruct (to m); destruct (state p a ts);
            destruct (dir p n a ts); auto).
      assert (p2: forall c', defined c' -> parent c' p ->
                         sle (dir p c' a ts) Sh).
      intros c' defC' c'_p.

      destruct (classic (c' = n)) as [eq|not].
      pose proof (cRecvRespPrevState defP defN n_p recvm markm) as stDir.
      rewrite <- stEq in stDir.
      rewrite stIn in stDir.
      rewrite eq.
      rewrite <- stDir.
      unfold sle; auto.

      specialize (two c' defC' not c'_p).
      unfold sle in *; unfold slt in *; destruct (to m); destruct (dir p n a ts);
      destruct (dir p c' a ts); auto.

      specialize (SIHt ts ts_le_t p defP p1 p2).
      destruct (SIHt) as [[initi condInit] | [resti condRest]].
      left.
      constructor. assumption.

      intros ti cond; assert (H: 0 <= ti < ts \/ ts <= ti <= t ) by omega;
      destruct H as [ind|tough].

      apply (condInit ti ind).
      apply (goodT ti tough).

      right.
      destruct condRest as [ib [tb [defCb [tb_lt_ts [deqSt [isSt [dtEq rest]]]]]]].
      exists resti; exists ib; exists tb.
      constructor. assumption. constructor.
      assert (tb < S t) by omega. assumption.
      constructor. assumption.
      constructor. assumption.
      constructor. assumption.
      intros ti cond; assert (H: tb < ti < ts \/ ts <= ti <= t) by omega;
      destruct H as [ind|tough].
      apply (rest ti ind).
      apply (goodT ti tough).

      assert (contra: forall p, defined p -> ~ parent n p) by firstorder.
      specialize (@noParentSame n a t defN contra).
      firstorder.

      specialize (condDir c defC c_n).

      assert (gt: slt (dir n c a (S t)) (dir n c a t)) by
          (unfold slt in *; unfold sle in *; destruct (dir n c a (S t));
           destruct (dir n c a t); auto; discriminate).
      assert (chnge: dir n c a (S t) <> dir n c a t) by
          (destruct (dir n c a (S t)); destruct (dir n c a t); unfold slt in *;
                                                               unfold sle in *;
                                                               auto; discriminate).

      pose proof (change (dt defN defC c_n) chnge) as [[m markm] | [m recvm]].
      pose proof (pSendUpgrade defN defC c_n markm) as contra.
      pose proof (slt_slti_false gt contra) as f.
      firstorder.

      pose proof (recvImpMark recvm) as [ts [ts_le_t markm]].
      pose proof (@pRecvNonI n c defN defC c_n m ts t a markm recvm) as pHigh.
      pose proof (@cSendNonM n c defN defC c_n m ts t a markm recvm) as cLow.
      assert (pHigh1: forall t0, ts < t0 <= t -> slt MsiState.In (dir n c a t0)) by
          ( intros t0 cond; assert (H: ts <= t0 <= t) by omega; apply (pHigh t0 H)).
      assert (pHigh2: slt MsiState.In (dir n c a ts)) by (assert (H: ts <= ts <= t) by omega;
                                                apply (pHigh ts H)).

      assert (noDeq1: forall t0, ts < t0 <= t ->
                                 forall c i, defined c -> ~ (deqR a c i t0 /\
                                                             desc (reqFn a c i) = St)).
      intros t0 cond.
      specialize (cLow t0 cond).
      specialize (pHigh1 t0 cond).
      pose proof (@leafGood n c a t0 defN defC c_n pHigh1 cLow) as H.
      generalize H; clear; firstorder.

      pose proof (@leafGood3 n c a ts defN defC c_n m markm) as noDeq2.

      assert (goodT: forall t0, ts <= t0 <= t ->
                                forall c i, defined c -> ~ (deqR a c i t0 /\
                                                            desc (reqFn a c i) = St)).
      intros t0 cond.
      assert (H: ts < t0 <= t \/ t0 = ts) by omega.
      destruct H as [c1|c2].
      apply (noDeq1 t0 c1).
      rewrite c2 in *.
      generalize noDeq2; clear; firstorder.

      pose proof (recvmCond defN defC c_n recvm) as stEq.
      rewrite <- stEq in dirM.
      pose proof (fromChild defN defC c_n recvm dirM) as dataEq.
      pose proof (toParent defN defC c_n markm dirM) as dataEq2.
      rewrite <- dataEq in dataEq2.
      rewrite dataEq2.

      pose proof (@sendPCond c a ts n defC defN c_n m markm) as sth.
      pose proof (recvmChange (dt defN defC c_n) recvm) as ch.
      rewrite ch in condDir.
      pose proof (cSendDowngrade defN defC c_n markm) as dwn.

      assert (p2: forall c0, defined c0 -> parent c0 c -> sle (dir c c0 a ts) Sh).
      intros c0 defC0 c0_c; specialize (sth c0 defC0 c0_c);
      destruct (to m); destruct (dir c c0 a ts); unfold sle in *; unfold slt in *;
      auto.

      assert (p1: sle Sh (state c a ts)) by
          ( unfold sle in *; unfold slt in *; destruct (state c a (S ts));
            destruct (state c a ts); auto).

      specialize (SIHt ts ts_le_t c defC p1 p2).

      destruct SIHt as [[initi condInit] | [resti condRest]].
      left.
      constructor. assumption.
      intros ti cond; assert (H: 0 <= ti < ts \/ ts <= ti <= t ) by omega;
      destruct H as [ind|tough].

      apply (condInit ti ind).
      apply (goodT ti tough).

      right.
      destruct condRest as [ib [tb [defCb [tb_lt_ts [deqSt [isSt [dtEq rest]]]]]]].
      exists resti; exists ib; exists tb.
      constructor. assumption. constructor.
      assert (tb < S t) by omega. assumption.
      constructor. assumption.
      constructor. assumption.
      constructor. assumption.
      intros ti cond; assert (H: tb < ti < ts \/ ts <= ti <= t) by omega;
     destruct H as [ind|tough].
      apply (rest ti ind).
      apply (goodT ti tough).

      assert (ex: forall c, defined c -> parent c n -> ~ slt Sh (dir n c a t)) by
          firstorder.
      assert (ex': forall c, defined c -> parent c n -> sle (dir n c a t) Sh) by
          ( intros c defC c_n; unfold sle in *; specialize (ex c defC c_n);
            unfold slt in *; destruct (dir n c a t); auto).
      assert (ex2: state n a t <> MsiState.In) by firstorder.
      assert (ex2': sle Sh (state n a t)) by (destruct (state n a t); unfold sle in *;
                                                                      auto).
      firstorder.

    Qed.

  Theorem latestValue:
  forall {c a t},
    defined c ->
    leaf c ->
    sle Sh (state c a t) ->
    (data c a t = initData a /\
     forall {ti}, 0 <= ti < t -> forall {ci ii},
                                   defined ci ->
                                   ~ (deqR a ci ii ti /\
                                      desc (reqFn a ci ii) = St)) \/
    (exists cb ib tb, defined cb /\ tb < t /\ deqR a cb ib tb /\ desc (reqFn a cb ib) = St /\
                      data c a t = dataQ (reqFn a cb ib) /\
                      forall {ti}, tb < ti < t ->
                                   forall {ci ii},
                                     defined ci ->
                                     ~ (deqR a ci ii ti /\
                                        desc (reqFn a ci ii) = St)
    ).
  Proof.
    intros c a t cDef leafC more.
    assert (cond: forall {c'}, defined c' -> parent c' c -> sle (dir c c' a t) Sh).
    intros c' defC' c'_c; unfold leaf in *; unfold parent in *.
    destruct c.
    destruct l0.
    unfold List.In in *.
    firstorder.
    firstorder.
    pose proof (allLatestValue cDef more cond) as useful.
    assumption.
  Qed.

  Definition deqOrNot := l1.deqOrNot.
End LatestValueTheorems.