Require Import Omega.
Require Import Bool.
Require Import RelationClasses.

Require Import sflib.
From Paco Require Import paco.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import DenseOrder.
Require Import Language.
Require Import Loc.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Trace.
Require Import Behavior.
Require Import Single.
Require Import Mapping.

Set Implicit Arguments.

Module SemiReachable.
  Section REACHABLE.

    Variable (c0: Configuration.t).

    Hypothesis CONFIG_CONSISTENT: forall tid lang st lc
                                         (TID: IdentMap.find tid (Configuration.threads c0) = Some (existT _ lang st, lc)),
        Local.promise_consistent lc.
    Hypothesis CONFIG_WF: Configuration.wf c0.

    Section TID.

      Variable (tid: Ident.t).

      Inductive semi_reachable lang (th: Thread.t lang): Prop :=
      | semi_reachable_intro
          c1 st1 lc1
          (STEPS: rtc SConfiguration.all_machine_step c0 c1)
          (TID: IdentMap.find tid (Configuration.threads c1) = Some (existT _ lang st1, lc1))
          (TSTEPS: rtc (@Thread.all_step _) (Thread.mk _ st1 lc1 (Configuration.sc c1) (Configuration.memory c1)) th)
          (CONSISTENT: Local.promise_consistent (Thread.local th))
      .
      Hint Constructors semi_reachable.

      Inductive semi_reachable_state
                (lang: language) (st: @Language.state _ lang): Prop :=
      | semi_reachable_stateintro
          lc sc mem
          (REACHABLE: semi_reachable (Thread.mk _ st lc sc mem))
        :
          semi_reachable_state _ st
      .
      Hint Constructors semi_reachable_state.

      Inductive step lang: forall (pf: bool) (e: ThreadEvent.t) (th0 th1: Thread.t lang), Prop :=
      | step_intro
          pf e th0 th1
          (STEP: Thread.step pf e th0 th1)
          (REACHABLE: semi_reachable_state lang (Thread.state th1))
        :
          step pf e th0 th1
      .
      Hint Constructors step.

      Inductive opt_step lang: forall (e:ThreadEvent.t) (e1 e2:Thread.t lang), Prop :=
      | step_none
          e:
          opt_step ThreadEvent.silent e e
      | step_some
          pf e e1 e2
          (STEP: step pf e e1 e2):
          opt_step e e1 e2
      .
      Hint Constructors opt_step.

      Inductive step_allpf lang (e:ThreadEvent.t) (e1 e2:Thread.t lang): Prop :=
      | step_nopf_intro
          pf
          (STEP: step pf e e1 e2)
      .
      Hint Constructors step_allpf.

      Definition tau_step lang := tau (@step_allpf lang).

      Inductive reserve_step lang (e1 e2:Thread.t lang): Prop :=
      | reserve_step_intro
          pf loc from to
          (STEP: step pf (ThreadEvent.promise loc from to Message.reserve Memory.op_kind_add) e1 e2)
      .
      Hint Constructors reserve_step.

      Inductive cancel_step lang (e1 e2:Thread.t lang): Prop :=
      | cancel_step_intro
          pf loc from to
          (STEP: step pf (ThreadEvent.promise loc from to Message.reserve Memory.op_kind_cancel) e1 e2)
      .
      Hint Constructors cancel_step.

      Lemma step_reachable lang pf e (th0 th1: Thread.t lang)
            (STEP: Thread.step pf e th0 th1)
            (CONSISTENT: Local.promise_consistent (Thread.local th1))
            (REACHABLE: semi_reachable th0)
        :
          (<<STEP: step pf e th0 th1>>) /\
          (<<REACHABLE: semi_reachable th1>>).
      Proof.
        inv REACHABLE.
        assert (REACHABLE0: semi_reachable th1).
        { econs; eauto. etrans; eauto. econs 2; [|refl]. econs; eauto. econs; eauto. }
        splits; auto. econs; eauto. destruct th1. econs; eauto.
      Qed.

      Lemma opt_step_reachable lang e (th0 th1: Thread.t lang)
            (STEP: Thread.opt_step e th0 th1)
            (CONSISTENT: Local.promise_consistent (Thread.local th1))
            (REACHABLE: semi_reachable th0)
        :
          (<<STEP: opt_step e th0 th1>>) /\
          (<<REACHABLE: semi_reachable th1>>).
      Proof.
        inv STEP.
        - splits; auto.
        - eapply step_reachable in STEP0; eauto. des. splits; eauto.
      Qed.

      Lemma tau_steps_reachable lang (th0 th1: Thread.t lang)
            (STEPS: rtc (@Thread.tau_step _) th0 th1)
            (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
            (MEMORY: Memory.closed (Thread.memory th0))
            (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
            (CONSISTENT: Local.promise_consistent (Thread.local th1))
            (REACHABLE: semi_reachable th0)
        :
          (<<STEP: rtc (@tau_step _) th0 th1>>) /\
          (<<REACHABLE: semi_reachable th1>>).
      Proof.
        revert LOCAL MEMORY SC CONSISTENT REACHABLE. induction STEPS; eauto. i.
        inv H. inv TSTEP. exploit Thread.step_future; eauto. i. des.
        hexploit PromiseConsistent.rtc_tau_step_promise_consistent; eauto. i.
        hexploit step_reachable; eauto. i. des.
        hexploit IHSTEPS; eauto. i. des. splits; eauto.
        econs; eauto. econs; eauto.
      Qed.

      Lemma reserve_steps_reachable lang (th0 th1: Thread.t lang)
            (STEPS: rtc (@Thread.reserve_step _) th0 th1)
            (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
            (MEMORY: Memory.closed (Thread.memory th0))
            (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
            (CONSISTENT: Local.promise_consistent (Thread.local th1))
            (REACHABLE: semi_reachable th0)
        :
          (<<STEP: rtc (@reserve_step _) th0 th1>>) /\
          (<<REACHABLE: semi_reachable th1>>).
      Proof.
        revert LOCAL MEMORY SC CONSISTENT REACHABLE. induction STEPS; eauto. i.
        inv H. exploit Thread.step_future; eauto. i. des.
        hexploit PromiseConsistent.rtc_reserve_step_promise_consistent; eauto. i.
        hexploit step_reachable; eauto. i. des.
        hexploit IHSTEPS; eauto. i. des. splits; eauto.
      Qed.

      Lemma cancel_steps_reachable lang (th0 th1: Thread.t lang)
            (STEPS: rtc (@Thread.cancel_step _) th0 th1)
            (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
            (MEMORY: Memory.closed (Thread.memory th0))
            (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
            (CONSISTENT: Local.promise_consistent (Thread.local th1))
            (REACHABLE: semi_reachable th0)
        :
          (<<STEP: rtc (@cancel_step _) th0 th1>>) /\
          (<<REACHABLE: semi_reachable th1>>).
      Proof.
        revert LOCAL MEMORY SC CONSISTENT REACHABLE. induction STEPS; eauto. i.
        inv H. exploit Thread.step_future; eauto. i. des.
        hexploit PromiseConsistent.rtc_cancel_step_promise_consistent; eauto. i.
        hexploit step_reachable; eauto. i. des.
        hexploit IHSTEPS; eauto. i. des. splits; eauto.
      Qed.

      Definition consistent lang (e1:Thread.t lang): Prop :=
        forall mem1 sc1
               (CAP: Memory.cap (Thread.memory e1) mem1)
               (SC_MAX: Memory.max_concrete_timemap mem1 sc1),
          (exists e2 e3,
              (<<STEPS: rtc (@tau_step lang) (Thread.mk _ (Thread.state e1) (Thread.local e1) sc1 mem1) e2>>) /\
              (<<FAILURE: step true ThreadEvent.failure e2 e3 >>)) \/
          (exists e2,
              (<<STEPS: rtc (@tau_step lang) (Thread.mk _ (Thread.state e1) (Thread.local e1) sc1 mem1) e2>>) /\
              (<<PROMISES: (Local.promises (Thread.local e2)) = Memory.bot>>))
      .

      Inductive configuration_step:
        forall (e:ThreadEvent.t) (tid:Ident.t) (c1 c2:Configuration.t), Prop :=
      | configuration_step_intro
          e tid c1 lang st1 lc1 e2 e3 st4 lc4 sc4 memory4
          (TID: IdentMap.find tid (Configuration.threads c1) = Some (existT _ lang st1, lc1))
          (CANCELS: rtc (@cancel_step _) (Thread.mk _ st1 lc1 (Configuration.sc c1) (Configuration.memory c1)) e2)
          (STEP: opt_step e e2 e3)
          (RESERVES: rtc (@reserve_step _) e3 (Thread.mk _ st4 lc4 sc4 memory4))
          (CONSISTENT: e <> ThreadEvent.failure -> consistent (Thread.mk _ st4 lc4 sc4 memory4)):
          configuration_step e tid c1 (Configuration.mk (IdentMap.add tid (existT _ _ st4, lc4) (Configuration.threads c1)) sc4 memory4)
      .
      Hint Constructors configuration_step.

      Lemma step_map_reachable lang pf e (th0 th1 fth0: Thread.t lang)
            (STEP: Thread.step pf e th0 th1)
            (THREAD: thread_map ident_map th0 fth0)
            (CONSISTENT: Local.promise_consistent (Thread.local th1))
            (REACHABLE: semi_reachable fth0)
            (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
            (MEMORY: Memory.closed (Thread.memory th0))
            (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
            (FLOCAL: Local.wf (Thread.local fth0) (Thread.memory fth0))
            (FMEMORY: Memory.closed (Thread.memory fth0))
            (FSC: Memory.closed_timemap (Thread.sc fth0) (Thread.memory fth0))
        :
          exists fpf fe fth1,
            (<<STEP: Thread.step fpf fe fth0 fth1>>) /\
            (<<EVENT: tevent_map ident_map fe e>>) /\
            (<<THREAD: thread_map ident_map th1 fth1>>) /\
            (<<REACHABLE: semi_reachable fth1>>) /\
            (<<STEP: step pf e th0 th1>>)
      .
      Proof.
        splits; auto.
        inv THREAD. destruct th1. ss. hexploit step_map; ss.
        { eapply ident_map_le. }
        { eapply ident_map_bot. }
        { eapply ident_map_eq. }
        { instantiate (1:=fun _ => True). i. eapply ident_map_mappable_evt. }
        { econs; eauto. econs; eauto. }
        { ss. }
        { eauto. }
        { ss. }
        { ss. }
        { ss. }
        { eapply mapping_map_lt_collapsable_unwritable. eapply ident_map_lt. }
        { ss. }
        i. des. inv STEP0.
        assert (RECHABLE0: semi_reachable (Thread.mk _ state flc1 fsc1 fmem1)).
        { inv REACHABLE.
          econs; eauto. etrans; eauto. econs 2; [|refl]. econs; eauto. econs; eauto.
          ss. inv LOCAL1. hexploit promise_consistent_map.
          { eapply ident_map_le. }
          { eapply ident_map_eq. }
          { eapply TVIEW. }
          { eapply PROMISES. }
          { ss. }
          i. eapply promise_consistent_mon; eauto. refl.
        }
        esplits; eauto. econs; eauto.
        { eapply mapping_map_lt_collapsable_unwritable; eauto. eapply ident_map_lt. }
      Qed.

      Lemma tau_steps_map_reachable lang (th0 th1 fth0: Thread.t lang)
            (STEPS: rtc (@Thread.tau_step _) th0 th1)
            (THREAD: thread_map ident_map th0 fth0)
            (CONSISTENT: Local.promise_consistent (Thread.local th1))
            (REACHABLE: semi_reachable fth0)
            (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
            (MEMORY: Memory.closed (Thread.memory th0))
            (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
            (FLOCAL: Local.wf (Thread.local fth0) (Thread.memory fth0))
            (FMEMORY: Memory.closed (Thread.memory fth0))
            (FSC: Memory.closed_timemap (Thread.sc fth0) (Thread.memory fth0))
        :
          exists fth1,
            (<<STEPS: rtc (@Thread.tau_step _) fth0 fth1>>) /\
            (<<THREAD: thread_map ident_map th1 fth1>>) /\
            (<<REACHABLE: semi_reachable fth1>>) /\
            (<<STEPS: rtc (@tau_step _) th0 th1>>)
      .
      Proof.
        revert_until STEPS. revert fth0. induction STEPS; eauto.
        { i. esplits; eauto. }
        i. inv H. inv TSTEP. exploit Thread.step_future; eauto. i. des.
        hexploit PromiseConsistent.rtc_tau_step_promise_consistent; eauto. i.
        hexploit step_map_reachable; eauto. i. des.
        exploit Thread.step_future; try apply STEP0; eauto. i. des.
        hexploit IHSTEPS; eauto. i. des. exists fth2. splits; auto.
        { eapply tevent_map_same_machine_event in EVENT0.
          rewrite <- EVENT0 in EVENT.
          econs 2; eauto. econs; eauto. econs; eauto.
        }
        { econs 2; eauto. econs; eauto. }
      Qed.

      Lemma consistent_reachable lang (th0: Thread.t lang)
            (CONSISTENT: Thread.consistent th0)
            (REACHABLE: semi_reachable th0)
            (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
            (MEMORY: Memory.closed (Thread.memory th0))
            (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
        :
          consistent th0.
      Proof.
        ii.
        assert (THREAD: thread_map ident_map (Thread.mk _ (Thread.state th0) (Thread.local th0) sc1 mem1) th0).
        { destruct th0. ss. econs; eauto.
          - eapply ident_map_local.
          - econs.
            + i. eapply Memory.cap_inv in GET; eauto. des; eauto.
              right. exists to, from, msg, msg. splits; ss.
              * eapply ident_map_message.
              * refl.
            + i. eapply Memory.cap_le in GET; eauto; [|refl].
              left. exists fto, ffrom, fto, ffrom. splits; ss; try refl. i. econs; eauto.
          - eapply mapping_map_lt_collapsable_unwritable. eapply ident_map_lt.
          - eapply ident_map_timemap.
          - eapply Memory.max_concrete_timemap_spec; eauto.
            eapply Memory.cap_closed_timemap; eauto.
        }
        assert (FLOCAL: Local.wf (Thread.local th0) mem1).
        { eapply Local.cap_wf; eauto. }
        assert (FMEMORY: Memory.closed mem1).
        { eapply Memory.cap_closed; eauto. }
        assert (FSC: Memory.closed_timemap sc1 mem1).
        { eapply Memory.max_concrete_timemap_closed; eauto. }
        exploit CONSISTENT; eauto. i. des.
        { left. unfold Thread.steps_failure in *. des.
          exploit Thread.rtc_tau_step_future; eauto. i. des. ss.
          eapply tau_steps_map_reachable in STEPS; eauto.
          { des. exploit Thread.rtc_tau_step_future; eauto. i. des.
            eapply step_map_reachable in FAILURE0; eauto.
            { des. esplits; eauto. }
            { inv FAILURE0; inv STEP. inv LOCAL0. inv LOCAL1. ss. }
          }
          { inv FAILURE0; inv STEP. inv LOCAL0. inv LOCAL1. ss. }
        }
        { right. eapply tau_steps_map_reachable in STEPS; eauto.
          { des. esplits; eauto. }
          { eapply Local.bot_promise_consistent; eauto. }
        }
      Qed.

      Lemma configuration_step_reachable c1 c2 e
            (STEP: SConfiguration.step e tid c1 c2)
            (REACHABLE: rtc SConfiguration.all_machine_step c0 c1)
            (WF: Configuration.wf c1)
        :
          configuration_step e tid c1 c2.
      Proof.
        inv STEP.
        exploit Thread.rtc_cancel_step_future; eauto; try eapply WF; eauto. i. des. ss.
        exploit Thread.opt_step_future; eauto. i. des.
        exploit Thread.rtc_reserve_step_future; eauto. i. des. ss.
        assert ((<<CONSISTENT4: Local.promise_consistent lc4>>) /\
                (<<CONSISTENT3: Local.promise_consistent (Thread.local e3)>>)).
        { destruct (classic (e = ThreadEvent.failure)).
          - subst. inv STEP0. inv STEP; inv STEP0. inv LOCAL. inv LOCAL0. ss.
            splits; eauto.
            eapply PromiseConsistent.rtc_reserve_step_promise_consistent2 in RESERVES; eauto.
          - specialize (CONSISTENT H).
            eapply PromiseConsistent.consistent_promise_consistent in CONSISTENT; eauto.
            splits; eauto.
            eapply PromiseConsistent.rtc_reserve_step_promise_consistent; eauto.
        }
        des.
        assert (CONSISTENT2: Local.promise_consistent (Thread.local e2)).
        { inv STEP0; eauto.
          eapply PromiseConsistent.step_promise_consistent; eauto. }
        assert (CONSISTENT1: Local.promise_consistent lc1).
        { eapply PromiseConsistent.rtc_cancel_step_promise_consistent in CANCELS; eauto. }
        eapply cancel_steps_reachable in CANCELS; eauto; try eapply WF; eauto. des.
        eapply opt_step_reachable in STEP0; eauto. des.
        eapply reserve_steps_reachable in RESERVES; eauto. des.
        econs; eauto. i.
        eapply consistent_reachable; eauto.
      Qed.

    End TID.

    Section SIMCONFIG.

      Inductive sim_state_rel
                (tid: Ident.t)
                (lang_src lang_tgt: language)
                (r: Language.state lang_src -> Language.state lang_tgt -> Prop) :=
      | sim_state_rel_intro
          (STEP: forall st_src0 st_tgt0 st_tgt1 e
                        (REL: r st_src0 st_tgt0)
                        (REACHABLE: semi_reachable_state tid lang_tgt st_tgt1)
                        (STEP: Language.step lang_tgt e st_tgt0 st_tgt1),
              exists st_src1,
                (<<STEP: Language.step lang_src e st_src0 st_src1>>) /\
                (<<REL: r st_src1 st_tgt1>>))
          (TERMINAL: forall st_src st_tgt
                            (REL: r st_src st_tgt)
                            (REACHABLE: semi_reachable_state tid lang_tgt st_tgt)
                            (TERMINAL: Language.is_terminal lang_tgt st_tgt),
              Language.is_terminal lang_src st_src)
      .
      Hint Constructors sim_state_rel.

      Lemma eq_sim_state_rel tid lang
        :
          sim_state_rel tid lang lang eq.
      Proof.
        econs; i; clarify. eauto.
      Qed.

      Variable (r: forall (tid: Ident.t) (lang_src lang_tgt: language),
                   Language.state lang_src -> Language.state lang_tgt -> Prop).
      Hypothesis (REL: forall tid lang_src lang_tgt, sim_state_rel tid lang_src lang_tgt (r tid lang_src lang_tgt)).

      Inductive sim_statelocal tid:
        forall (lcst_src lcst_tgt: (sigT (@Language.state _)) * Local.t), Prop :=
      | sim_statelocal_intro
          lang_src lang_tgt st_src st_tgt lc
          (REL: r tid lang_src lang_tgt st_src st_tgt)
        :
          sim_statelocal tid (existT _ lang_src st_src, lc) (existT _ lang_tgt st_tgt, lc)
      .
      Hint Constructors sim_statelocal.

      Inductive sim_thread tid lang_src lang_tgt: forall (th_src: Thread.t lang_src) (th_tgt: Thread.t lang_tgt), Prop :=
      | sim_thread_intro
          st_src st_tgt lc sc mem
          (REL: r tid lang_src lang_tgt st_src st_tgt)
        :
          sim_thread tid (Thread.mk _ st_src lc sc mem) (Thread.mk _ st_tgt lc sc mem)
      .
      Hint Constructors sim_thread.

      Inductive sim_configuration:
        forall (c_src c_tgt: Configuration.t), Prop :=
      | sim_configuration_intro
          ths_src ths_tgt sc mem
          (THS: forall tid,
              option_rel
                (sim_statelocal tid)
                (IdentMap.find tid ths_src)
                (IdentMap.find tid ths_tgt))
        :
          sim_configuration (Configuration.mk ths_src sc mem) (Configuration.mk ths_tgt sc mem)
      .
      Hint Constructors sim_configuration.

      Lemma sim_thread_step tid lang_src lang_tgt
            (th_src0: Thread.t lang_src) (th_tgt0 th_tgt1: Thread.t lang_tgt) pf e
            (STEP: step tid pf e th_tgt0 th_tgt1)
            (SIM: sim_thread tid th_src0 th_tgt0)
        :
          exists th_src1,
            (<<STEP: Thread.step pf e th_src0 th_src1>>) /\
            (<<SIM: sim_thread tid th_src1 th_tgt1>>).
      Proof.
        inv SIM. inv STEP; ss. inv STEP0.
        { inv STEP. ss. esplits; eauto. econs 1; eauto. econs; eauto. }
        inv STEP. specialize (REL tid lang_src lang_tgt). inv REL.
        exploit STEP; eauto. i. des.
        esplits; eauto.
      Qed.

      Lemma sim_thread_opt_step tid lang_src lang_tgt
            (th_src0: Thread.t lang_src) (th_tgt0 th_tgt1: Thread.t lang_tgt) e
            (STEP: opt_step tid e th_tgt0 th_tgt1)
            (SIM: sim_thread tid th_src0 th_tgt0)
        :
          exists th_src1,
            (<<STEP: Thread.opt_step e th_src0 th_src1>>) /\
            (<<SIM: sim_thread tid th_src1 th_tgt1>>).
      Proof.
        inv STEP.
        - esplits; eauto. econs 1.
        - eapply sim_thread_step in SIM; eauto. des. esplits; eauto. econs 2; eauto.
      Qed.

      Lemma sim_thread_reserve_steps tid lang_src lang_tgt
            (th_src0: Thread.t lang_src) (th_tgt0 th_tgt1: Thread.t lang_tgt)
            (STEPS: rtc (@reserve_step tid _) th_tgt0 th_tgt1)
            (SIM: sim_thread tid th_src0 th_tgt0)
        :
          exists th_src1,
            (<<STEPS: rtc (@Thread.reserve_step _) th_src0 th_src1>>) /\
            (<<SIM: sim_thread tid th_src1 th_tgt1>>).
      Proof.
        ginduction STEPS; eauto. i. inv H.
        eapply sim_thread_step in STEP; eauto. des.
        exploit IHSTEPS; eauto. i. des.
        exists th_src2; eauto. esplits; eauto. econs; eauto. econs; eauto.
      Qed.

      Lemma sim_thread_cancel_steps tid lang_src lang_tgt
            (th_src0: Thread.t lang_src) (th_tgt0 th_tgt1: Thread.t lang_tgt)
            (STEPS: rtc (@cancel_step tid _) th_tgt0 th_tgt1)
            (SIM: sim_thread tid th_src0 th_tgt0)
        :
          exists th_src1,
            (<<STEPS: rtc (@Thread.cancel_step _) th_src0 th_src1>>) /\
            (<<SIM: sim_thread tid th_src1 th_tgt1>>).
      Proof.
        ginduction STEPS; eauto. i. inv H.
        eapply sim_thread_step in STEP; eauto. des.
        exploit IHSTEPS; eauto. i. des.
        exists th_src2; eauto. esplits; eauto. econs; eauto. econs; eauto.
      Qed.

      Lemma sim_thread_tau_steps tid lang_src lang_tgt
            (th_src0: Thread.t lang_src) (th_tgt0 th_tgt1: Thread.t lang_tgt)
            (STEPS: rtc (@tau_step tid _) th_tgt0 th_tgt1)
            (SIM: sim_thread tid th_src0 th_tgt0)
        :
          exists th_src1,
            (<<STEPS: rtc (@Thread.tau_step _) th_src0 th_src1>>) /\
            (<<SIM: sim_thread tid th_src1 th_tgt1>>).
      Proof.
        ginduction STEPS; eauto. i. inv H. inv TSTEP.
        eapply sim_thread_step in STEP; eauto. des.
        exploit IHSTEPS; eauto. i. des.
        exists th_src2; eauto. esplits; eauto. econs; eauto. econs; eauto. econs; eauto.
      Qed.

      Lemma sim_thread_consistent tid lang_src lang_tgt
            (th_src: Thread.t lang_src) (th_tgt: Thread.t lang_tgt)
            (CONSISTENT: consistent tid th_tgt)
            (SIM: sim_thread tid th_src th_tgt)
        :
          Thread.consistent th_src.
      Proof.
        inv SIM. ii; ss.
        assert (SIM: sim_thread tid (Thread.mk _ st_src lc sc1 mem1) (Thread.mk _ st_tgt lc sc1 mem1)).
        { econs; eauto. }
        exploit CONSISTENT; eauto. i; ss. des.
        - left. eapply sim_thread_tau_steps in STEPS; eauto. des.
          eapply sim_thread_step in FAILURE; eauto. des.
          unfold Thread.steps_failure. esplits; eauto.
        - right. eapply sim_thread_tau_steps in STEPS; eauto. des.
          esplits; eauto. inv SIM0. ss.
      Qed.

      Lemma sim_configuration_step c_src0 c_tgt0 c_tgt1 e tid
            (WF: Configuration.wf c_tgt0)
            (STEP: SConfiguration.step e tid c_tgt0 c_tgt1)
            (SIM: sim_configuration c_src0 c_tgt0)
            (REACHABLE: rtc SConfiguration.all_machine_step c0 c_tgt0)
        :
          exists c_src1,
            (<<STEP: SConfiguration.step e tid c_src0 c_src1>>) /\
            (<<SIM: sim_configuration c_src1 c_tgt1>>).
      Proof.
        eapply configuration_step_reachable in STEP; eauto.
        inv STEP. inv SIM. ss.
        dup THS. specialize (THS0 tid). setoid_rewrite TID in THS0.
        unfold option_rel in THS0. des_ifs. destruct p as [[lang_src st_src] lc_tgt].
        inv THS0. eapply inj_pair2 in H4. clarify. eapply inj_pair2 in H0. clarify.
        assert (SIM: sim_thread tid (Thread.mk _ st_src lc1 sc mem) (Thread.mk _ st1 lc1 sc mem)) by eauto.
        eapply sim_thread_cancel_steps in CANCELS; eauto. des.
        eapply sim_thread_opt_step in STEP0; eauto. des.
        eapply sim_thread_reserve_steps in RESERVES; eauto. des. destruct th_src2.
        esplits.
        { econs; s.
          - eauto.
          - eapply STEPS.
          - eapply STEP.
          - eapply STEPS0.
          - i. eapply sim_thread_consistent; eauto.
        }
        { inv SIM2. ss. econs; eauto. i.
          repeat erewrite IdentMap.gsspec. des_ifs.
        }
      Qed.

      Lemma steps_configuration_local_consistent c1
            (REACHABLE: rtc SConfiguration.all_machine_step c0 c1)
            tid lang st lc
            (TID: IdentMap.find tid (Configuration.threads c1) = Some (existT _ lang st, lc))
        :
          Local.promise_consistent lc.
      Proof.
        eapply Operators_Properties.clos_rt_rt1n_iff in REACHABLE.
        eapply Operators_Properties.clos_rt_rtn1_iff in REACHABLE.
        revert tid lang st lc TID. induction REACHABLE; eauto.
        i. inv H. inv STEP. assert (WF0: Configuration.wf y).
        { eapply Operators_Properties.clos_rt_rtn1_iff in REACHABLE.
          eapply Operators_Properties.clos_rt_rt1n_iff in REACHABLE.
          eapply SConfiguration.all_machine_steps_future; eauto. }
        exploit SConfiguration.step_future; eauto. i. des.
        inv STEP0. ss.
        erewrite IdentMap.gsspec in TID. des_ifs.
        { eapply inj_pair2 in H0. clarify.
          destruct (classic (e0 = ThreadEvent.failure)).
          { inv STEP; ss. inv STEP0; inv STEP. inv LOCAL. inv LOCAL0.
            eapply PromiseConsistent.rtc_reserve_step_promise_consistent2 in RESERVES; eauto.
          }
          { hexploit PromiseConsistent.consistent_promise_consistent; eauto; try apply WF2; eauto.
            ss. inv WF2. ss. eapply WF; eauto.
            erewrite IdentMap.gss. eauto.
          }
        }
        { eapply IHREACHABLE; eauto. }
      Qed.

      Lemma sim_configuration_terminal c_src c_tgt
            (TERMINAL: Configuration.is_terminal c_tgt)
            (SIM: sim_configuration c_src c_tgt)
            (REACHABLE: rtc SConfiguration.all_machine_step c0 c_tgt)
        :
          Configuration.is_terminal c_src.
      Proof.
        ii. inv SIM. ss.
        specialize (THS tid). setoid_rewrite FIND in THS.
        unfold option_rel in THS. des_ifs. destruct p as [[lang_tgt st_tgt] lc_tgt].
        inv THS. eapply inj_pair2 in H4. clarify. eapply inj_pair2 in H0. clarify.
        exploit TERMINAL; eauto. i. des.
        specialize (REL tid lang lang_tgt). inv REL.
        exploit TERMINAL0; eauto.
        econs; eauto. econs; eauto. ss.
        hexploit steps_configuration_local_consistent.
        { eapply REACHABLE. }
        { ss. eauto. }
        { eauto. }
      Qed.

      Lemma sim_configuration_behavior c_src c_tgt
            (WF: Configuration.wf c_tgt)
            (SIM: sim_configuration c_src c_tgt)
            (REACHABLE: rtc SConfiguration.all_machine_step c0 c_tgt)
        :
          behaviors SConfiguration.machine_step c_tgt <1= behaviors SConfiguration.machine_step c_src.
      Proof.
        intros beh BEH. ginduction BEH; eauto.
        - i. econs 1. eapply sim_configuration_terminal; eauto.
        - i. dup STEP. inv STEP0. exploit SConfiguration.step_future; eauto. i. des.
          eapply sim_configuration_step in STEP1; eauto. des. econs 2.
          + rewrite <- H0. econs; eauto.
          + eapply IHBEH; eauto. etrans; eauto.
        - i. dup STEP. inv STEP0. exploit SConfiguration.step_future; eauto. i. des.
          eapply sim_configuration_step in STEP1; eauto. des. econs 3.
          + rewrite <- H0. econs; eauto.
        - i. dup STEP. inv STEP0. exploit SConfiguration.step_future; eauto. i. des.
          eapply sim_configuration_step in STEP1; eauto. des. econs 4.
          + rewrite <- H0. econs; eauto.
          + eapply IHBEH; eauto. etrans; eauto.
      Qed.
    End SIMCONFIG.
  End REACHABLE.

  Theorem unreachable_code_transformation syn_src syn_tgt
          (r: forall (tid: Ident.t) (lang_src lang_tgt: language),
              Language.state lang_src -> Language.state lang_tgt -> Prop)
          (REL: forall tid lang_src lang_tgt, sim_state_rel (Configuration.init syn_tgt) tid lang_src lang_tgt (r tid lang_src lang_tgt))
          (INIT: sim_configuration r (Configuration.init syn_src) (Configuration.init syn_tgt))
    :
      behaviors SConfiguration.machine_step (Configuration.init syn_tgt)
      <1=
      behaviors SConfiguration.machine_step (Configuration.init syn_src).
  Proof.
    eapply sim_configuration_behavior; eauto.
    - i. ss. unfold Threads.init in *. rewrite IdentMap.Facts.map_o in TID.
      unfold option_map in *. des_ifs. ii. ss. erewrite Memory.bot_get in *. ss.
    - eapply Configuration.init_wf.
    - eapply Configuration.init_wf.
  Qed.
End SemiReachable.


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

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

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.

Require Import PromiseConsistent.
Require Import ReorderPromises.
Require Import Mapping.
Require Import Pred.
Require Import Trace.

Set Implicit Arguments.

Definition pf_consistent lang (e:Thread.t lang): Prop :=
  forall mem1 (CAP: Memory.cap (Thread.memory e) mem1),
  exists e2,
    (<<STEPS: rtc (tau (Thread.step true)) (Thread.mk _ (Thread.state e) (Thread.local e) (Thread.sc e) mem1) e2>>) /\
    (<<PROMISES: (Local.promises (Thread.local e2)) = Memory.bot>>).

Definition pf_consistent_or_failure lang (e:Thread.t lang): Prop :=
  forall mem1 (CAP: Memory.cap (Thread.memory e) mem1),
  exists e2,
    (<<STEPS: rtc (tau (Thread.step true)) (Thread.mk _ (Thread.state e) (Thread.local e) (Thread.sc e) mem1) e2>>) /\
    ((exists e e3,
         (<<STEP_FAILURE: Thread.step true e e2 e3 >>) /\
         (<<EVENT_FAILURE: ThreadEvent.get_machine_event e = MachineEvent.failure>>)) \/
     (<<PROMISES: (Local.promises (Thread.local e2)) = Memory.bot>>)).

Lemma promise_step_is_racy
      lc1 mem1 loc from to msg lc2 mem2 kind
      loc' to' ord
      (STEP: Local.promise_step lc1 mem1 loc from to msg lc2 mem2 kind)
      (RACE: Local.is_racy lc2 mem2 loc' to' ord):
  Local.is_racy lc1 mem1 loc' to' ord.
Proof.
  destruct lc1 as [tview1 promises1]. inv STEP. ss.
  inv RACE. ss. inv PROMISE; ss.
  { revert GET. erewrite Memory.add_o; eauto.
    revert GETP. erewrite Memory.add_o; eauto.
    condtac; ss; eauto.
  }
  { revert GET. erewrite Memory.split_o; eauto.
    revert GETP. erewrite Memory.split_o; eauto.
    repeat (condtac; ss); eauto.
  }
  { revert GET. erewrite Memory.lower_o; eauto.
    revert GETP. erewrite Memory.lower_o; eauto.
    condtac; ss; eauto.
  }
  { revert GET. erewrite Memory.remove_o; eauto.
    revert GETP. erewrite Memory.remove_o; eauto.
    condtac; ss; eauto.
  }
Qed.

Lemma rtc_union_step_nonpf_failure
      lang e1 e e2 e2'
      (STEP: rtc (union (@Thread.step lang false)) e1 e2)
      (FAILURE: Thread.step true e e2 e2')
      (EVENT: ThreadEvent.get_machine_event e = MachineEvent.failure)
  :
    exists e1',
      Thread.step true e e1 e1'.
Proof.
  ginduction STEP; eauto.
  i. exploit IHSTEP; eauto. intros x0. des.
  exists (Thread.mk _ (Thread.state e1') (Thread.local x) (Thread.sc x) (Thread.memory x)).
  econs 2; eauto.
    inv H. inv USTEP. inv STEP0. ss.
  inv x0; inv STEP0; ss. inv LOCAL0; ss.
  - inv LOCAL1; ss.
    econs; eauto. econs; eauto. econs; eauto; ss.
    eapply promise_step_promise_consistent; eauto.
  - inv LOCAL1; ss.
    econs; eauto. econs; eauto. econs; eauto; ss.
    + eapply promise_step_is_racy; eauto.
    + eapply promise_step_promise_consistent; eauto.
  - econs; eauto. econs; eauto.
    inv LOCAL1; ss; eauto using promise_step_is_racy, promise_step_promise_consistent.
Qed.

Lemma consistent_pf_consistent lang (e:Thread.t lang)
      (WF: Local.wf (Thread.local e) (Thread.memory e))
      (SC: Memory.closed_timemap (Thread.sc e) (Thread.memory e))
      (MEM: Memory.closed (Thread.memory e))
      (CONSISTENT: Thread.consistent e)
  :
    (<<CONSISTENT: pf_consistent e>>) \/ (<<FAILURE: Thread.steps_failure e>>).
Proof.
  destruct (classic (Thread.steps_failure e)) as [|NFAILURE]; auto.
  left. ii. exploit CONSISTENT; eauto. i. des.
  - exfalso. red in FAILURE. des.
    exploit cap_failure_current_steps; eauto.
    red. esplits; eauto.
  - exploit tau_steps_pf_tau_steps; eauto; ss.
    { ii. rewrite PROMISES, Memory.bot_get in *.  congr. }
    { eapply Local.cap_wf; eauto. }
    { eapply Memory.cap_closed_timemap; eauto. }
    { eapply Memory.cap_closed; eauto. }
    i. des.
    exploit rtc_union_step_nonpf_bot; [|eauto|].
    { eapply rtc_implies; [|eauto]. apply tau_union. }
    i. subst. esplits; eauto.
Qed.

Lemma consistent_pf_consistent_or_failure lang (e:Thread.t lang)
      (WF: Local.wf (Thread.local e) (Thread.memory e))
      (SC: Memory.closed_timemap (Thread.sc e) (Thread.memory e))
      (MEM: Memory.closed (Thread.memory e))
      (CONSISTENT: Thread.consistent e)
  :
    pf_consistent_or_failure e.
Proof.
  ii. exploit CONSISTENT; eauto. i. des.
  - inv FAILURE. des.
    hexploit tau_steps_pf_tau_steps; eauto; ss.
    { inv STEP_FAILURE; inv STEP; ss.
      inv LOCAL; ss; inv LOCAL0; ss.
    }
    { eapply Local.cap_wf; eauto. }
    { eapply Memory.cap_closed_timemap; eauto. }
    { eapply Memory.cap_closed; eauto. }
    i. des.
    exploit rtc_union_step_nonpf_failure.
    { eapply rtc_implies; [|eauto]. apply tau_union. }
    { eauto. }
    { eauto. }
    i. des.
    esplits; eauto.
  - exploit tau_steps_pf_tau_steps; eauto; ss.
    { ii. rewrite PROMISES, Memory.bot_get in *.  congr. }
    { eapply Local.cap_wf; eauto. }
    { eapply Memory.cap_closed_timemap; eauto. }
    { eapply Memory.cap_closed; eauto. }
    i. des.
    exploit rtc_union_step_nonpf_bot; [|eauto|].
    { eapply rtc_implies; [|eauto]. apply tau_union. }
    i. subst. esplits; eauto.
Qed.

Definition no_sc_consistent lang (e:Thread.t lang): Prop :=
  forall mem1 (CAP: Memory.cap (Thread.memory e) mem1),
  exists e2,
    (<<STEPS: rtc (tau (@pred_step no_sc _)) (Thread.mk _ (Thread.state e) (Thread.local e) (Thread.sc e) mem1) e2>>) /\
    __guard__((exists e e3,
                  (<<STEP_FAILURE: Thread.step true e e2 e3 >>) /\
                  (<<EVENT_FAILURE: ThreadEvent.get_machine_event e = MachineEvent.failure>>)) \/
              (<<PROMISES: (Local.promises (Thread.local e2)) = Memory.bot>>)).

Lemma consistent_no_sc_consistent lang (e:Thread.t lang)
      (WF: Local.wf (Thread.local e) (Thread.memory e))
      (SC: Memory.closed_timemap (Thread.sc e) (Thread.memory e))
      (MEM: Memory.closed (Thread.memory e))
      (CONSISTENT: Thread.consistent e)
  :
  no_sc_consistent e.
Proof.
  eapply consistent_pf_consistent_or_failure in CONSISTENT; eauto.
  ii. exploit CONSISTENT; eauto. intros [e2 [STEPS FINAL]].
  guardH FINAL. des.
  eapply rtc_implies in STEPS; cycle 1.
  { instantiate (1:= tau (@pred_step (fun _ => True)  _)).
    i. inv H. econs; eauto. econs; eauto. econs; eauto.
  }
  eapply (@hold_or_not _ no_sc) in STEPS. des.
  { esplits.
    { eapply rtc_implies; [|eapply HOLD].
      i. inv H. inv TSTEP. des. econs; eauto. econs; eauto.
    }
    { eauto. }
  }
  { esplits.
    { eapply rtc_implies; [|eapply STEPS0].
      i. inv H. inv TSTEP. des. econs; eauto. econs; eauto.
    }
    right. inv STEP. inv STEP0; inv STEP; ss. inv LOCAL; ss.
    { inv LOCAL0. eapply PROMISES.
      eapply NNPP in BREAKQ. destruct ordw; ss.
    }
    { inv LOCAL0. eapply PROMISES. auto. }
  }
Qed.

Definition no_sc_trace_consistent lang (e:Thread.t lang): Prop :=
  forall mem1 (CAP: Memory.cap (Thread.memory e) mem1),
  exists tr0 tr1 e2,
    (<<STEPS: Trace.steps (tr0++tr1) (Thread.mk _ (Thread.state e) (Thread.local e) (Thread.sc e) mem1) e2>>) /\
    (<<NOSC: List.Forall (fun '(_, e) => no_sc e) (tr0++tr1)>>) /\
    (<<SILENT: List.Forall (fun '(_, e) => ThreadEvent.get_machine_event e = MachineEvent.silent) tr0>>) /\
    (<<TRACE: __guard__(((<<NIL: tr1 = []>>) /\ (<<PROMISES: Local.promises (Thread.local e2) = Memory.bot>>)) \/ (exists lc e, (<<EVENT: tr1 = [(lc, e)]>>) /\ (<<FAILURE: ThreadEvent.get_machine_event e = MachineEvent.failure>>)))>>).

Lemma consistent_no_sc_trace_consistent lang (e:Thread.t lang)
      (WF: Local.wf (Thread.local e) (Thread.memory e))
      (SC: Memory.closed_timemap (Thread.sc e) (Thread.memory e))
      (MEM: Memory.closed (Thread.memory e))
      (CONSISTENT: Thread.consistent e)
  :
  no_sc_trace_consistent e.
Proof.
  eapply consistent_no_sc_consistent in CONSISTENT; eauto.
  ii. exploit CONSISTENT; eauto. intros x. des.
  eapply pred_steps_trace_steps in STEPS. des. red in x0. des.
  { exists tr, [(Thread.local e2, e0)]. esplits; eauto.
    { eapply Trace.plus_step_steps; eauto. }
    { eapply List.Forall_app. split.
      { eapply List.Forall_impl; eauto. i.
        destruct a. ss. des. auto.
      }
      { econs; eauto. destruct e0; ss. }
    }
    { eapply List.Forall_impl; eauto. i.
      destruct a. ss. des. auto.
    }
    { right. esplits; eauto. }
  }
  { eexists tr, []. rewrite List.app_nil_r. esplits; eauto.
    { eapply List.Forall_impl; eauto. i.
      destruct a. ss. des. auto.
    }
    { eapply List.Forall_impl; eauto. i.
      destruct a. ss. des. auto.
    }
    { left. esplits; eauto. }
  }
Qed.


Set Implicit Arguments.

Require Import Bedrock.IL Bedrock.Memory Coq.Strings.String Bedrock.sep.Locals Coq.Lists.List.

Definition upd_option vs x value :=
  match x with
    | None => vs
    | Some s => Locals.upd vs s value
  end.

Require Import Platform.Cito.FuncCore.
Export FuncCore.
Record InternalFuncSpec :=
  {
    Fun : FuncCore;
    NoDupArgVars : NoDup (ArgVars Fun)
  }.

Coercion Fun : InternalFuncSpec >-> FuncCore.

Require Import Platform.Cito.Syntax Platform.Cito.SemanticsExpr.
Require Import Platform.Cito.GLabel.
Require Import Platform.Cito.WordMap.
Require Import Platform.Cito.AxSpec.
Export AxSpec.

Section ADTValue.

  Variable ADTValue : Type.

  Definition Heap := WordMap.t ADTValue.

  Definition State := (vals * Heap)%type.

  Notation Value := (@Value ADTValue).
  Notation AxiomaticSpec := (@AxiomaticSpec ADTValue).
  Arguments SCA {ADTValue} _.
  Arguments ADT {ADTValue} _.

  Inductive Callee :=
  | Foreign : AxiomaticSpec -> Callee
  | Internal : InternalFuncSpec -> Callee.

  Definition word_adt_match (heap : Heap) (p : W * Value) :=
    let word := fst p in
    let in_ := snd p in
    match in_ with
      | SCA w => word = w
      | ADT a => WordMap.find word heap = Some a
    end.

  Definition disjoint_ptrs (pairs : list (W * Value)) :=
    let pairs := filter (fun p => is_adt (snd p)) pairs in
    NoDup (List.map fst pairs).

  Definition good_inputs heap pairs :=
    Forall (word_adt_match heap) pairs /\
    disjoint_ptrs pairs.

  Record ArgTriple :=
    {
      Word : W;
      ADTIn : Value;
      ADTOut : option ADTValue
    }.

  Definition store_out (heap : Heap) t :=
    match ADTIn t, ADTOut t with
      | SCA _, _ => heap
      | ADT _, None => WordMap.remove (Word t) heap
      | ADT _, Some a => WordMap.add (Word t) a heap
    end.

  Definition decide_ret addr (ret : Value) :=
    match ret with
      | SCA w => (w, None)
      | ADT a => (addr, Some a)
    end.

  Definition separated heap ret_w (ret_a : option ADTValue) :=
    ret_a = None \/ ~ @WordMap.In ADTValue ret_w heap.

  Definition heap_upd_option m k (v : option ADTValue) :=
    match v with
      | Some x => WordMap.add k x m
      | None => m
    end.

  (* Semantics *)

  Section Env.

    Variable env : (glabel -> option W) * (W -> option Callee).

    Inductive RunsTo : Stmt -> State -> State -> Prop :=
    | RunsToSkip : forall v, RunsTo Syntax.Skip v v
    | RunsToSeq :
        forall a b v v' v'',
          RunsTo a v v' ->
          RunsTo b v' v'' ->
          RunsTo (Syntax.Seq a b) v v''
    | RunsToIfTrue :
        forall cond t f v v',
          wneb (eval (fst v) cond) $0 = true ->
          RunsTo t v v' ->
          RunsTo (Syntax.If cond t f) v v'
    | RunsToIfFalse :
        forall cond t f v v',
          wneb (eval (fst v) cond) $0 = false ->
          RunsTo f v v' ->
          RunsTo (Syntax.If cond t f) v v'
    | RunsToWhileTrue :
        forall cond body v v' v'',
          let loop := While cond body in
          wneb (eval (fst v) cond) $0 = true ->
          RunsTo body v v' ->
          RunsTo loop v' v'' ->
          RunsTo loop v v''
    | RunsToWhileFalse :
        forall cond body v,
          let loop := While cond body in
          wneb (eval (fst v) cond) $0 = false ->
          RunsTo loop v v
    | RunsToCallInternal :
        forall var f args v spec vs_callee vs_callee' heap',
          let vs := fst v in
          let heap := snd v in
          let fs := snd env in
          fs (eval vs f) = Some (Internal spec) ->
          map (Locals.sel vs_callee) (ArgVars spec) = map (eval vs) args ->
          RunsTo (Body spec) (vs_callee, heap) (vs_callee', heap') ->
          let vs := upd_option vs var (Locals.sel vs_callee' (RetVar spec)) in
          let heap := heap' in
          RunsTo (Syntax.Call var f args) v (vs, heap)
    | RunsToCallForeign :
        forall var f args v spec triples addr ret heap',
          let vs := fst v in
          let heap := snd v in
          let fs := snd env in
          fs (eval vs f) = Some (Foreign spec) ->
          map (eval vs) args = map Word triples ->
          good_inputs heap (map (fun x => (Word x, ADTIn x)) triples) ->
          PreCond spec (map ADTIn triples) ->
          PostCond spec (map (fun x => (ADTIn x, ADTOut x)) triples) ret ->
          let heap := fold_left store_out triples heap in
          let t := decide_ret addr ret in
          let ret_w := fst t in
          let ret_a := snd t in
          separated heap ret_w ret_a ->
          let heap := heap_upd_option heap ret_w ret_a in
          let vs := upd_option vs var ret_w in
          WordMap.Equal heap' heap ->
          RunsTo (Syntax.Call var f args) v (vs, heap')
    | RunsToLabel :
        forall x lbl v w,
          fst env lbl = Some w ->
          RunsTo (Syntax.Label x lbl) v (Locals.upd (fst v) x w, snd v)
    | RunsToAssign :
        forall x e v,
          let vs := fst v in
          RunsTo (Syntax.Assign x e) v (Locals.upd vs x (eval vs e), snd v).

    CoInductive Safe : Stmt -> State -> Prop :=
    | SafeSkip :
        forall v, Safe Syntax.Skip v
    | SafeSeq :
        forall a b v,
          Safe a v ->
          (forall v', RunsTo a v v' -> Safe b v') ->
          Safe (Syntax.Seq a b) v
    | SafeIf :
        forall cond t f v,
          let b := wneb (eval (fst v) cond) $0 in
          b = true /\ Safe t v \/ b = false /\ Safe f v ->
          Safe (Syntax.If cond t f) v
    | SafeWhileTrue :
        forall cond body v,
          let loop := While cond body in
          wneb (eval (fst v) cond) $0 = true ->
          Safe body v ->
          (forall v', RunsTo body v v' -> Safe loop v') ->
          Safe loop v
    | SafeWhileFalse :
        forall cond body v,
          let loop := While cond body in
          wneb (eval (fst v) cond) $0 = false ->
          Safe loop v
    | SafeCallInternal :
        forall var f args v spec,
          let vs := fst v in
          let heap := snd v in
          let fs := snd env in
          fs (eval vs f) = Some (Internal spec) ->
          length (ArgVars spec) = length args ->
          (forall vs_arg,
             map (Locals.sel vs_arg) (ArgVars spec) = map (eval vs) args
             -> Safe (Body spec) (vs_arg, heap)) ->
          Safe (Syntax.Call var f args) v
    | SafeCallForeign :
        forall var f args v spec pairs,
          let vs := fst v in
          let heap := snd v in
          let fs := snd env in
          fs (eval vs f) = Some (Foreign spec) ->
          map (eval vs) args = map fst pairs ->
          good_inputs heap pairs ->
          PreCond spec (map snd pairs) ->
          Safe (Syntax.Call var f args) v
    | SafeLabel :
        forall x lbl v,
          fst env lbl <> None ->
          Safe (Syntax.Label x lbl) v
    | SafeAssign :
        forall x e v,
          Safe (Syntax.Assign x e) v.

    Section Safe_coind.
      Variable R : Stmt -> State -> Prop.

      Hypothesis SeqCase : forall a b v, R (Syntax.Seq a b) v -> R a v /\ forall v', RunsTo a v v' -> R b v'.

      Hypothesis IfCase : forall cond t f v, R (Syntax.If cond t f) v -> (wneb (eval (fst v) cond) $0 = true /\ R t v) \/ (wneb (eval (fst v) cond) $0 = false /\ R f v).

      Hypothesis WhileCase :
        forall cond body v,
          let loop := Syntax.While cond body in
          R loop v ->
          (wneb (eval (fst v) cond) $0 = true /\ R body v /\ (forall v', RunsTo body v v' -> R loop v')) \/
          (wneb (eval (fst v) cond) $0 = false).

      Hypothesis CallCase : forall var f args v,
        R (Syntax.Call var f args) v
        -> (exists spec, let vs := fst v in
          let heap := snd v in
            let fs := snd env in
              fs (eval vs f) = Some (Internal spec) /\
              length (ArgVars spec) = length args /\
              (forall vs_arg,
                map (Locals.sel vs_arg) (ArgVars spec) = map (eval vs) args
                -> R (Body spec) (vs_arg, heap)))
        \/ (exists spec, exists pairs, let vs := fst v in
          let heap := snd v in
            let fs := snd env in
              fs (eval vs f) = Some (Foreign spec) /\
              map (eval vs) args = map fst pairs /\
              good_inputs heap pairs /\
              PreCond spec (map snd pairs)).

      Hypothesis LabelCase : forall x lbl v,
        R (Syntax.Label x lbl) v
        -> fst env lbl <> None.

      Hint Constructors Safe.

      Ltac openhyp :=
        repeat match goal with
                 | H : _ /\ _ |- _  => destruct H
                 | H : _ \/ _ |- _ => destruct H
                 | H : exists x, _ |- _ => destruct H
               end.

      Ltac break_pair :=
        match goal with
          V : (_ * _)%type |- _ => destruct V
        end.

      Theorem Safe_coind : forall c v, R c v -> Safe c v.
        cofix; unfold State; intros; break_pair; destruct c.

        eauto.

        eapply SeqCase in H; openhyp; eauto.

        eapply IfCase in H; openhyp; eauto.

        eapply WhileCase in H; openhyp; eauto.

        eapply CallCase in H; openhyp; simpl in *; intuition eauto.

        eapply LabelCase in H; openhyp; eauto.

        eauto.
      Qed.

    End Safe_coind.

  End Env.

End ADTValue.

Require Import Platform.Cito.ADT.

Module Make (Import E : ADT).

  Definition RunsTo := @RunsTo ADTValue.

  Definition Safe := @Safe ADTValue.

  Definition Heap := @Heap ADTValue.

  Definition State := @State ADTValue.

  Definition ArgIn := @Value ADTValue.

  Definition ArgOut := option ADTValue.

  Definition Ret := @Value ADTValue.

  Definition ForeignFuncSpec := @AxiomaticSpec ADTValue.

  Definition Callee := @Callee ADTValue.

  Definition ArgTriple := @ArgTriple ADTValue.

  Definition word_adt_match := @word_adt_match ADTValue.

  Definition is_adt := @is_adt ADTValue.

  Definition disjoint_ptrs := @disjoint_ptrs ADTValue.

  Definition good_inputs := @good_inputs ADTValue.

  Definition store_out := @store_out ADTValue.

  Definition decide_ret := @decide_ret ADTValue.

  Definition separated := @separated ADTValue.

  Definition heap_upd_option := @heap_upd_option ADTValue.

  Definition Foreign := @Foreign ADTValue.

  Definition Internal := @Internal ADTValue.

  (* some shorthands for heap operations *)
  Require Import Coq.FSets.FMapFacts.
  Module Import P := Properties WordMap.
  Import F WordMap.

  Definition elt := ADTValue.

  Implicit Types m h : Heap.
  Implicit Types x y z k p w : key.
  Implicit Types e v a : elt.
  Implicit Types ls : list (key * elt).

  Definition heap_sel h p := find p h.

  Definition heap_mem := @In elt.

  Definition heap_upd h p v := add p v h.

  Definition heap_remove h p := remove p h.

  Definition heap_empty := @empty elt.

  Definition heap_merge := @update elt.

  Definition heap_elements := @elements elt.

  Definition heap_diff := @diff elt.

End Make.


Require Import floyd.base.
Require Import floyd.assert_lemmas.
Require Import floyd.client_lemmas.
Require Import floyd.nested_field_lemmas.
Require Import floyd.type_induction.
Require Import floyd.reptype_lemmas.
Require Import floyd.aggregate_type.
Require Import floyd.sublist.

Section PROJ_REPTYPE.

Context {cs: compspecs}.

Definition proj_gfield_reptype (t: type) (gf: gfield) (v: reptype t): reptype (gfield_type t gf) :=
  match t, gf return (REPTYPE t -> reptype (gfield_type t gf))
  with
  | Tarray t0 hi a, ArraySubsc i => fun v => Znth i v (default_val _)
  | Tstruct id _, StructField i => fun v => proj_struct i (co_members (get_co id)) v (default_val _)
  | Tunion id _, UnionField i => fun v => proj_union i (co_members (get_co id)) v (default_val _)
  | _, _ => fun _ => default_val _
  end (unfold_reptype v).

Fixpoint proj_reptype (t: type) (gfs: list gfield) (v: reptype t) : reptype (nested_field_type t gfs) :=
  let res :=
  match gfs as gfs'
    return reptype (match gfs' with
                    | nil => t
                    | gf :: gfs0 => gfield_type (nested_field_type t gfs0) gf
                    end)
  with
  | nil => v
  | gf :: gfs0 => proj_gfield_reptype _ gf (proj_reptype t gfs0 v)
  end
  in eq_rect_r reptype res (nested_field_type_ind t gfs).

End PROJ_REPTYPE.


(******************************************************************************)
(** * Compilation correctness from the S_IMM memory model to the ARMv8.3 model *)
(******************************************************************************)

From hahn Require Import Hahn.
Require Import Events.
Require Import Execution.
Require Import Execution_eco.
Require Import Arm.
Require Import imm_bob.
Require Import imm_s_ppo.
Require Import imm_s_hb.
Require Import imm_s.
Require Import imm_ppo.
Require Import imm_hb.
Require Import imm.
Require Import immToARMhelper.
Require Import imm_s_hb_hb.

Set Implicit Arguments.
Remove Hints plus_n_O.

Section immToARM.

Variable G : execution.

Notation "'E'" := G.(acts_set).
Notation "'acts'" := G.(acts).
Notation "'lab'" := G.(lab).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'co'" := G.(co).
Notation "'rmw'" := G.(rmw).
Notation "'data'" := G.(data).
Notation "'addr'" := G.(addr).
Notation "'ctrl'" := G.(ctrl).
Notation "'deps'" := G.(deps).
Notation "'rmw_dep'" := G.(rmw_dep).

Notation "'fre'" := G.(fre).
Notation "'rfe'" := G.(rfe).
Notation "'coe'" := G.(coe).
Notation "'rfi'" := G.(rfi).
Notation "'fri'" := G.(fri).
Notation "'coi'" := G.(coi).
Notation "'fr'" := G.(fr).
Notation "'eco'" := G.(eco).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).
Notation "'W_ex'" := (W_ex G).
Notation "'W_ex_acq'" := (W_ex ∩₁ (fun a => is_true (is_xacq lab a))).
Notation "'R_ex'" := (fun a => is_true (R_ex lab a)).

Notation "'loc'" := (loc lab).
Notation "'val'" := (val lab).
Notation "'mod'" := (mod lab).
Notation "'same_loc'" := (same_loc lab).
Notation "'detour'" := G.(detour).
Notation "'bob'" := G.(bob).

(* imm_s *)
Notation "'s_sw'" := G.(imm_s_hb.sw).
Notation "'s_release'" := G.(imm_s_hb.release).
Notation "'s_rs'" := G.(imm_s_hb.rs).
Notation "'s_hb'" := G.(imm_s_hb.hb).
Notation "'s_ppo'" := G.(imm_s_ppo.ppo).
Notation "'s_psc_f'" := G.(imm_s.psc_f).
Notation "'s_psc_base'" := G.(imm_s.psc_base).
Notation "'s_ar_int'" := G.(imm_s_ppo.ar_int).

(* imm *)
Notation "'sw'" := G.(imm_hb.sw).
Notation "'release'" := G.(imm_hb.release).
Notation "'rs'" := G.(imm_hb.rs).
Notation "'hb'" := G.(imm_hb.hb).
Notation "'ppo'" := G.(imm_ppo.ppo).
Notation "'psc'" := G.(imm.psc).
Notation "'psc_f'" := G.(imm.psc_f).
Notation "'psc_base'" := G.(imm.psc_base).
Notation "'ar_int'" := G.(imm_ppo.ar_int).

Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (fun a => is_true (is_rlx lab a)).
Notation "'Rel'" := (fun a => is_true (is_rel lab a)).
Notation "'Acq'" := (fun a => is_true (is_acq lab a)).
Notation "'Acqrel'" := (fun a => is_true (is_acqrel lab a)).
Notation "'Acq/Rel'" := (fun a => is_true (is_ra lab a)).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

(* arm *)
Notation "'obs'" := G.(obs).
Notation "'obs''" := G.(obs').
Notation "'aob'" := G.(aob).
Notation "'boba'" := G.(Arm.bob).
Notation "'boba''" := G.(bob').
Notation "'dob'" := G.(dob).

Notation "'L'" := (W ∩₁ (fun a => is_true (is_rel lab a))).
Notation "'Q'" := (R ∩₁ (fun a => is_true (is_acq lab a))).
Notation "'A'" := (R ∩₁ (fun a => is_true (is_sc  lab a))).

Notation "'F^ld'" := (F ∩₁ (fun a => is_true (is_acq lab a))).
Notation "'F^sy'" := (F ∩₁ (fun a => is_true (is_rel lab a))).

Hypothesis RMW_DEPS : rmw ⊆ ctrl ∪ data.
Hypothesis W_EX_ACQ_SB : ⦗W_ex_acq⦘ ⨾ sb ⊆ sb ⨾ ⦗F^ld⦘ ⨾  sb^?.
Hypothesis DEPS_RMW_SB : rmw_dep ⨾ sb ⊆ ctrl.
Hypothesis REX_IN_RMW_CTRL : <|R_ex|> ;; sb ⊆ ctrl.

Hypothesis CON: ArmConsistent G.

Lemma WF : Wf G.
Proof using CON. apply CON. Qed.
Lemma COMP : complete G.
Proof using CON. apply CON. Qed.
Lemma SC_PER_LOC : sc_per_loc G.
Proof using CON. apply CON. Qed.

Lemma RMW_COI : rmw ⨾ coi ⊆ obs' ∪ dob ∪ aob ∪ boba.
Proof using CON.
  cdes CON. rewrite rmw_in_fri; auto.
  rewrite fri_coi; auto. rewrite fri_in_fr.
  unfold Arm.obs'. eauto with hahn.
Qed.

Lemma R_ex_fail_sb_in_ctrl : ⦗R_ex \₁ dom_rel rmw⦘ ⨾ sb ⊆ ctrl.
Proof using REX_IN_RMW_CTRL.
  rewrite <- REX_IN_RMW_CTRL.
  basic_solver.
Qed.

Lemma s_ppo_in_dob : s_ppo ⊆ dob⁺.
Proof using CON DEPS_RMW_SB REX_IN_RMW_CTRL RMW_DEPS W_EX_ACQ_SB.
  unfold imm_s_ppo.ppo.
  rewrite REX_IN_RMW_CTRL.
  arewrite (data ∪ ctrl ∪ addr ⨾ sb^? ∪ rfi ∪ rmw ∪ rmw_dep ⨾ sb^? ∪ ctrl ⊆
            data ∪ ctrl ∪ addr ⨾ sb^? ∪ rfi ∪ rmw_dep ⨾ sb^?).
  { rewrite RMW_DEPS. unionL; eauto with hahn. }
  rewrite path_union, !seq_union_l, !seq_union_r. unionL.
  { apply ppo_in_dob_helper; auto. }
  assert ((data ∪ ctrl ∪ addr ⨾ sb^? ∪ rfi)＊ ⊆ sb^?) as AA.
  { rewrite WF.(data_in_sb), WF.(ctrl_in_sb), WF.(addr_in_sb).
    arewrite (rfi ⊆ sb).
    generalize (@sb_trans G). ins. relsf. }
  rewrite AA at 2.
  rewrite ct_begin, !seqA.
  rewrite AA at 2.
  arewrite (sb^? ⨾ (sb^? ⨾ rmw_dep ⨾ sb^?)＊ ⨾ sb^? ⊆ sb^?).
  { rewrite WF.(rmw_dep_in_sb). generalize (@sb_trans G). ins. relsf. }
  arewrite (rmw_dep ⨾ sb^? ⨾ ⦗W⦘ ⊆ rmw_dep ⨾ sb ⨾ ⦗W⦘).
  { rewrite (dom_r WF.(wf_rmw_depD)) at 1. rewrite R_ex_in_R. type_solver. }
  sin_rewrite DEPS_RMW_SB.
  arewrite (ctrl ⊆ data ∪ ctrl ∪ addr ⨾ sb^? ∪ rfi) at 2.
  seq_rewrite <- ct_end.
  apply ppo_in_dob_helper; auto.
Qed.

Lemma s_ppo_in_ord : s_ppo ⊆ (obs⁺ ∩ sb ∪ dob ∪ aob ∪ boba' ∪ sb ⨾ ⦗F^ld⦘)⁺.
Proof using CON DEPS_RMW_SB REX_IN_RMW_CTRL RMW_DEPS W_EX_ACQ_SB.
  rewrite s_ppo_in_dob. apply clos_trans_mori. eauto with hahn.
Qed.

Lemma s_ar_int_in_ord : ⦗R⦘ ⨾ s_ar_int⁺ ⨾ ⦗W⦘ ⊆ (obs ∪ dob ∪ aob ∪ boba')⁺.
Proof using CON DEPS_RMW_SB REX_IN_RMW_CTRL RMW_DEPS W_EX_ACQ_SB.
  unfold imm_s_ppo.ar_int.
  transitivity (⦗R⦘ ⨾  ((obs⁺∩ sb) ∪ dob ∪ aob ∪ boba' ∪ sb ⨾ ⦗F^ld⦘)⁺ ⨾ ⦗W⦘).
  2: { rewrite path_union.
       relsf; unionL.
       { arewrite_id ⦗R⦘; arewrite_id ⦗W⦘.
         rels.
         arewrite (obs⁺ ∩ sb ⊆ obs⁺).
         apply inclusion_t_t2.
         apply_unionL_once.
         apply_unionL_once.
         apply_unionL_once.
         { apply inclusion_t_t. basic_solver. }
         all: rewrite <- ct_step; basic_solver. }
       rewrite (dob_in_sb WF) at 1 2.
       rewrite (aob_in_sb WF) at 1 2.
       rewrite (bob'_in_sb WF) at 1 2.
       arewrite (obs⁺ ∩ sb ⊆ sb).
       rewrite ct_begin.
       arewrite_id ⦗F^ld⦘ at 2.
       generalize (@sb_trans G); ins; relsf.
       arewrite (⦗F^ld⦘ ⨾ sb^? ⨾ ⦗W⦘ ⊆ ⦗F^ld⦘ ⨾ sb) by type_solver.
       unfold Arm.bob', Arm.bob.
       rewrite <- ct_step. basic_solver 21. }
  arewrite (detour ⊆ detour ∩ sb).
  rewrite W_ex_acq_sb_in_boba1; auto.
  rewrite bob_in_boba; auto.
  rewrite detour_in_obs; auto.
  hahn_frame.
  apply inclusion_t_t2.
  apply_unionL_once.
  2: { rewrite <- ct_step. unfold Arm.aob. basic_solver 12. }
  apply_unionL_once.
  2: { apply inclusion_t_t; basic_solver 12. }
  apply_unionL_once.
  2: by unfolder; ins; econs; eauto.
  apply_unionL_once.
  { rewrite <- ct_step; rewrite <- ct_step; unfold Arm.obs; ie_unfolder; basic_solver 12. }
  apply s_ppo_in_ord.
Qed.

Lemma C_EXT_helper: imm_s.acyc_ext G (⦗F∩₁Sc⦘ ⨾ s_hb ⨾ eco ⨾ s_hb ⨾ ⦗F∩₁Sc⦘).
Proof using CON DEPS_RMW_SB REX_IN_RMW_CTRL RMW_DEPS W_EX_ACQ_SB.
  apply (s_acyc_ext_psc_helper WF).
  rewrite s_ar_int_in_ord.
  arewrite (rfe ⊆ (obs ∪ dob ∪ aob ∪ boba')⁺ ).
  { unfold Arm.obs; rewrite <- ct_step; basic_solver 12. }
  arewrite (imm_s.psc G ⊆ imm.psc G).
  { unfold imm_s.psc, imm.psc. by rewrite s_hb_in_hb. }
  rewrite psc_in_ord; auto.
  relsf; red; relsf.
  apply (external_alt_bob' WF CON).
Qed.

Lemma C_SC : acyclic (imm_s.psc_f G ∪ imm_s.psc_base G).
Proof using CON RMW_DEPS W_EX_ACQ_SB.
  unfold imm_s.psc_f, imm_s.psc_base, imm_s.scb.
  rewrite s_hb_in_hb.
  apply immToARMhelper.C_SC; auto.
Qed.

Lemma IMM_s_psc_consistent : exists sc, imm_psc_consistent G sc.
Proof using CON DEPS_RMW_SB REX_IN_RMW_CTRL RMW_DEPS W_EX_ACQ_SB.
  edestruct (imm_s.s_acyc_ext_helper WF C_EXT_helper) as [sc HH]. desc.
  exists sc. red. splits; eauto.
  2: by apply C_SC.
  red. splits; eauto; try apply CON.
  red.
  rewrite crE, seq_union_r, seq_id_r.
  rewrite s_hb_in_hb.
  apply irreflexive_union. split.
  2: { apply COH; auto. }
  rewrite hb_in_ord; auto.
  apply irreflexive_union. split.
  { by apply (@sb_irr G). }
  apply (external_alt_bob' WF CON).
Qed.

End immToARM.


Require Import List.
Require Import ListSet.
Require Import Coqlib.
Require Import Metatheory.
Require Import Maps.
Require Import Lattice.
Require Import Kildall.
Require Import Iteration.
Require Import cfg.
Require Import dom_decl.
Require Import reach.
Require Import Dipaths.
Require Import dom_tree.
Require Import syntax.
Require Import infrastructure.
Require Import infrastructure_props.
Import LLVMsyntax.
Import LLVMinfra.

(* The file defines the specification of computing dominators. *)

Notation "x {+} y" := (x :: y) (at level 0): dom.
Notation "x {<=} y" := (incl x y) (at level 0): dom.
Notation "{}" := nil (at level 0): dom.
Notation "x `in` y" := (In x y) (at level 70): dom.
Local Open Scope dom.

(* ALGDOM gives an abstract specification of algorithms that compute dominators.
   First of all, sdom defines the signature of a dominance analysis algorithm:
   given a function f and a label l1, (sdom f l1) returns the set of strict
   dominators of l1 in f ; dom defines the set of dominators of l1 by adding l1
   into l1’s strict dominators.

   To make the interface simple, ALGDOM only requires the basic properties that
   ensure that sdom is correct: it must be both sound and complete in terms of
   the declarative definitions (Definition 2). Given the correctness of sdom,
   the AlgDom_Properties module can ‘lift’ properties (conversion, transitivity,
   acyclicity, ordering, etc.) from the declarative definitions to the
   implementations of sdom and dom.

   ALGDOM requires completeness directly. Soundness can be proven by two more
   basic properties: entry_sound requires that the entry has no strict
   dominators; successors_sound requires that if l1 is a successor of l2, then
   l2’s dominators must include l1’s strict dominators. Given an algorithm that
   establishes the two properties, AlgDom_Properties proves that the algorithm
   is sound by induction over any path from the entry to l2. *)
Module Type ALGDOM.

Parameter sdom : fdef -> atom -> set atom.

Axiom dom_entrypoint : forall f l0 s0
  (Hentry : getEntryBlock f = Some (l0, s0)),
  sdom f l0 = {}.

Definition branchs_in_fdef f :=
  forall (p : l) (ps0 : phinodes) (cs0 : cmds)
         (tmn0 : terminator) (l2 : l),
  blockInFdefB (p, stmts_intro ps0 cs0 tmn0) f ->
  In l2 (successors_terminator tmn0) -> In l2 (bound_fdef f).

Axiom sdom_in_bound: forall fh bs l5,
  (sdom (fdef_intro fh bs) l5) {<=} (bound_blocks bs).

Axiom dom_successors : forall
  (l3 : l) (l' : l) f
  (contents3 contents': ListSet.set atom)
  (Hinscs : l' `in` (successors f) !!! l3)
  (Heqdefs3 : contents3 = sdom f l3)
  (Heqdefs' : contents' = sdom f l'),
  contents' {<=} (l3 {+} contents3).

Axiom sdom_is_complete: forall (f:fdef)
  (Hbinf: branchs_in_fdef f)
  (l3 : l) (l' : l) s3 s'
  (HuniqF : uniqFdef f)
  (HBinF' : blockInFdefB (l', s') f = true)
  (HBinF : blockInFdefB (l3, s3) f = true)
  (Hsdom: f |= l' >> l3),
  l' `in` (sdom f l3).

Axiom dom_unreachable: forall (f:fdef)
  (Hbinf: branchs_in_fdef f)
  (Hhasentry: getEntryBlock f <> None)
  (l3 : l) s3
  (HuniqF: uniqFdef f)
  (HBinF : blockInFdefB (l3, s3) f = true)
  (Hunreach: ~ f ~>* l3),
  sdom f l3 = bound_fdef f.

Axiom pres_sdom: forall
  (ftrans: fdef -> fdef)
  (btrans: block -> block)
  (ftrans_spec: forall fh bs,
    ftrans (fdef_intro fh bs) = fdef_intro fh (List.map btrans bs))
  (btrans_eq_label: forall b, getBlockLabel b = getBlockLabel (btrans b))
  (btrans_eq_tmn: forall b,
    terminator_match (getTerminator b) (getTerminator (btrans b)))
  (f : fdef) (l5 l0 : l),
  ListSet.set_In l5 (sdom f l0) <->
  ListSet.set_In l5 (sdom (ftrans f) l0).

End ALGDOM.

Module AlgDom_Properties(adom: ALGDOM).

Lemma entry_doms_others: forall (f:fdef)
  (Hbinf: adom.branchs_in_fdef f) (Huniq: uniqFdef f) entry
  (H: getEntryLabel f = Some entry),
  (forall b (H0: b <> entry /\ reachable f b),
     entry `in` (adom.sdom f b)).
Proof.
  intros.
  assert (Hsdom: strict_domination f entry b).
    apply DecDom.entry_doms_others; auto.
  destruct H0 as [Hneq Hreach].
  apply reachable__in_bound in Hreach; auto.
  apply In_bound_fdef__blockInFdefB in Hreach.
  destruct Hreach as [s HBinF].
  apply getEntryLabel__getEntryBlock in H.
  destruct H as [be [Hentry EQ]]; subst.
  apply entryBlockInFdef in Hentry.
  destruct be; simpl in *.
  eapply adom.sdom_is_complete; eauto.
Qed.

Lemma in_bound_dom__in_bound_fdef: forall l' f l1
  (Hin: l' `in` (adom.sdom f l1)),
  l' `in` (bound_fdef f).
Proof.
  intros. destruct f. eapply adom.sdom_in_bound; eauto.
Qed.

Section sound.

Variable f : fdef.
Hypothesis Hhasentry: getEntryBlock f <> None.

Lemma dom_is_sound : forall
  (l3 : l) (l' : l) s3
  (HBinF : blockInFdefB (l3, s3) f = true)
  (Hin : l' `in` (l3 {+} (adom.sdom f l3))),
  f |= l' >>= l3.
Proof.
  unfold domination. autounfold with cfg.
  intros. destruct f as [fh bs].
  remember (getEntryBlock (fdef_intro fh bs)) as R.
  destruct R; try congruence. clear Hhasentry.
  destruct b as [l5 s5].
  intros vl al Hreach.
  generalize dependent s3.
  remember (ACfg.vertexes (successors (fdef_intro fh bs))) as Vs.
  remember (ACfg.arcs (successors (fdef_intro fh bs))) as As.
  unfold ATree.elt, l in *.
  remember (index l3) as v0.
  remember (index l5) as v1.
  generalize dependent bs.
  generalize dependent l3.
  generalize dependent l5.
  induction Hreach; intros; subst.
    inv Heqv0. symmetry in HeqR.
    apply adom.dom_entrypoint in HeqR.
    rewrite HeqR in Hin.
    simpl in Hin. destruct Hin as [Hin | Hin]; tinv Hin; auto.

    destruct y as [a0].
    assert (exists ps0, exists cs0, exists tmn0,
      blockInFdefB (a0, stmts_intro ps0 cs0 tmn0) (fdef_intro fh bs) /\
      In l3 (successors_terminator tmn0)) as J.
      eapply successors__blockInFdefB; eauto.
    destruct J as [ps0 [cs0 [tmn0 [HBinF'' Hinsucc]]]].
    destruct (id_dec l' l3); subst; auto.
    left.
    assert (In l'
      (a0 :: (adom.sdom (fdef_intro fh bs) a0))) as J.
      assert (incl (adom.sdom (fdef_intro fh bs) l3)
                   (a0 :: (adom.sdom (fdef_intro fh bs) a0))) as Hinc.
        eapply adom.dom_successors; eauto.
      simpl in Hin. destruct Hin; try congruence.
      apply Hinc; auto.
    eapply IHHreach in J; eauto 1.
    simpl.
    destruct J as [J | J]; subst; eauto.
Qed.

Lemma sdom_is_sound : forall
  (l3 : l) (l' : l) s3
  (HBinF : blockInFdefB (l3, s3) f = true)
  (Hin : l' `in` (adom.sdom f l3)),
  f |= l' >> l3.
Proof.
  intros.
  eapply dom_is_sound with (l':=l') in HBinF; simpl; eauto.
  unfold strict_domination, domination in *.
  remember (getEntryBlock f) as R.
  destruct R; try congruence.
  destruct b as [l0 ? ? ?].
  intros vl al Hreach.
  assert (Hw':=Hreach).
  apply DWalk_to_dpath in Hreach; auto.
  destruct Hreach as [vl0 [al0 Hp]].
  destruct (id_dec l' l3); subst.
  Case "l'=l3".
    destruct (id_dec l3 l0); subst.
    SCase "l3=l0".
      symmetry in HeqR.
      apply adom.dom_entrypoint in HeqR.
      rewrite HeqR in Hin. inv Hin.
    SCase "l3<>l0".
      inv Hp; try congruence.
      destruct y as [a0].
      assert (exists ps0, exists cs0, exists tmn0,
        blockInFdefB (a0, stmts_intro ps0 cs0 tmn0) f /\
        In l3 (successors_terminator tmn0)) as J.
        eapply successors__blockInFdefB; eauto.
      destruct J as [ps0 [cs0 [tmn0 [HBinF' Hinsucc]]]].
      assert (In l3 (a0 :: (adom.sdom f a0))) as J.
        assert (incl (adom.sdom f l3) (a0 :: (adom.sdom f a0))) as Hinc.
          destruct f. eapply adom.dom_successors; eauto.
        simpl in Hin.
        apply Hinc; auto.
      eapply dom_is_sound in J; try solve [eauto 1 | congruence].
      unfold domination in J.
      rewrite <- HeqR in J.
      assert (Hw:=H).
      apply D_path_isa_walk in Hw.
      apply J in Hw.
      destruct Hw as [Hw | Hw]; subst; auto.
        apply H4 in Hw. inv Hw; try congruence.
        elimtype False. auto.
  Case "l'<>l3".
    apply HBinF in Hw'.
    split; auto. destruct Hw'; subst; auto. congruence.
Qed.

End sound.

Lemma sdom_isnt_refl : forall
  f (l3 : l) (l' : l) s3
  (Hreach : reachable f l3)
  (HBinF : blockInFdefB (l3, s3) f = true)
  (Hin : In l' (adom.sdom f l3)),
  l' <> l3.
Proof.
  intros.
  eapply sdom_is_sound in Hin; eauto using reachable_has_entry.
  unfold strict_domination, reachable in *.
  autounfold with cfg in *.
  destruct (getEntryBlock f) as [[]|]; try congruence.
  destruct Hreach as [vl [al Hreach]].
  apply Hin in Hreach. tauto.
Qed.

Definition getEntryBlock_inv f := forall
  (l3 : l)
  (l' : l)
  (ps : phinodes)
  (cs : cmds)
  (tmn : terminator)
  (HBinF : blockInFdefB (l3, stmts_intro ps cs tmn) f = true)
  (Hsucc : In l' (successors_terminator tmn)) a s0
  (H : getEntryBlock f = Some (a, s0)),
  l' <> a.

Lemma sdom_acyclic: forall f
  (HgetEntryBlock_inv : getEntryBlock_inv f)
  l1 l2 s1 s2,
  reachable f l2 ->
  blockInFdefB (l1, s1) f = true ->
  blockInFdefB (l2, s2) f = true ->
  l1 `in` (adom.sdom f l2) ->
  l2 `in` (adom.sdom f l1) ->
  l1 <> l2 ->
  False.
Proof.
  intros.
  assert (strict_domination f l1 l2) as Hdom12.
    eapply sdom_is_sound; eauto using reachable_has_entry.
  assert (strict_domination f l2 l1) as Hdom21.
    eapply sdom_is_sound; eauto using reachable_has_entry.
  eapply DecDom.dom_acyclic in Hdom12; eauto 1.
  apply Hdom12. apply DecDom.sdom_dom; auto.
Qed.

End AlgDom_Properties.

(* The analysis that create trees must ensure that generated trees are
   well-formed. *)
Module Type ALGDOM_WITH_TREE.

Include Type ALGDOM.

Parameter create_dom_tree : fdef -> option (@DTree l).

Axiom dtree_edge_iff_idom: forall (f:fdef)
  (dt: @DTree l)
  (Hcreate: create_dom_tree f = Some dt)
  (le:l) (Hentry: getEntryLabel f = Some le)
  (Hnopreds: (XATree.make_predecessors (successors f)) !!! le = nil)
  (Hwfcfg: branchs_in_fdef f)
  (Huniq: uniqFdef f),
  forall p0 ch0,
    is_dtree_edge eq_atom_dec dt p0 ch0 = true <->
      (imm_domination f p0 ch0 /\ reachable f ch0).

Axiom create_dom_tree__wf_dtree: forall (f:fdef)
  (dt: @DTree l)
  (Hcreate: create_dom_tree f = Some dt)
  (le:l) (Hentry: getEntryLabel f = Some le)
  (Hnopreds: (XATree.make_predecessors (successors f)) !!! le = nil)
  (Hwfcfg: branchs_in_fdef f)
  (Huniq: uniqFdef f),
  ADProps.wf_dtree (successors f) le eq_atom_dec dt.

End ALGDOM_WITH_TREE.


(*! Language | Compilation from typed ASTs to lowered ASTs !*)
Require Import Koika.Syntax Koika.TypedSyntaxFunctions Koika.SyntaxMacros.
Require Export Koika.Common Koika.Environments.
Require Koika.SyntaxMacros Koika.TypedSyntax Koika.LoweredSyntax.

Import PrimTyped CircuitSignatures.

Section Lowering.
  Context {pos_t var_t fn_name_t rule_name_t reg_t ext_fn_t: Type}.

  Context {R: reg_t -> type}.
  Context {Sigma: ext_fn_t -> ExternalSignature}.
  Context {REnv: Env reg_t}.

  Definition lower_R idx :=
    type_sz (R idx).
  Notation lR := lower_R.

  Definition lower_Sigma fn :=
    CSig_of_Sig (Sigma fn).
  Notation lSigma := lower_Sigma.

  Definition lower_r (r: REnv.(env_t) R)
    : REnv.(env_t) (fun idx => bits (lR idx)) :=
    map REnv (fun idx v => bits_of_value v) r.

  Definition lower_sigma (sigma: forall f, Sig_denote (Sigma f))
    : forall f, CSig_denote (lSigma f) :=
    fun f => fun bs => bits_of_value (sigma f (value_of_bits bs)).

  Notation typed_action := (TypedSyntax.action pos_t var_t fn_name_t R Sigma).
  Notation low_action := (LoweredSyntax.action pos_t var_t lR lSigma).

  Section Action.
    Definition lower_unop {sig} (fn: fn1)
               (a: low_action sig (type_sz (PrimSignatures.Sigma1 fn).(arg1Sig))):
      low_action sig (type_sz (PrimSignatures.Sigma1 fn).(retSig)) :=
      let lArg1 fn := low_action sig (type_sz (PrimSignatures.Sigma1 fn).(arg1Sig)) in
      let lRet fn := low_action sig (type_sz (PrimSignatures.Sigma1 fn).(retSig)) in
      match fn return lArg1 fn -> lRet fn with
      | Display fn => fun a => LoweredSyntax.Unop (Lowered (DisplayBits fn)) a
      | Conv tau fn => fun a =>
        match fn return lArg1 (Conv tau fn) -> lRet (Conv tau fn) with
        | Pack => fun a => a
        | Unpack => fun a => a
        | Ignore => fun a => LoweredSyntax.Unop (Lowered (IgnoreBits _)) a
        end a
      | Bits1 fn => fun a => LoweredSyntax.Unop fn a
      | Struct1 fn sig f => fun a =>
        match fn return lArg1 (Struct1 fn sig f) -> lRet (Struct1 fn sig f) with
        | GetField => fun a =>
          LoweredSyntax.Unop (GetFieldBits sig f) a
        end a
      | Array1 fn sig idx => fun a =>
        match fn return lArg1 (Array1 fn sig idx) -> lRet (Array1 fn sig idx) with
        | GetElement => fun a =>
          LoweredSyntax.Unop (GetElementBits sig idx) a
        end a
      end a.

    Definition lower_binop {sig} (fn: fn2)
               (a1: low_action sig (type_sz (PrimSignatures.Sigma2 fn).(arg1Sig)))
               (a2: low_action sig (type_sz (PrimSignatures.Sigma2 fn).(arg2Sig))):
      low_action sig (type_sz (PrimSignatures.Sigma2 fn).(retSig)) :=
      let lArg1 fn := low_action sig (type_sz (PrimSignatures.Sigma2 fn).(arg1Sig)) in
      let lArg2 fn := low_action sig (type_sz (PrimSignatures.Sigma2 fn).(arg2Sig)) in
      let lRet fn := low_action sig (type_sz (PrimSignatures.Sigma2 fn).(retSig)) in
      match fn return lArg1 fn -> lArg2 fn -> lRet fn with
      | Eq tau negate => fun a1 a2 => LoweredSyntax.Binop (EqBits (type_sz tau) negate) a1 a2
      | Bits2 fn => fun a1 a2 => LoweredSyntax.Binop fn a1 a2
      | Struct2 fn sig f => fun a1 a2 =>
        match fn return lArg1 (Struct2 fn sig f) -> lArg2 (Struct2 fn sig f) -> lRet (Struct2 fn sig f) with
        | SubstField => fun a1 a2 =>
          LoweredSyntax.Binop (SubstFieldBits sig f) a1 a2
        end a1 a2
      | Array2 fn sig idx => fun a1 a2 =>
        match fn return lArg1 (Array2 fn sig idx) -> lArg2 (Array2 fn sig idx) -> lRet (Array2 fn sig idx) with
        | SubstElement => fun a1 a2 =>
          LoweredSyntax.Binop (SubstElementBits sig idx) a1 a2
        end a1 a2
      end a1 a2.

    Definition lower_member
               {k: var_t} {tau: type} {sig}
               (m: member (k, tau) sig) :
      member (type_sz tau) (lsig_of_tsig sig) :=
      member_map _ m.

    Section Args.
      Context (lower_action:
                 forall {sig: tsig var_t} {tau}
                   (a: typed_action sig tau),
                   low_action (lsig_of_tsig sig) (type_sz tau)).

      Definition lower_args' {sig argspec}
                 (args: context (fun k_tau => typed_action sig (snd k_tau)) argspec) :=
        cmap (V' := fun sz => (var_t * low_action _ sz)%type)
             (fun k_tau => type_sz (snd k_tau))
             (fun k_tau a => ((fst k_tau), lower_action _ _ a))
             args.
    End Args.

    Fixpoint lower_action
             {sig: tsig var_t} {tau}
             (a: typed_action sig tau):
      low_action (lsig_of_tsig sig) (type_sz tau) :=
      let l {sig tau} a := @lower_action sig tau a in
      match a with
      | TypedSyntax.Fail tau =>
        LoweredSyntax.Fail (type_sz tau)
      | @TypedSyntax.Var _ _ _ _ _ _ _ _ k _ m =>
        LoweredSyntax.Var k (lower_member m)
      | TypedSyntax.Const cst =>
        LoweredSyntax.Const (bits_of_value cst)
      | TypedSyntax.Seq r1 r2 =>
        LoweredSyntax.Seq (l r1) (l r2)
      | @TypedSyntax.Assign _ _ _ _ _ _ _ _ k _ m ex =>
        LoweredSyntax.Assign k (lower_member m) (l ex)
      | TypedSyntax.Bind var ex body =>
        LoweredSyntax.Bind var (l ex) (l body)
      | TypedSyntax.If cond tbranch fbranch =>
        LoweredSyntax.If (l cond) (l tbranch) (l fbranch)
      | TypedSyntax.Read p idx =>
        LoweredSyntax.Read p idx
      | TypedSyntax.Write p idx val =>
        LoweredSyntax.Write p idx (l val)
      | TypedSyntax.Unop fn a =>
        lower_unop fn (l a)
      | TypedSyntax.Binop fn a1 a2 =>
        lower_binop fn (l a1) (l a2)
      | TypedSyntax.ExternalCall fn a =>
        LoweredSyntax.ExternalCall fn (l a)
      | TypedSyntax.InternalCall fn args body =>
        SyntaxMacros.InternalCall
          (lower_args' (@lower_action) args)
          (l body)
      | TypedSyntax.APos p a =>
        LoweredSyntax.APos p (l a)
      end.
  End Action.
End Lowering.

Notation lower_args args := (lower_args' (@lower_action _ _ _ _ _ _ _) args).

Arguments lower_R {reg_t} R idx : assert.
Arguments lower_Sigma {ext_fn_t} Sigma fn : assert.
Arguments lower_r {reg_t} {R} {REnv} r : assert.
Arguments lower_sigma {ext_fn_t} {Sigma} sigma f a : assert.


Require Import Raft.

Require Import LastAppliedLeCommitIndexInterface.
Require Import UpdateLemmas.
Require Import SpecLemmas.
Require Import CommonTheorems.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Section LastAppliedLeCommitIndex.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Ltac update_destruct :=
    match goal with
      | [ |- context [ update _ ?y _ ?x ] ] => destruct (name_eq_dec y x)
    end.

  Ltac update_destruct_hyp :=
    match goal with
      | [ _ : context [ update _ ?y _ ?x ] |- _ ] => destruct (name_eq_dec y x)
    end.

  Ltac destruct_update :=
    repeat (first [update_destruct_hyp|update_destruct]; subst; rewrite_update).

  Lemma lastApplied_le_commitIndex_appendEntries :
    raft_net_invariant_append_entries lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp handleAppendEntries_same_lastApplied.
    repeat find_rewrite.
    find_apply_lem_hyp handleAppendEntries_log_detailed.
    intuition; repeat find_rewrite; eauto;
    eapply le_trans; eauto; eauto using Max.le_max_l.
  Qed.

  Lemma lastApplied_le_commitIndex_appendEntriesReply :
    raft_net_invariant_append_entries_reply lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp handleAppendEntriesReply_same_lastApplied.
    repeat find_rewrite.
    find_copy_apply_lem_hyp handleAppendEntriesReply_same_commitIndex.
    repeat find_rewrite. eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_requestVote :
    raft_net_invariant_request_vote lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp handleRequestVote_same_lastApplied.
    repeat find_rewrite.
    find_copy_apply_lem_hyp handleRequestVote_same_commitIndex.
    repeat find_rewrite. eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_requestVoteReply :
    raft_net_invariant_request_vote_reply lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    rewrite handleRequestVoteReply_same_lastApplied.
    rewrite handleRequestVoteReply_same_commitIndex. eauto.
  Qed.

  Lemma doLeader_same_lastApplied:
    forall st (os : list raft_output) (d' : raft_data)
      (ms : list (name * msg)) (h0 : name),
      doLeader st h0 = (os, d', ms) ->
      lastApplied d' = lastApplied st.
  Proof using.
    intros.
    unfold doLeader, advanceCommitIndex in *.
    repeat break_match; simpl in *; find_inversion; auto.
  Qed.

  Lemma fold_left_max :
    forall l y z,
      (forall x, In x l ->
            y <= x) ->
      y <= z ->
      y <= fold_left max l z.
  Proof using.
    induction l; simpl in *; auto.
    intros.
    specialize (IHl y (max z a)).
    forward IHl; eauto. concludes.
    forward IHl; [eapply le_trans; eauto; eauto using Max.le_max_l|].
    concludes. auto.
  Qed.

  Lemma advanceCommitIndex_commitIndex :
    forall st h,
      commitIndex st <= commitIndex (advanceCommitIndex st h).
  Proof using.
    intros. unfold advanceCommitIndex. simpl in *.
    apply fold_left_max; auto.
    intros.
    do_in_map. subst.
    find_apply_lem_hyp filter_In.
    repeat (intuition; do_bool).
  Qed.

  Lemma doLeader_same_commitIndex :
    forall st (os : list raft_output) (d' : raft_data)
      (ms : list (name * msg)) (h0 : name),
      doLeader st h0 = (os, d', ms) ->
      commitIndex st <= commitIndex d'.
  Proof using.
    intros.
    unfold doLeader in *.
    repeat break_match; tuple_inversion; auto; eauto using advanceCommitIndex_commitIndex.
    eapply le_trans; [eapply advanceCommitIndex_commitIndex with (h := h0)|]; eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_doLeader :
    raft_net_invariant_do_leader lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    subst.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp doLeader_same_lastApplied.
    find_copy_apply_lem_hyp doLeader_same_commitIndex.
    repeat find_rewrite. eapply le_trans; [|eauto]; eauto.
  Qed.

  Lemma doGenericServer_lastApplied:
    forall (h : name)
      (st : raft_data) (out : list raft_output) (st' : raft_data)
      (ms : list (name * msg)),
      doGenericServer h st = (out, st', ms) ->
      lastApplied st' <= max (lastApplied st) (commitIndex st).
  Proof using.
    intros. unfold doGenericServer in *. break_let. find_inversion.
    simpl in *.
    break_if; simpl in *; do_bool; auto.
    - use_applyEntries_spec. subst. simpl in *.
      eauto using Max.le_max_r.
    - use_applyEntries_spec. subst. simpl in *.
      eauto using Max.le_max_l.
  Qed.

  Lemma lastApplied_le_commitIndex_doGenericServer :
    raft_net_invariant_do_generic_server lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    subst.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp doGenericServer_commitIndex.
    find_copy_apply_lem_hyp doGenericServer_lastApplied.
    repeat find_rewrite.
    erewrite Max.max_r in *; eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_clientRequest :
    raft_net_invariant_client_request lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    subst.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp handleClientRequest_commitIndex.
    find_copy_apply_lem_hyp handleClientRequest_lastApplied.
    repeat find_rewrite. eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_timeout :
    raft_net_invariant_timeout lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    subst.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp handleTimeout_commitIndex.
    find_copy_apply_lem_hyp handleTimeout_lastApplied.
    repeat find_rewrite. eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_reboot :
    raft_net_invariant_reboot lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    subst.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_state_same_packet_subset :
    raft_net_invariant_state_same_packet_subset lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    subst.
    simpl in *. repeat find_reverse_higher_order_rewrite. auto.
  Qed.

  Lemma lastApplied_le_commitIndex_init :
    raft_net_invariant_init lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    simpl in *. auto.
  Qed.

  Theorem lastApplied_le_commitIndex_invariant :
    forall net,
      raft_intermediate_reachable net ->
      lastApplied_le_commitIndex net.
  Proof using.
    intros. apply raft_net_invariant; auto.
    - apply lastApplied_le_commitIndex_init.
    - apply lastApplied_le_commitIndex_clientRequest.
    - apply lastApplied_le_commitIndex_timeout.
    - apply lastApplied_le_commitIndex_appendEntries.
    - apply lastApplied_le_commitIndex_appendEntriesReply.
    - apply lastApplied_le_commitIndex_requestVote.
    - apply lastApplied_le_commitIndex_requestVoteReply.
    - apply lastApplied_le_commitIndex_doLeader.
    - apply lastApplied_le_commitIndex_doGenericServer.
    - apply lastApplied_le_commitIndex_state_same_packet_subset.
    - apply lastApplied_le_commitIndex_reboot.
  Qed.

  Instance lalcii : lastApplied_le_commitIndex_interface.
  split. auto using lastApplied_le_commitIndex_invariant.
  Qed.

End LastAppliedLeCommitIndex.


Require Import Charge.Open.Subst.
Require Import Charge.Open.Open.
Require Import Charge.Open.Stack.
Require Import Charge.Logics.BILogic.

Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.String.
Require Import ExtLib.Data.Sum.
Require Import ExtLib.Tactics.Consider.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.Lemma.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.syms.SymEnv.
Require Import MirrorCore.syms.SymSum.
Require Import MirrorCore.Subst.FMapSubst.

Require Import Java.Logic.AssertionLogic.
Require Import Java.Logic.SpecLogic.
Require Import Java.Language.Lang.
Require Import Java.Language.Program.
Require Import Java.Semantics.OperationalSemantics.

Require Import Coq.Strings.String.
Require Import Coq.Bool.Bool.

Require Import MirrorCharge.Java.JavaType.
Require Import MirrorCharge.ModularFunc.ILogicFunc.
Require Import MirrorCharge.ModularFunc.BILogicFunc.
Require Import MirrorCharge.ModularFunc.LaterFunc.
Require Import MirrorCharge.ModularFunc.BaseFunc.
Require Import MirrorCharge.ModularFunc.ListFunc.
Require Import MirrorCharge.ModularFunc.OpenFunc.
Require Import MirrorCharge.ModularFunc.EmbedFunc.

Set Implicit Arguments.
Set Strict Implicit.

	Inductive java_func :=
	| pVal (_ : val)
	| pVarList (_ : list var)
	| pProg (_ : Program)
	| pCmd (_ : cmd)
	| pDExpr (_ : dexpr)
	| pFields (_ : list field)

	| pMethodSpec
	| pProgEq
	| pTriple
	| pTypeOf
	| pFieldLookup

	| pPointsto
	| pNull

	| pPlus
	| pMinus
	| pTimes
	| pAnd
	| pOr
	| pNot
	| pLt
	| pValEq.

	Fixpoint beq_list {A} (f : A -> A -> bool) (xs ys : list A) :=
		match xs, ys with
			| nil, nil => true
			| x::xs, y :: ys => andb (f x y) (beq_list f xs ys)
			| _, _ => false
		end.

	Definition typeof_java_func bf :=
		match bf with
		    | pVal _ => Some tyVal
		    | pVarList _ => Some tyVarList
		    | pProg _ => Some tyProg
		    | pCmd _ => Some tyCmd
		    | pDExpr _ => Some tyDExpr
		    | pFields _ => Some tyFields

		    | pMethodSpec => Some (tyArr tyString (tyArr tyString (tyArr tyVarList
		    	 (tyArr tyString (tyArr tySasn (tyArr tySasn tySpec))))))
		    | pProgEq => Some (tyArr tyProg tySpec)
		    | pTriple => Some (tyArr tySasn (tyArr tySasn (tyArr tyCmd tySpec)))

		    | pTypeOf => Some (tyArr tyString (tyArr tyVal tyProp))

		    | pFieldLookup => Some (tyArr tyProg (tyArr tyString (tyArr tyFields tyProp)))

		    | pPointsto => Some (tyArr tyVal (tyArr tyString (tyArr tyVal tyAsn)))

		    | pNull => Some tyVal

		    | pPlus => Some (tyArr tyVal (tyArr tyVal tyVal))
		    | pMinus => Some (tyArr tyVal (tyArr tyVal tyVal))
		    | pTimes => Some (tyArr tyVal (tyArr tyVal tyVal))
		    | pAnd => Some (tyArr tyVal (tyArr tyVal tyVal))
		    | pOr => Some (tyArr tyVal (tyArr tyVal tyVal))
		    | pNot => Some (tyArr tyVal tyVal)
		    | pLt => Some (tyArr tyVal (tyArr tyVal tyVal))
		    | pValEq => Some (tyArr tyVal (tyArr tyVal tyVal))
		end.

	Definition java_func_eq (a b : java_func) : option bool :=
	  match a , b with
		| pVal a, pVal b => Some (a ?[ eq ] b)
	    | pVarList a, pVarList b => Some (a ?[ eq ] b)
	    | pProg a, pProg b => Some (a ?[ eq ] b)
	    | pCmd a, pCmd b => Some (a ?[ eq ] b)
	    | pDExpr e1, pDExpr e2 => Some (e1 ?[ eq ] e2)
	    | pFields a, pFields b => Some (a ?[ eq ] b)

	    | pMethodSpec, pMethodSpec => Some true
	    | pProgEq, pProgEq => Some true
		| pTriple, pTriple => Some true

	    | pTypeOf, pTypeOf => Some true

	    | pPointsto, pPointsto => Some true
	    | pFieldLookup, pFieldLookup => Some true

	    | pNull, pNull => Some true
	    | pPlus, pPlus => Some true
	    | pMinus, pMinus => Some true
	    | pTimes, pTimes => Some true
	    | pAnd, pAnd => Some true
	    | pOr, pOr => Some true
	    | pNot, pNot => Some true
	    | pLt, pLt => Some true
	    | pValEq, pValEq => Some true
	    | _, _ => None
	  end.

    Global Instance RelDec_java_func : RelDec (@eq java_func) := {
      rel_dec a b := match java_func_eq a b with
    	  		       | Some b => b
    		 	       | None => false
    			     end
    }.

    Global Instance RelDec_Correct_ilfunc : RelDec_Correct RelDec_java_func.
    Proof.
      constructor.
      destruct x; destruct y; simpl;
      try solve [ try rewrite Bool.andb_true_iff ;
                  repeat rewrite rel_dec_correct; intuition congruence ].
    Qed.

Definition set_fold_fun (x : String.string) (f : field) (P : sasn) :=
	(`pointsto) (x/V) `f `null ** P.

  	 Definition java_func_symD bf :=
		match bf as bf return match typeof_java_func bf with
								| Some t => typD t
								| None => unit
							  end with
              | pProg p => p
              | pVal v => v
              | pVarList vs => vs
              | pCmd c => c
              | pDExpr e => e
              | pFields fs => fs

              | pMethodSpec => method_spec
              | pProgEq => prog_eq
              | pTriple => triple

              | pTypeOf => typeof

              | pFieldLookup => field_lookup

              | pPointsto => pointsto

              | pNull => null

              | pPlus => eplus
              | pMinus => eminus
              | pTimes => etimes
              | pAnd => eand
              | pOr => eor
              | pNot => enot
              | pLt => elt
              | pValEq => eeq
	end.

	Global Instance RSym_JavaFunc : SymI.RSym java_func := {
	  typeof_sym := typeof_java_func;
	  symD := java_func_symD;
	  sym_eqb := java_func_eq
	}.

	Global Instance RSymOk_JavaFunc : SymI.RSymOk RSym_JavaFunc.
	Proof.
		split; intros.
		destruct a, b; simpl; try apply I; try reflexivity.
		+ consider (v ?[ eq ] v0); intuition congruence.
		+ consider (l ?[ eq ] l0); intuition congruence.
		+ consider (p ?[ eq ] p0); intuition congruence.
		+ consider (c ?[ eq ] c0); intuition congruence.
		+ consider (d ?[ eq ] d0); intuition congruence.
		+ consider (l ?[ eq ] l0); intuition congruence.
	Qed.

Definition func := (SymEnv.func + @ilfunc typ + @bilfunc typ +
                    @base_func typ + @list_func typ + @open_func typ _ _ +
                    @embed_func typ + @later_func typ + java_func)%type.

Section MakeJavaFunc.
	Definition mkVal v : expr typ func := Inj (inr (pVal v)).
	Definition mkVarList vs : expr typ func := Inj (inr (pVarList vs)).
	Definition mkProg P : expr typ func := Inj (inr (pProg P)).
	Definition mkCmd c : expr typ func := Inj (inr (pCmd c)).
	Definition mkDExpr e : expr typ func := Inj (inr (pDExpr e)).
	Definition mkFields fs : expr typ func := Inj (inr (pFields fs)).

	Definition fMethodSpec : expr typ func := Inj (inr pMethodSpec).
	Definition fProgEq : expr typ func := Inj (inr pProgEq).
	Definition fTriple : expr typ func := Inj (inr pTriple).
	Definition fTypeOf : expr typ func := Inj (inr pTypeOf).
	Definition fFieldLookup : expr typ func := Inj (inr pFieldLookup).
	Definition fPointsto : expr typ func := Inj (inr pPointsto).
	Definition mkNull : expr typ func := Inj (inr pNull).

	Definition fPlus : expr typ func := Inj (inr pPlus).
	Definition fMinus : expr typ func := Inj (inr pMinus).
	Definition fTimes : expr typ func := Inj (inr pTimes).
	Definition fAnd : expr typ func := Inj (inr pAnd).
	Definition fOr : expr typ func := Inj (inr pOr).
	Definition fNot : expr typ func := Inj (inr pNot).
	Definition fLt : expr typ func := Inj (inr pLt).
	Definition fValEq : expr typ func := Inj (inr pValEq).

	Definition mkTriple P c Q : expr typ func := App (App (App fTriple P) Q) c.
	Definition mkFieldLookup P C f : expr typ func := App (App (App fFieldLookup P) C) f.
	Definition mkTypeOf C x : expr typ func := App (App fTypeOf C) x.
	Definition mkProgEq P := App fProgEq P.

	Definition mkExprList es :=
		(fold_right (fun (e : dexpr) (acc : expr typ func) =>
			mkCons tyExpr (mkDExpr e) acc) (mkNil tyExpr) es).

	Fixpoint evalDExpr (e : dexpr) : expr typ func :=
		match e with
			| E_val v => mkConst tyVal (mkVal v)
			| E_var x => App (fStackGet (func := expr typ func)) (mkString (func := func) x)
			| E_plus e1 e2 => mkAps fPlus ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
			| E_minus e1 e2 => mkAps fMinus ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
			| E_times e1 e2 => mkAps fTimes ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
			| E_and e1 e2 => mkAps fAnd ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
			| E_or e1 e2 => mkAps fOr ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
			| E_not e => mkAps fNot ((evalDExpr e, tyVal)::nil) tyVal
			| E_lt e1 e2 => mkAps fLt ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
			| E_eq e1 e2 => mkAps fValEq ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
		end.

End MakeJavaFunc.

Require Import Java.Examples.ListModel.

Class Environment := { java_env :> @SymEnv.functions typ _}.

Section JavaFunc.

  Context {fs : Environment}.

(* This needs to be parametric. It shouldn't be here
Definition fs : @SymEnv.functions typ _ :=
  SymEnv.from_list
  	(@SymEnv.F typ _ (tyArr tyVal (tyArr (tyList tyVal) tyAsn)) List::
  	 @SymEnv.F typ _ (tyArr tyVal (tyArr (tyList tyVal) tyAsn)) NodeList::nil).

*)
Check RSym.

  Global Instance RSym_ilfunc : RSym (@ilfunc typ) :=
	  RSym_ilfunc ilops.
  Global Instance RSym_bilfunc : RSym (@bilfunc typ) :=
	  RSym_bilfunc _ bilops.
  Global Instance RSym_embed_func : RSym (@embed_func typ) :=
	  RSym_embed_func _ eops.
  Global Instance RSym_later_func : RSym (@later_func typ) :=
	  RSym_later_func _ lops.

  Global Instance RSym_open_func : RSym (@open_func typ _ _) :=
	  @RSym_OpenFunc _ _ _ RType_typ _ _ _ _ _ _ _ _.

  Global Existing Instance RSym_sum.
  Global Existing Instance RSymOk_sum.

  Global Instance RSym_func : RSym func.
    repeat (apply RSym_sum; [|apply _]).
    apply (RSym_func java_env).
  Defined.

  Global Instance RelDec_expr : RelDec (@eq func) := _.

  Global Instance Expr_expr : ExprI.Expr _ (expr typ func) := @Expr_expr typ func _ _ _.
  Global Instance Expr_ok : @ExprI.ExprOk typ RType_typ (expr typ func) Expr_expr := ExprOk_expr.

  Require Import MirrorCore.VariablesI.
  Require Import MirrorCore.Lambda.ExprVariables.

  Global Instance ExprVar_expr : ExprVar (expr typ func) := _.
  Global Instance ExprVarOk_expr : ExprVarOk ExprVar_expr := _.

  Global Instance ExprUVar_expr : ExprUVar (expr typ func) := _.
  Global Instance ExprUVarOk_expr : ExprUVarOk ExprUVar_expr := _.

  Definition subst : Type :=
    FMapSubst.SUBST.raw (expr typ func).
  Global Instance SS : SubstI.Subst subst (expr typ func) :=
    @FMapSubst.SUBST.Subst_subst _.
  Global Instance SU : SubstI.SubstUpdate subst (expr typ func) :=
    @FMapSubst.SUBST.SubstUpdate_subst _ _.
  Global Instance SO : SubstI.SubstOk SS :=
    @FMapSubst.SUBST.SubstOk_subst typ RType_typ (expr typ func) _ _.
  Global Instance SUO :SubstI.SubstUpdateOk SU SO :=  @FMapSubst.SUBST.SubstUpdateOk_subst typ RType_typ (expr typ func) _ _ _.

  Global Instance MA : MentionsAny (expr typ func) := {
    mentionsAny := ExprCore.mentionsAny
  }.

  Global Instance MAOk : MentionsAnyOk MA _ _.
  Proof.
    admit.
  Qed.

  Lemma evalDexpr_wt (e : dexpr) :
	  typeof_expr nil nil (evalDExpr e) = Some tyExpr.
  Proof.
    induction e.
    + simpl; reflexivity.
    + simpl; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
    + simpl; rewrite IHe; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
  Qed.

  Definition is_pure (e : expr typ func) : bool :=
	match e with
	  | App f P => match embedS f with
				     | Some (eilf_embed tyPure tySasn) => true
					 | Some (eilf_embed tyProp tySasn) => true
					 | _ => false
				   end

 	  | e =>
 		match ilogicS e with
 		  | Some (ilf_true _) => true
 		  | Some (ilf_false _) => true
 		  | _ => false
 		end
   end.

  Definition mkPointstoVar x f e : expr typ func :=
     mkAp tyVal tyAsn
          (mkAp tyString (tyArr tyVal tyAsn)
                (mkAp tyVal (tyArr tyString (tyArr tyVal tyAsn))
                      (mkConst (tyArr tyVal (tyArr tyString (tyArr tyVal tyAsn)))
                               fPointsto)
                      (App fStackGet (mkString x)))
                (mkConst tyString (mkString f)))
          e.

  Definition test_lemma :=
    @lemmaD typ (expr typ func) RType_typ Expr_expr (expr typ func)
            (fun tus tvs e => exprD' tus tvs tyProp e)
            _
            nil nil.
End JavaFunc.