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 Configuration.

Require Import ITreeLang.

Require Import PromiseConsistent.
Require Import CompressSteps.

Require Import iPromotionDef.
Require Import SimCommon.
Require Import PromotionProgress.

Set Implicit Arguments.

Module SimThreadPromotion.
  Import SimCommon.
  Section TYPE.
  Variable R: Type.

  (* sim_state *)

  Inductive sim_state (l: Loc.t) (val: Const.t)
            (st_src: itree MemE.t R) (st_tgt: itree MemE.t (Const.t * R)): Prop :=
  | sim_state_intro
      (STMTS: st_tgt = promote_itree l val st_src)
  .
  Hint Constructors sim_state: core.

  (* sim_thread *)

  Definition safe (l: Loc.t) (lc: Local.t) (mem: Memory.t): Prop :=
    forall from to val released
      (GET: Memory.get l to mem = Some (from, Message.concrete val (Some released))),
      View.le released (TView.cur (Local.tview lc)).

  Inductive sim_thread (l: Loc.t) (e_src: Thread.t (lang R)) (e_tgt: Thread.t (lang (Const.t * R))): Prop :=
  | sim_thread_intro
      val
      (STATE: sim_state l val (Thread.state e_src) (Thread.state e_tgt))
      (LOCAL: sim_local l (Thread.local e_src) (Thread.local e_tgt))
      (SC: sim_timemap l (Thread.sc e_src) (Thread.sc e_tgt))
      (MEMORY: sim_memory l (Thread.memory e_src) (Thread.memory e_tgt))
      (FULFILLABLE: fulfillable l (Local.tview (Thread.local e_src)) (Thread.memory e_src)
                                  (Local.promises (Thread.local e_src)))
      (LATEST: exists from released,
          Memory.get l (Memory.max_ts l (Thread.memory e_src)) (Thread.memory e_src) =
          Some (from, Message.concrete val released))
      (PROMISES: forall to, Memory.get l to (Local.promises (Thread.local e_src)) = None)
      (SAFE: safe l (Thread.local e_src) (Thread.memory e_src))
  .
  Hint Constructors sim_thread: core.

  Inductive sim_thread_reserve (l: Loc.t) (e_src: Thread.t (lang R)) (e_tgt: Thread.t (lang (Const.t * R))): Prop :=
  | sim_thread_reserve_intro
      val
      (STATE: sim_state l val (Thread.state e_src) (Thread.state e_tgt))
      (LOCAL: sim_local l (Thread.local e_src) (Thread.local e_tgt))
      (SC: sim_timemap l (Thread.sc e_src) (Thread.sc e_tgt))
      (MEMORY: sim_memory l (Thread.memory e_src) (Thread.memory e_tgt))
      (FULFILLABLE: fulfillable l (Local.tview (Thread.local e_src)) (Thread.memory e_src)
                                  (Local.promises (Thread.local e_src)))
      (LATEST: exists from from' released,
          <<MEM: Memory.get l (Memory.max_ts l (Thread.memory e_src)) (Thread.memory e_src) =
                 Some (from, Message.reserve)>> /\
          <<PROMISE: Memory.get l (Memory.max_ts l (Thread.memory e_src)) (Local.promises (Thread.local e_src)) =
                     Some (from, Message.reserve)>> /\
          <<LATEST: Memory.get l from (Thread.memory e_src) =
                    Some (from', Message.concrete val released)>>)
      (PROMISES: forall to (TO: to <> Memory.max_ts l (Thread.memory e_src)),
          Memory.get l to (Local.promises (Thread.local e_src)) = None)
      (SAFE: safe l (Thread.local e_src) (Thread.memory e_src))
  .
  Hint Constructors sim_thread_reserve: core.

  Definition sim_thread_all (l: Loc.t): forall (e_src: Thread.t (lang R)) (e_tgt: Thread.t (lang (Const.t * R))), Prop :=
    (sim_thread l) \2/ (sim_thread_reserve l).
  Hint Unfold sim_thread_all: core.

  Lemma step_sim_thread_reserve
        l e1_src e_tgt
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (SIM1: sim_thread l e1_src e_tgt):
    exists from to e2_src,
      <<STEP: Thread.step false (ThreadEvent.promise l from to Message.reserve Memory.op_kind_add)
                          e1_src e2_src>> /\
      <<SIM2: sim_thread_reserve l e2_src e_tgt>>.
  Proof.
    destruct e1_src as [st1_src [tview1_src promises1_src] sc1_src mem1_src].
    destruct e_tgt as [st_tgt [tview_tgt promises_tgt] sc_tgt mem_tgt].
    inv SIM1. ss. des.
    dup WF1_SRC. inv WF1_SRC0. ss.
    clear TVIEW_WF TVIEW_CLOSED FINITE BOT.
    exploit (@Memory.add_exists_max_ts mem1_src l (Time.incr (Memory.max_ts l mem1_src)) Message.reserve).
    { apply Time.incr_spec. }
    { econs. }
    i. des.
    exploit Memory.add_exists_le; eauto. i. des.
    assert (MAX: Memory.max_ts l mem2 = Time.incr (Memory.max_ts l mem1_src)).
    { exploit Memory.add_get0; try exact x0. i. des.
      exploit Memory.max_ts_spec; try exact GET0. i. des.
      inv MAX; ss.
      revert GET1. erewrite Memory.add_o; eauto. condtac; ss; try by des; ss.
      guardH o. i.
      exploit Memory.max_ts_spec; try exact GET1. i. des.
      specialize (Time.incr_spec (Memory.max_ts l mem1_src)). i.
      rewrite H in H0. timetac.
    }
    esplits.
    - econs 1. econs; ss. econs; eauto.
    - econs; s; eauto.
      + inv LOCAL. econs; ss.
        etrans; eauto. econs; i.
        * revert GET_SRC. erewrite Memory.add_o; eauto. condtac; ss.
          { des. subst. ss. }
          { esplits; eauto. refl. }
        * erewrite Memory.add_o; eauto. condtac; ss.
          { des. subst. ss. }
          { esplits; eauto. refl. }
      + etrans; eauto. econs; i.
        * revert GET_SRC. erewrite Memory.add_o; eauto. condtac; ss.
          { des. subst. ss. }
          { esplits; eauto. refl. }
        * erewrite Memory.add_o; eauto. condtac; ss.
          { des. subst. ss. }
          { esplits; eauto. refl. }
      + ii. revert GETP.
        erewrite Memory.add_o; eauto. condtac; ss. i. guardH o.
        exploit FULFILLABLE; eauto. i. des. split; ss.
        unfold prev_released_le_loc in *.
        erewrite Memory.add_o; eauto. condtac; ss.
      + exploit Memory.add_get0; try exact x0. i. des.
        exploit Memory.add_get0; try exact x1. i. des.
        exploit Memory.add_get1; try exact LATEST; eauto. i.
        rewrite MAX. esplits; eauto.
      + i. rewrite MAX in *.
        erewrite Memory.add_o; eauto. condtac; ss.
        des. subst. ss.
      + ii. revert GET.
        erewrite Memory.add_o; eauto. condtac; ss; eauto.
  Qed.

  Lemma step_reserve_sim_thread
        l e1_src e_tgt
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (SIM1: sim_thread_reserve l e1_src e_tgt):
    exists from to e2_src,
      <<STEP: Thread.step true (ThreadEvent.promise l from to Message.reserve Memory.op_kind_cancel)
                          e1_src e2_src>> /\
      <<SIM2: sim_thread l e2_src e_tgt>>.
  Proof.
    destruct e1_src as [st1_src [tview1_src promises1_src] sc1_src mem1_src].
    destruct e_tgt as [st_tgt [tview_tgt promises_tgt] sc_tgt mem_tgt].
    inv SIM1. ss. des.
    dup WF1_SRC. inv WF1_SRC0. ss.
    clear TVIEW_WF TVIEW_CLOSED FINITE BOT.
    exploit (@Memory.remove_exists promises1_src l from (Memory.max_ts l mem1_src) Message.reserve); ss.
    i. des.
    exploit Memory.remove_exists_le; eauto. i. des.
    assert (MAX: Memory.max_ts l mem0 = from).
    { exploit Memory.get_ts; try exact MEM. i. des.
      { rewrite x3 in *.
        inv CLOSED1_SRC. rewrite INHABITED in *. ss. }
      exploit Memory.remove_get0; try exact x1. i. des.
      exploit Memory.remove_get1; try exact LATEST; eauto. i. des.
      { subst. timetac. }
      exploit Memory.max_ts_spec; try exact GET2. i. des.
      inv MAX; ss.
      revert GET1. erewrite Memory.remove_o; eauto. condtac; ss.
      i. des; ss.
      exploit Memory.max_ts_spec; try exact GET1. i. des.
      exploit Memory.get_ts; try exact GET1. i. des.
      { subst. rewrite x4 in *. inv H. }
      exploit Memory.get_disjoint; [exact MEM|exact GET1|..]. i. des.
      { subst. rewrite x4 in *. congr. }
      exfalso.
      apply (x4 (Memory.max_ts l mem0)); econs; ss. refl.
    }
    esplits.
    - econs. econs; ss. econs; eauto.
    - econs; s; eauto.
      + inv LOCAL. econs; ss.
        etrans; eauto. econs; i.
        * revert GET_SRC. erewrite Memory.remove_o; eauto. condtac; ss. i.
          esplits; eauto. refl.
        * erewrite Memory.remove_o; eauto. condtac; ss; try by des; ss.
          esplits; eauto. refl.
      + etrans; eauto. econs; i.
        * revert GET_SRC. erewrite Memory.remove_o; eauto. condtac; ss. i.
          esplits; eauto. refl.
        * erewrite Memory.remove_o; eauto. condtac; ss; try by des; ss.
          esplits; eauto. refl.
      + ii. revert GETP.
        erewrite Memory.remove_o; eauto. condtac; ss. i. guardH o.
        exploit FULFILLABLE; eauto. i. des. split; ss.
        unfold prev_released_le_loc in *.
        erewrite Memory.remove_o; eauto. condtac; ss.
      + rewrite MAX.
        erewrite Memory.remove_o; eauto. condtac; ss; eauto.
        des. subst. rewrite a0 in *.
        exploit Memory.get_ts; try exact MEM. i. des; timetac.
        rewrite x2 in *.
        inv CLOSED1_SRC. rewrite INHABITED in MEM. ss.
      + i. erewrite Memory.remove_o; eauto. condtac; ss.
        apply PROMISES. des; ss.
      + ii. revert GET.
        erewrite Memory.remove_o; eauto. condtac; ss; eauto.
  Qed.

  Lemma eq_loc_max_ts
        loc mem1 mem2
        (MEMLOC: forall to, Memory.get loc to mem1 = Memory.get loc to mem2):
    Memory.max_ts loc mem1 = Memory.max_ts loc mem2.
  Proof.
    unfold Memory.max_ts.
    replace (mem1 loc) with (mem2 loc); ss.
    apply Cell.ext. eauto.
  Qed.

  Lemma sim_thread_promise_step
        l e1_src
        pf e_tgt e1_tgt e2_tgt
        (SIM1: sim_thread l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (STEP_TGT: Thread.promise_step pf e_tgt e1_tgt e2_tgt):
    exists e_src e2_src,
      <<STEP_SRC: Thread.opt_promise_step e_src e1_src e2_src>> /\
      <<SIM2: sim_thread l e2_src e2_tgt>>.
  Proof.
    inversion STEP_TGT. subst.
    destruct (Loc.eq_dec loc l).
    { subst. inv LOCAL; ss.
      esplits; [econs 1|]; eauto.
      inv SIM1. ss.
      exploit promise_loc; try exact PROMISE; try apply LOCAL; eauto. i. des.
      econs; ss; eauto.
      econs; ss; eauto; try apply LOCAL.
    }
    exploit promise_step; try exact LOCAL; try apply SIM1;
      try apply WF1_SRC; try apply WF1_TGT; eauto.
    i. des.
    destruct e1_src. ss.
    esplits.
    - econs 2. econs; eauto.
    - inv SIM1. inv STEP_SRC. ss.
      econs; eauto; ss; ii.
      + erewrite Memory.promise_get_diff; eauto.
        erewrite <- eq_loc_max_ts; eauto.
        i. symmetry. eapply Memory.promise_get_diff; eauto.
      + erewrite Memory.promise_get_diff_promise; eauto.
      + erewrite Memory.promise_get_diff in GET; eauto.
  Qed.

  Lemma promote_itree_step
        l val X (i: MemE.t X) k
        st1_tgt
        e st2_tgt
        (STMTS1: sim_state l val (Vis i k) st1_tgt)
        (STEP_TGT: ILang.step (ThreadEvent.get_program_event e) st1_tgt st2_tgt)
        (NORMAL: loc_free_event l i)
    :
      exists st2_src,
        (<<STEP_SRC: ILang.step (ThreadEvent.get_program_event e) (Vis i k) st2_src>>) /\
        (<<STMTS2: sim_state l val st2_src st2_tgt>>) /\
        (<<NORMAL: ~ ThreadEvent.is_accessing_loc l e>>)
  .
  Proof.
    subst. inv STMTS1. rewrite unfold_promote_itree in *. ss. destruct i.
    - des_ifs; ss. dependent destruction STEP_TGT. esplits; eauto.
      + rewrite <- x. econs; eauto.
      + destruct e; ss; clarify.
    - des_ifs; ss. dependent destruction STEP_TGT. esplits; eauto.
      + rewrite <- x. econs; eauto.
      + destruct e; ss; clarify.
    - destruct rmw; des_ifs; ss; dependent destruction STEP_TGT.
      + esplits; eauto.
        * rewrite <- x. econs; eauto.
        * destruct e; ss; clarify.
      + esplits; eauto.
        * rewrite <- x. econs; eauto.
        * destruct e; ss; clarify.
      + esplits; eauto.
        * rewrite <- x. econs; eauto.
        * destruct e; ss; clarify.
      + esplits; eauto.
        * rewrite <- x. econs; eauto.
        * destruct e; ss; clarify.
    - des_ifs; ss. dependent destruction STEP_TGT. esplits; eauto.
      + rewrite <- x. econs; eauto.
      + destruct e; ss; clarify.
    - des_ifs; ss. dependent destruction STEP_TGT. esplits; eauto.
      + rewrite <- x. econs; eauto.
      + destruct e; ss; clarify.
    - des_ifs; ss. dependent destruction STEP_TGT. esplits; eauto.
      + rewrite <- x. econs; eauto.
      + econs. apply bisim_is_eq. ginit. gcofix CIH.
        gstep. red. cbn. econs. gbase. auto.
      + destruct e; ss; clarify.
    - des_ifs; ss. dependent destruction STEP_TGT. esplits; eauto.
      + rewrite <- x. econs; eauto.
      + destruct e; ss; clarify.
  Qed.

  Lemma sim_thread_program_step
        l e1_src
        e_tgt e1_tgt e2_tgt
        (SIM1: sim_thread l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
        (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (CLOSED1_TGT: Memory.closed (Thread.memory e1_tgt))
        (STEP_TGT: Thread.program_step e_tgt e1_tgt e2_tgt):
    exists e_src e2_src,
      <<STEP_SRC: Thread.opt_program_step e_src e1_src e2_src>> /\
      <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
      <<SIM2: sim_thread l e2_src e2_tgt>>.
  Proof.
    destruct e1_src as [stmts1_src lc1_src sc1_src mem1_src].
    destruct e1_tgt as [stmts1_tgt lc1_tgt sc1_tgt mem1_tgt].
    dup SIM1. inv SIM0. ss. inv STATE. inv STEP_TGT. des.
    ides stmts1_src.
    (* ret *)
    { rewrite unfold_promote_itree in STATE. inv STATE. }
    (* tau *)
    { rewrite unfold_promote_itree in STATE. inv STATE. inv LOCAL0; ss. esplits; eauto.
      { econs 2. econs 1; eauto. econs; eauto. }
      { ss. }
      { econs; eauto. ss. }
    }
    (* normal *)
    destruct (classic (loc_free_event l e)) as [NORMAL|PROMOTE].
    { exploit promote_itree_step; eauto. i. des.
      exploit program_step; try eapply SIM1; try exact LOCAL; eauto.
      s. i. des. esplits.
      { econs 2. econs.
        { rewrite EVENT2. eauto. }
        { eauto. }
      }
      { ss. }
      { econs; ss.
        + eauto.
        + cut (forall to, Memory.get l to mem1_src = Memory.get l to mem2_src).
          { i. hexploit eq_loc_max_ts; eauto. i.
            rewrite <- H. rewrite <- H0.
            inv SIM1. ss. eauto. }
          unfold ThreadEvent.is_accessing_loc in *.
          eapply Local.program_step_get_diff; try exact STEP_SRC0.
          rewrite ThreadEvent.eq_program_event_eq_loc; eauto.
        + i. erewrite <- Local.program_step_get_diff_promises; try exact STEP_SRC0; eauto.
          rewrite ThreadEvent.eq_program_event_eq_loc; eauto.
        + ii. exploit Local.program_step_future; try exact STEP_SRC; eauto. i. des.
          etrans; try eapply TVIEW_FUTURE.
          inv SIM1. ss. revert GET.
          unfold ThreadEvent.is_accessing_loc in *.
          erewrite <- Local.program_step_get_diff; eauto.
          rewrite ThreadEvent.eq_program_event_eq_loc; eauto.
      }
    }
    rewrite unfold_promote_itree in STATE. destruct e; ss.
    (* load *)
    { des_ifs; ss.
      inv STATE. destruct e_tgt; ss; try by inv LOCAL0.
      exploit PromotionProgress.progress_read; try eapply LATEST; eauto.
      { destruct released; eauto using View.bot_spec. }
      i. des. esplits.
      - econs 2. econs; cycle 1.
        + econs 2; eauto.
        + econs. econs.
      - ss.
      - inv LOCAL0; ss. econs; ss; eauto.
        + etrans; eauto. symmetry. ss.
        + ii. inv STEP. inv LC. ss.
          exploit FULFILLABLE; eauto.
        + inv STEP. inv LC. ss.
        + ii. etrans; try eapply SAFE; eauto.
          exploit Local.read_step_future; eauto. i. des.
          apply TVIEW_FUTURE.
    }
    (* store *)
    { des_ifs; ss.
      inv STATE. destruct e_tgt; ss; try by inv LOCAL0.
      exploit PromotionProgress.progress_write; try exact WF1_SRC; try exact SC1_SRC; eauto.
      { ss. apply View.bot_spec. }
      i. des. esplits.
      - econs 2. econs; cycle 1.
        + econs 3; eauto.
        + econs. econs.
      - ss.
      - inv LOCAL0. econs; ss; eauto.
        + etrans; eauto. symmetry. ss.
        + etrans; eauto. symmetry. ss.
        + ii. inv STEP. inv LC. ss.
          inv WRITE. inv PROMISE. revert GETP.
          erewrite Memory.remove_o; eauto. condtac; ss.
          erewrite Memory.add_o; eauto. condtac; ss. i.
          guardH o. guardH o0.
          destruct (Loc.eq_dec loc l); try by subst; congr.
          exploit FULFILLABLE; eauto. i. des. split.
          * unfold tview_released_le_loc in *.
            unfold TView.write_tview. ss.
            unfold LocFun.add. condtac; ss.
          * unfold prev_released_le_loc in *.
            erewrite Memory.add_o; eauto. condtac; ss.
            des. subst. ss.
        + inv STEP. inv WRITE. inv PROMISE. ss.
          exploit Memory.add_get0; try exact MEM0. i. des.
          replace (Memory.max_ts l mem0) with (Time.incr (Memory.max_ts l mem1_src)); eauto.
          exploit Memory.max_ts_spec; try exact GET0. i. des. inv MAX; ss.
          revert GET1. erewrite Memory.add_o; eauto. condtac; ss; try by des.
          guardH o. i.
          exploit Memory.max_ts_spec; try exact GET1. i. des.
          exploit TimeFacts.lt_le_lt; try exact H; try exact MAX. i.
          specialize (Time.incr_spec (Memory.max_ts l mem1_src)). i.
          rewrite x0 in H1. timetac.
        + exploit Local.write_step_future; eauto. i. des.
          inv STEP. inv WRITE. inv PROMISE. ss.
          ii. revert GET.
          erewrite Memory.add_o; eauto. condtac; ss; i.
          * inv GET. rewrite H3 in *. ss.
          * etrans; try eapply TVIEW_FUTURE; eauto.
    }
    { des_ifs; ss.
      (* fa *)
      { inv STATE. destruct e_tgt; ss; try by inv LOCAL0.
        exploit PromotionProgress.progress_read; try eapply LATEST; eauto.
        { destruct released; eauto using View.bot_spec. }
        i. des.
        exploit Local.read_step_future; eauto. i. des.
        exploit PromotionProgress.progress_write; try exact WF2; eauto.
        { inv STEP. ss. }
        { etrans; try eapply TVIEW_FUTURE.
          destruct released; try apply View.bot_spec.
          eapply SAFE; eauto. }
        i. des. esplits.
        - econs 2. econs; cycle 1.
          + econs 4; eauto.
          + econs; eauto. econs; eauto.
        - ss.
        - inv LOCAL0. econs; ss; eauto.
          + etrans; eauto. symmetry. etrans; eauto.
          + etrans; eauto. symmetry. ss.
          + ii. inv STEP. inv LC0. ss. inv STEP0. ss.
            inv WRITE. inv PROMISE. revert GETP.
            erewrite Memory.remove_o; eauto. condtac; ss.
            erewrite Memory.add_o; eauto. condtac; ss. i.
            guardH o. guardH o0.
            destruct (Loc.eq_dec loc l); try by subst; congr.
            exploit FULFILLABLE; eauto. i. des. split.
            * unfold tview_released_le_loc in *.
              unfold TView.write_tview. ss.
              unfold LocFun.add. condtac; ss.
            * unfold prev_released_le_loc in *.
              erewrite Memory.add_o; eauto. condtac; ss.
              des. subst. ss.
          + inv STEP0. inv WRITE. inv PROMISE. ss.
            exploit Memory.add_get0; try exact MEM0. i. des.
            replace (Memory.max_ts l mem0) with (Time.incr (Memory.max_ts l mem1_src)); eauto.
            exploit Memory.max_ts_spec; try exact GET0. i. des. inv MAX; ss.
            revert GET1. erewrite Memory.add_o; eauto. condtac; ss; try by des.
            guardH o. i.
            exploit Memory.max_ts_spec; try exact GET1. i. des.
            exploit TimeFacts.lt_le_lt; try exact H; try exact MAX. i.
            specialize (Time.incr_spec (Memory.max_ts l mem1_src)). i.
            rewrite x0 in H1. timetac.
          + exploit Local.write_step_future; eauto. i. des.
            inv STEP0. inv WRITE. inv PROMISE. ss.
            ii. revert GET.
            erewrite Memory.add_o; eauto. condtac; ss; i.
            * inv GET. rewrite H3 in *. ss.
            * etrans; try eapply TVIEW_FUTURE0.
              etrans; try eapply TVIEW_FUTURE; eauto.
      }
      (* cas success *)
      { inv STATE. destruct e_tgt; ss; try by inv LOCAL0.
        exploit PromotionProgress.progress_read; try eapply LATEST; eauto.
        { destruct released; eauto using View.bot_spec. }
        i. des.
        exploit Local.read_step_future; eauto. i. des.
        exploit PromotionProgress.progress_write; try exact WF2; eauto.
        { inv STEP. ss. }
        { etrans; try eapply TVIEW_FUTURE.
          destruct released; try apply View.bot_spec.
          eapply SAFE; eauto. }
        i. des. esplits.
        - econs 2. econs; cycle 1.
          + econs 4; eauto.
          + econs; eauto. econs 2; eauto.
            rewrite Const.eqb_sym. ii. congr.
        - ss.
        - inv LOCAL0. econs; ss; eauto.
          + etrans; eauto. symmetry. etrans; eauto.
          + etrans; eauto. symmetry. ss.
          + ii. inv STEP. inv LC0. ss. inv STEP0. ss.
            inv WRITE. inv PROMISE. revert GETP.
            erewrite Memory.remove_o; eauto. condtac; ss.
            erewrite Memory.add_o; eauto. condtac; ss. i.
            guardH o. guardH o0.
            destruct (Loc.eq_dec loc l); try by subst; congr.
            exploit FULFILLABLE; eauto. i. des. split.
            * unfold tview_released_le_loc in *.
              unfold TView.write_tview. ss.
              unfold LocFun.add. condtac; ss.
            * unfold prev_released_le_loc in *.
              erewrite Memory.add_o; eauto. condtac; ss.
              des. subst. ss.
          + inv STEP0. inv WRITE. inv PROMISE. ss.
            exploit Memory.add_get0; try exact MEM0. i. des.
            replace (Memory.max_ts l mem0) with (Time.incr (Memory.max_ts l mem1_src)); eauto.
            exploit Memory.max_ts_spec; try exact GET0. i. des. inv MAX; ss.
            revert GET1. erewrite Memory.add_o; eauto. condtac; ss; try by des.
            guardH o. i.
            exploit Memory.max_ts_spec; try exact GET1. i. des.
            exploit TimeFacts.lt_le_lt; try exact H; try exact MAX. i.
            specialize (Time.incr_spec (Memory.max_ts l mem1_src)). i.
            rewrite x0 in H1. timetac.
          + exploit Local.write_step_future; eauto. i. des.
            inv STEP0. inv WRITE. inv PROMISE. ss.
            ii. revert GET.
            erewrite Memory.add_o; eauto. condtac; ss; i.
            * inv GET. rewrite H3 in *. ss.
            * etrans; try eapply TVIEW_FUTURE0.
              etrans; try eapply TVIEW_FUTURE; eauto.
      }
      (* cas fail *)
      { inv STATE. destruct e_tgt; ss; try by inv LOCAL0.
        exploit PromotionProgress.progress_read; try eapply LATEST; eauto.
        { destruct released; eauto using View.bot_spec. }
        i. des. esplits.
        - econs 2. econs; cycle 1.
          + econs 2; eauto.
          + econs; eauto. econs 3; eauto.
            rewrite Const.eqb_sym. ii. congr.
        - ss.
        - inv LOCAL0. econs; ss; eauto.
          + etrans; eauto. symmetry. ss.
          + ii. inv STEP. inv LC. ss.
            exploit FULFILLABLE; eauto.
          + inv STEP. inv LC. ss.
          + ii. etrans; try eapply SAFE; eauto.
            exploit Local.read_step_future; eauto. i. des.
            apply TVIEW_FUTURE.
      }
      { inv STATE. destruct e_tgt; ss; try by inv LOCAL0.
        exploit PromotionProgress.progress_read; try eapply LATEST; eauto.
        { destruct released; eauto using View.bot_spec. }
        i. des. esplits.
        - econs 2. econs; cycle 1.
          + econs 2; eauto.
          + econs; eauto. econs 3; eauto.
            rewrite Const.eqb_sym. ii. congr.
        - ss.
        - inv LOCAL0. econs; ss; eauto.
          + etrans; eauto. symmetry. ss.
          + ii. inv STEP. inv LC. ss.
            exploit FULFILLABLE; eauto.
          + inv STEP. inv LC. ss.
          + ii. etrans; try eapply SAFE; eauto.
            exploit Local.read_step_future; eauto. i. des.
            apply TVIEW_FUTURE.
      }
    }
  Qed.

  Lemma sim_thread_step
        l e1_src
        pf e_tgt e1_tgt e2_tgt
        (SIM1: sim_thread l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
        (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (CLOSED1_TGT: Memory.closed (Thread.memory e1_tgt))
        (STEP_TGT: Thread.step pf e_tgt e1_tgt e2_tgt):
    exists e_src e2_src,
      <<STEP_SRC: Thread.opt_step e_src e1_src e2_src>> /\
      <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
      <<SIM2: sim_thread l e2_src e2_tgt>>.
  Proof.
    inv STEP_TGT.
    - exploit sim_thread_promise_step; eauto. i. des.
      esplits.
      + inv STEP_SRC.
        * econs 1.
        * econs 2. econs 1; eauto.
      + inv STEP. inv STEP_SRC; ss. inv STEP. ss.
      + ss.
    - exploit sim_thread_program_step; eauto. i. des.
      esplits.
      + inv STEP_SRC.
        * econs 1.
        * econs 2. econs 2; eauto.
      + ss.
      + ss.
  Qed.

  Lemma sim_thread_opt_step
        l e1_src
        e_tgt e1_tgt e2_tgt
        (SIM1: sim_thread l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
        (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (CLOSED1_TGT: Memory.closed (Thread.memory e1_tgt))
        (STEP_TGT: Thread.opt_step e_tgt e1_tgt e2_tgt):
    exists e_src e2_src,
      <<STEP_SRC: Thread.opt_step e_src e1_src e2_src>> /\
      <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
      <<SIM2: sim_thread l e2_src e2_tgt>>.
  Proof.
    inv STEP_TGT.
    - esplits; eauto. econs 1.
    - exploit sim_thread_step; eauto.
  Qed.

  Lemma sim_thread_rtc_tau_step
        l e1_src
        e1_tgt e2_tgt
        (SIM1: sim_thread l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
        (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (CLOSED1_TGT: Memory.closed (Thread.memory e1_tgt))
        (STEPS_TGT: rtc (@Thread.tau_step (lang (Const.t * R))) e1_tgt e2_tgt):
    exists e2_src,
      <<STEPS_SRC: rtc (@Thread.tau_step (lang R)) e1_src e2_src>> /\
      <<SIM2: sim_thread l e2_src e2_tgt>>.
  Proof.
    revert e1_src SIM1 WF1_SRC SC1_SRC CLOSED1_SRC.
    induction STEPS_TGT; i.
    - esplits; eauto.
    - inv H. inv TSTEP.
      exploit sim_thread_step; eauto. i. des.
      exploit Thread.step_future; try exact STEP; eauto. i. des.
      exploit Thread.opt_step_future; try exact STEP_SRC; eauto. i. des.
      exploit IHSTEPS_TGT; eauto. i. des.
      inv STEP_SRC.
      + esplits; eauto.
      + esplits; [M|..]; eauto.
        econs; [|eauto].
        econs; [econs; eauto|]. rewrite <- EVENT. ss.
  Qed.

  Lemma sim_thread_plus_step
        l e1_src
        pf e_tgt e1_tgt e2_tgt e3_tgt
        (SIM1: sim_thread l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
        (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (CLOSED1_TGT: Memory.closed (Thread.memory e1_tgt))
        (STEPS_TGT: rtc (@Thread.tau_step (lang (Const.t * R))) e1_tgt e2_tgt)
        (STEP_TGT: Thread.step pf e_tgt e2_tgt e3_tgt):
    exists e_src e2_src e3_src,
      <<STEPS_SRC: rtc (@Thread.tau_step (lang R)) e1_src e2_src>> /\
      <<STEP_SRC: Thread.opt_step e_src e2_src e3_src>> /\
      <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
      <<SIM3: sim_thread l e3_src e3_tgt>>.
  Proof.
    exploit sim_thread_rtc_tau_step; eauto. i. des.
    exploit Thread.rtc_tau_step_future; try exact STEPS_SRC; eauto. i. des.
    exploit Thread.rtc_tau_step_future; try exact STEPS_TGT; eauto. i. des.
    exploit sim_thread_step; eauto. i. des.
    esplits; eauto.
  Qed.

  Lemma sim_thread_all_plus_step
        l e1_src
        pf e_tgt e1_tgt e2_tgt e3_tgt
        (SIM1: sim_thread_all l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
        (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (CLOSED1_TGT: Memory.closed (Thread.memory e1_tgt))
        (STEPS_TGT: rtc (@Thread.tau_step (lang (Const.t * R))) e1_tgt e2_tgt)
        (STEP_TGT: Thread.step pf e_tgt e2_tgt e3_tgt)
        (EVENT: ThreadEvent.get_machine_event e_tgt <> MachineEvent.silent):
    exists e_src e2_src e3_src,
      <<STEPS_SRC: rtc (@Thread.tau_step (lang R)) e1_src e2_src>> /\
      <<STEP_SRC: Thread.step true e_src e2_src e3_src>> /\
      <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
      <<SIM3: sim_thread l e3_src e3_tgt>>.
  Proof.
    inv SIM1.
    { exploit sim_thread_plus_step; eauto. i. des.
      esplits; eauto.
      inv STEP_SRC; ss; try congr.
      destruct pf0; [|inv STEP; inv STEP0; ss; congr]. ss.
    }
    { exploit step_reserve_sim_thread; try exact H; eauto. i. des.
      exploit Thread.step_future; eauto. i. des.
      exploit sim_thread_plus_step; try exact SIM2; eauto. i. des.
      exploit Thread.rtc_tau_step_future; try exact STEPS_SRC; eauto. i. des.
      exploit Thread.opt_step_future; try exact STEP_SRC; eauto. i. des.
      inv STEP_SRC; ss; try congr.
      destruct pf0; [|inv STEP0; inv STEP1; ss; congr].
      esplits.
      - econs 2; try exact STEPS_SRC. econs; [econs; eauto|]. ss.
      - eauto.
      - ss.
      - ss.
    }
  Qed.

  Lemma sim_thread_all_plus_step_silent
        l e1_src
        pf e_tgt e1_tgt e2_tgt e3_tgt
        (SIM1: sim_thread_all l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
        (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (CLOSED1_TGT: Memory.closed (Thread.memory e1_tgt))
        (STEPS_TGT: rtc (@Thread.tau_step (lang (Const.t * R))) e1_tgt e2_tgt)
        (STEP_TGT: Thread.step pf e_tgt e2_tgt e3_tgt)
        (EVENT: ThreadEvent.get_machine_event e_tgt = MachineEvent.silent):
    exists e_src e2_src e3_src,
      <<STEPS_SRC: rtc (@Thread.tau_step (lang R)) e1_src e2_src>> /\
      <<STEP_SRC: Thread.opt_step e_src e2_src e3_src>> /\
      <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
      <<SIM3: sim_thread_reserve l e3_src e3_tgt>>.
  Proof.
    inv SIM1.
    { exploit sim_thread_plus_step; try exact SIM2; eauto. i. des.
      exploit Thread.rtc_tau_step_future; try exact STEPS_SRC; eauto. i. des.
      exploit Thread.opt_step_future; try exact STEP_SRC; eauto. i. des.
      exploit step_sim_thread_reserve; try exact SIM3; eauto. i. des.
      exploit Thread.tau_opt_tau; try exact STEPS_SRC; eauto; i.
      { rewrite EVENT0. ss. }
      esplits.
      - apply x0.
      - econs 2; eauto.
      - ss.
      - ss.
    }
    { exploit step_reserve_sim_thread; try exact H; eauto. i. des.
      exploit Thread.step_future; eauto. i. des.
      exploit sim_thread_plus_step; try exact SIM2; eauto. i. des.
      exploit Thread.rtc_tau_step_future; try exact STEPS_SRC; eauto. i. des.
      exploit Thread.opt_step_future; try exact STEP_SRC; eauto. i. des.
      exploit step_sim_thread_reserve; try exact SIM3; eauto. i. des.
      exploit Thread.tau_opt_tau; try exact STEPS_SRC; eauto; i.
      { rewrite EVENT0. ss. }
      esplits.
      - econs 2; try exact x0. econs; [econs; eauto|]. ss.
      - econs 2; eauto.
      - ss.
      - ss.
    }
  Qed.

  (* future *)

  Lemma sim_thread_future
        l
        st_src lc_src sc1_src mem1_src sc2_src mem2_src
        st_tgt lc_tgt sc1_tgt mem1_tgt sc2_tgt mem2_tgt
        (SIM1: sim_thread l
                          (Thread.mk (lang R) st_src lc_src sc1_src mem1_src)
                          (Thread.mk (lang (Const.t * R)) st_tgt lc_tgt sc1_tgt mem1_tgt))
        (WF1_SRC: Local.wf lc_src mem1_src)
        (MEM_SRC: Memory.future mem1_src mem2_src)
        (SC: sim_timemap l sc2_src sc2_tgt)
        (MEM: sim_memory l mem2_src mem2_tgt)
        (PREV: Memory.prev_None mem1_src mem2_src)
        (MEMLOC: forall to, Memory.get l to mem1_src = Memory.get l to mem2_src):
    sim_thread l
               (Thread.mk (lang R) st_src lc_src sc2_src mem2_src)
               (Thread.mk (lang (Const.t * R)) st_tgt lc_tgt sc2_tgt mem2_tgt).
  Proof.
    inv SIM1. des. ss. econs; s; eauto.
    - ii. exploit FULFILLABLE; eauto. i. des. split; ss.
      unfold prev_released_le_loc in *. des_ifs; ss.
      + exploit Memory.future_get1; try exact Heq0; eauto; ss. i. des.
        inv MSG_LE. inv RELEASED; try congr.
        rewrite Heq in *. inv GET.
        unnw. etrans; eauto. split; apply LE.
      + exploit Memory.future_get1; try exact Heq0; eauto; ss. i. des.
        inv MSG_LE. inv RELEASED; try congr.
      + exploit Memory.future_get1; try exact Heq0; eauto; ss. i. des.
        rewrite GET in *. inv Heq. inv MSG_LE.
      + inv WF1_SRC. exploit PROMISES0; eauto. i.
        exploit PREV; eauto; ss. ii. congr.
      + inv WF1_SRC. exploit PROMISES0; eauto. i.
        exploit PREV; eauto; ss. ii. congr.
    - erewrite <- eq_loc_max_ts; eauto.
      rewrite MEMLOC in *.
      esplits; eauto.
    - ii. rewrite <- MEMLOC in *. eauto.
  Qed.

  Lemma sim_thread_reserve_future
        l
        st_src lc_src sc1_src mem1_src sc2_src mem2_src
        st_tgt lc_tgt sc1_tgt mem1_tgt sc2_tgt mem2_tgt
        (SIM1: sim_thread_reserve l
                          (Thread.mk (lang R) st_src lc_src sc1_src mem1_src)
                          (Thread.mk (lang (Const.t * R)) st_tgt lc_tgt sc1_tgt mem1_tgt))
        (WF1_SRC: Local.wf lc_src mem1_src)
        (MEM_SRC: Memory.future mem1_src mem2_src)
        (SC: sim_timemap l sc2_src sc2_tgt)
        (MEM: sim_memory l mem2_src mem2_tgt)
        (PREV: Memory.prev_None mem1_src mem2_src)
        (MEMLOC: forall to, Memory.get l to mem1_src = Memory.get l to mem2_src):
    sim_thread_reserve l
               (Thread.mk (lang R) st_src lc_src sc2_src mem2_src)
               (Thread.mk (lang (Const.t * R)) st_tgt lc_tgt sc2_tgt mem2_tgt).
  Proof.
    inv SIM1. des. ss. econs; s; eauto.
    - ii. exploit FULFILLABLE; eauto. i. des. split; ss.
      unfold prev_released_le_loc in *. des_ifs; ss.
      + exploit Memory.future_get1; try exact Heq0; eauto; ss. i. des.
        inv MSG_LE. inv RELEASED; try congr.
        rewrite Heq in *. inv GET.
        unnw. etrans; eauto. split; apply LE.
      + exploit Memory.future_get1; try exact Heq0; eauto; ss. i. des.
        inv MSG_LE. inv RELEASED; try congr.
      + exploit Memory.future_get1; try exact Heq0; eauto; ss. i. des.
        rewrite GET in *. inv Heq. inv MSG_LE.
      + inv WF1_SRC. exploit PROMISES0; eauto. i.
        exploit PREV; eauto; ss. ii. congr.
      + inv WF1_SRC. exploit PROMISES0; eauto. i.
        exploit PREV; eauto; ss. ii. congr.
    - erewrite <- eq_loc_max_ts; eauto.
      rewrite MEMLOC in *.
      esplits; eauto.
    - erewrite <- eq_loc_max_ts; eauto.
    - ii. rewrite <- MEMLOC in *. eauto.
  Qed.

  Lemma sim_thread_all_future
        l
        st_src lc_src sc1_src mem1_src sc2_src mem2_src
        st_tgt lc_tgt sc1_tgt mem1_tgt sc2_tgt mem2_tgt
        (SIM1: sim_thread_all l
                          (Thread.mk (lang R) st_src lc_src sc1_src mem1_src)
                          (Thread.mk (lang (Const.t * R)) st_tgt lc_tgt sc1_tgt mem1_tgt))
        (WF1_SRC: Local.wf lc_src mem1_src)
        (MEM_SRC: Memory.future mem1_src mem2_src)
        (SC: sim_timemap l sc2_src sc2_tgt)
        (MEM: sim_memory l mem2_src mem2_tgt)
        (PREV: Memory.prev_None mem1_src mem2_src)
        (MEMLOC: forall to, Memory.get l to mem1_src = Memory.get l to mem2_src):
    sim_thread_all l
               (Thread.mk (lang R) st_src lc_src sc2_src mem2_src)
               (Thread.mk (lang (Const.t * R)) st_tgt lc_tgt sc2_tgt mem2_tgt).
  Proof.
    inv SIM1.
    - left. eapply sim_thread_future; eauto.
    - right. eapply sim_thread_reserve_future; eauto.
  Qed.

  (* terminal *)

  Lemma sim_thread_promises_bot
        l e_src e_tgt
        (SIM: sim_thread l e_src e_tgt)
        (PROMISES_TGT: (Local.promises (Thread.local e_tgt)) = Memory.bot):
    <<PROMISES_SRC: (Local.promises (Thread.local e_src)) = Memory.bot>>.
  Proof.
    inv SIM. inv LOCAL. apply Memory.ext. i.
    rewrite Memory.bot_get.
    destruct (Loc.eq_dec loc l); subst; ss.
    symmetry in PROMISES1.
    exploit sim_memory_get_None_src; eauto.
    rewrite PROMISES_TGT. rewrite Memory.bot_get. ss.
  Qed.

  Lemma sim_thread_terminal
        l e_src e_tgt
        (SIM: sim_thread l e_src e_tgt)
        (TERMINAL_TGT: (Language.is_terminal (lang _)) (Thread.state e_tgt)):
    <<TERMINAL_SRC: (Language.is_terminal (lang _)) (Thread.state e_src)>>.
  Proof.
    unfold Language.is_terminal in *. ss.
    unfold ILang.is_terminal in *.
    inv SIM.
    clear - TERMINAL_TGT STATE.
    destruct e_src, e_tgt. ss.
    inv STATE. des.
    rewrite unfold_promote_itree in *. ides state0; eauto.
    destruct e; ss; des_ifs; ss.
  Qed.

  (* certification *)

  Lemma cap_sim_thread_reserve
        l
        st_src lc_src sc_src mem_src
        st_tgt lc_tgt sc_tgt mem_tgt
        cap_src cap_tgt
        (SIM: sim_thread_reserve l
                                 (Thread.mk (lang _) st_src lc_src sc_src mem_src)
                                 (Thread.mk (lang _) st_tgt lc_tgt sc_tgt mem_tgt))
        (WF_SRC: Local.wf lc_src mem_src)
        (WF_TGT: Local.wf lc_tgt mem_tgt)
        (SC_SRC: Memory.closed_timemap sc_src mem_src)
        (CLOSED_SRC: Memory.closed mem_src)
        (CLOSED_TGT: Memory.closed mem_tgt)
        (CAP_SRC: Memory.cap mem_src cap_src)
        (CAP_TGT: Memory.cap mem_tgt cap_tgt):
    exists mem1_src,
      <<REMOVE: Memory.remove cap_src l (Memory.max_ts l mem_src)
                              (Time.incr (Memory.max_ts l mem_src)) Message.reserve mem1_src>> /\
      <<SIM: sim_thread_reserve l
                                (Thread.mk (lang _) st_src lc_src sc_src mem1_src)
                                (Thread.mk (lang _) st_tgt lc_tgt sc_tgt cap_tgt)>> /\
      <<WF_SRC: Local.wf lc_src mem1_src>> /\
      <<SC_SRC: Memory.closed_timemap sc_src mem1_src>> /\
      <<CLOSED_SRC: Memory.closed mem1_src>>.
  Proof.
    exploit sim_memory_cap; try eapply SIM; eauto. intros x. des.
    exploit (@Memory.remove_exists cap_src l (Memory.max_ts l mem_src)
                                   (Time.incr (Memory.max_ts l mem_src)) Message.reserve);
      try apply CAP_SRC.
    intros x0. des.
    assert (MAX: Memory.max_ts l mem2 = Memory.max_ts l mem_src).
    { inv SIM. ss. des.
      dup CAP_SRC. inv CAP_SRC0.
      exploit Memory.cap_max_ts; try exact CAP_SRC; eauto.
      instantiate (1 := l). intros x1.
      exploit SOUND; try exact MEM. intros x2.
      exploit Memory.remove_get1; try exact x; eauto. i. des.
      { specialize (Time.incr_spec (Memory.max_ts l mem_src)). i.
        rewrite <- LOCTS0 in *. timetac. }
      exploit Memory.max_ts_spec; try exact GET2. i. des.
      apply TimeFacts.antisym; ss.
      destruct (TimeFacts.le_lt_dec (Memory.max_ts l mem2) (Memory.max_ts l mem_src)); ss.
      exfalso.
      exploit Memory.max_ts_spec; try exact GET. i. des.
      revert GET0. erewrite Memory.remove_o; eauto. condtac; ss. des; ss. i.
      exploit Memory.cap_inv; try exact GET0; try exact CAP_SRC; eauto. i. des.
      - exploit Memory.max_ts_spec; try exact x4. i. des. timetac.
      - inv x3. exploit Memory.max_ts_spec; try exact GET3. i. des.
        exploit Memory.get_ts; try exact GET3. intros x6. des.
        { rewrite x6 in *. inv l0. }
        { exploit TimeFacts.lt_le_lt; try exact x6; try exact MAX1. i. timetac. }
      - subst. ss.
    }
    esplits; eauto.
    - inv SIM. ss. des. econs; ss; eauto.
      + inv x. econs; i.
        * revert GET_SRC.
          erewrite Memory.remove_o; eauto. condtac; ss; eauto.
        * erewrite Memory.remove_o; eauto. condtac; ss; eauto.
          des. subst. ss.
      + des. ii.
        exploit FULFILLABLE; eauto. i. des. splits; ss.
        unfold prev_released_le_loc in *. des_ifs; ss; revert Heq.
        * erewrite Memory.remove_o; eauto. condtac; ss. i. guardH o.
          exploit Memory.cap_inv; try exact CAP_SRC; eauto. i. des; congr.
        * erewrite Memory.remove_o; eauto. condtac; ss. i. guardH o.
          exploit Memory.cap_inv; try exact CAP_SRC; eauto. i. des; congr.
        * erewrite Memory.remove_o; eauto. condtac; ss. i. guardH o.
          exploit Memory.cap_inv; try exact CAP_SRC; eauto. i. des; congr.
        * erewrite Memory.remove_o; eauto. condtac; ss. i. guardH o.
          exploit Memory.cap_inv; try exact CAP_SRC; eauto. i. des; congr.
        * erewrite Memory.remove_o; eauto. condtac; ss. i. guardH o.
          exploit Memory.cap_inv; try exact CAP_SRC; eauto. i. des; congr.
      + rewrite MAX. inv CAP_SRC.
        exploit SOUND; try exact MEM. i.
        exploit Memory.remove_get1; try exact x; eauto. i. des.
        { specialize (Time.incr_spec (Memory.max_ts l mem_src)). i.
          rewrite <- LOCTS0 in *. timetac. }
        esplits; eauto.
        instantiate (1 := released).
        instantiate (1 := from').
        erewrite Memory.remove_o; eauto. condtac; ss; eauto.
        des. subst.
        exploit Memory.get_ts; try exact MEM. i. des.
        * specialize (Time.incr_spec (Memory.max_ts l mem_src)). i.
          rewrite x3 in H. inv H.
        * specialize (Time.incr_spec (Memory.max_ts l mem_src)). i.
          rewrite x3 in H. timetac.
      + i. rewrite MAX in *. eauto.
      + ii. revert GET.
        erewrite Memory.remove_o; eauto. condtac; ss. des; ss. i.
        exploit Memory.cap_inv; try exact GET; try exact CAP_SRC; eauto. i. des; ss.
        eapply SAFE; eauto.
    - exploit Local.cap_wf; try exact CAP_SRC; eauto. i.
      inv x2. econs; ii; eauto.
      + inv TVIEW_CLOSED.
        econs; i; eauto using Memory.cancel_closed_view.
      + inv WF_SRC. exploit PROMISES0; eauto. intros x1.
        erewrite Memory.remove_o; eauto. condtac; ss; cycle 1.
        { apply CAP_SRC. ss. }
        des. subst.
        exploit Memory.max_ts_spec; try exact x1. i. des.
        specialize (Time.incr_spec (Memory.max_ts l mem_src)). i.
        exploit TimeFacts.le_lt_lt; try exact MAX0; try exact H. i. timetac.
    - hexploit Memory.cap_closed_timemap; try exact CAP_SRC; eauto. i.
      eapply Memory.cancel_closed_timemap; eauto.
    - exploit Memory.cap_closed; try exact CAP_SRC; eauto. i.
      eapply Memory.cancel_closed; eauto.
  Qed.

  Lemma cap_sim_thread
        l e_src e_tgt
        cap_src cap_tgt
        (SIM: sim_thread_reserve l e_src e_tgt)
        (WF_SRC: Local.wf (Thread.local e_src) (Thread.memory e_src))
        (WF_TGT: Local.wf (Thread.local e_tgt) (Thread.memory e_tgt))
        (SC_SRC: Memory.closed_timemap (Thread.sc e_src) (Thread.memory e_src))
        (SC_TGT: Memory.closed_timemap (Thread.sc e_tgt) (Thread.memory e_tgt))
        (CLOSED_SRC: Memory.closed (Thread.memory e_src))
        (CLOSED_TGT: Memory.closed (Thread.memory e_tgt))
        (CAP_SRC: Memory.cap (Thread.memory e_src) cap_src)
        (CAP_TGT: Memory.cap (Thread.memory e_tgt) cap_tgt):
    exists from e2_src mem_src,
      <<STEP: Thread.step true (ThreadEvent.promise l from (Memory.max_ts l (Thread.memory e_src)) Message.reserve Memory.op_kind_cancel)
                          (Thread.mk (lang _) (Thread.state e_src) (Thread.local e_src) (Thread.sc e_src) cap_src) e2_src>> /\
      <<SPACE: CompressSteps.spatial_mem (Thread.memory e2_src) mem_src>> /\
      <<SIM: sim_thread l
                        (Thread.mk (lang _) (Thread.state e2_src) (Thread.local e2_src) (Thread.sc e2_src) mem_src)
                        (Thread.mk (lang _) (Thread.state e_tgt) (Thread.local e_tgt) (Thread.sc e_tgt) cap_tgt)>> /\
      <<WF_SRC: Local.wf (Thread.local e2_src) mem_src>> /\
      <<SC_SRC: Memory.closed_timemap (Thread.sc e2_src) mem_src>> /\
      <<MEM_SRC: Memory.closed mem_src>>.
  Proof.
    destruct e_src as [st1_src lc1_src sc1_src mem1_src].
    destruct e_tgt as [st1_tgt lc1_tgt sc1_tgt mem1_tgt].
    ss.
    exploit cap_sim_thread_reserve; eauto. i. des.
    exploit step_reserve_sim_thread; try exact SIM0; eauto. i. des.
    assert (to = Memory.max_ts l mem1_src); subst.
    { inv SIM. ss. des.
      inv STEP; inv STEP0; inv LOCAL; inv LOCAL0. inv PROMISE0.
      exploit Memory.remove_get0; try exact PROMISES0. i. des.
      destruct (Time.eq_dec to (Memory.max_ts l mem1_src)); ss.
      exploit PROMISES; eauto. i. congr.
    }
    destruct e2_src as [st2_src lc2_src sc2_src mem2_src]. ss.
    cut (exists mem'_src,
            <<STEP': Thread.step true (ThreadEvent.promise l from (Memory.max_ts l mem1_src) Message.reserve Memory.op_kind_cancel)
                                 (Thread.mk (lang _) st1_src lc1_src sc1_src cap_src)
                                 (Thread.mk (lang _) st1_src lc2_src sc2_src mem'_src)>> /\
            <<SPACE: CompressSteps.spatial_mem mem'_src mem2_src>>).
    { i. des.
      exploit Thread.step_future; try exact STEP; eauto. s. i. des.
      inv STEP; inv STEP0; inv LOCAL. ss.
      esplits; try exact STEP'; eauto.
    }
    inv SIM. ss. des. dup CAP_SRC. inv CAP_SRC0.
    inv STEP; inv STEP0; inv LOCAL0. inv PROMISE0. ss.
    replace from0 with from in *; cycle 1.
    { exploit SOUND; try exact MEM. intros x.
      exploit Memory.remove_get0; try exact MEM0. i. des.
      revert GET. erewrite Memory.remove_o; eauto. condtac; ss. i.
      rewrite GET in *. inv x. ss. }
    exploit (@Memory.remove_exists cap_src l from (Memory.max_ts l mem1_src) Message.reserve).
    { exploit SOUND; try exact MEM. ss. }
    i. des. exists mem2. split.
    - econs 1. econs; eauto.
    - move MEM0 at bottom. move REMOVE at bottom.
      exploit (@Memory.add_exists mem2_src l (Memory.max_ts l mem1_src)
                                  (Time.incr (Memory.max_ts l mem1_src)) Message.reserve).
      { ii. revert GET2.
        erewrite Memory.remove_o; eauto. condtac; ss.
        erewrite Memory.remove_o; eauto. condtac; ss.
        i. des; ss.
        exploit Memory.remove_get0; try exact REMOVE. i. des.
        exploit Memory.get_disjoint; [exact GET2|exact GET|..]. i. des; eauto. }
      { apply Time.incr_spec. }
      { econs. }
      i. des.
      cut (mem2 = mem0).
      { i. subst. econs; eauto.
        destruct (TimeFacts.le_lt_dec (Memory.max_ts l mem1_src) (Memory.max_ts l mem2_src)); ss.
        inv CLOSED_SRC0. clear CLOSED0.
        specialize (INHABITED l).
        exploit Memory.remove_get1; try exact INHABITED; eauto. i. des.
        { rewrite <- LOCTS0 in *.
          inv CLOSED_SRC. rewrite INHABITED0 in *. congr. }
        exploit Memory.max_ts_spec; try exact GET2. i. des.
        revert GET.
        erewrite Memory.remove_o; eauto. condtac; ss.
        erewrite Memory.remove_o; eauto. condtac; ss.
        des; ss. i.
        exploit Memory.cap_inv; try exact GET; try exact CAP_SRC; eauto. i. des.
        - exploit Memory.max_ts_spec; try exact x2. i. des.
          exploit TimeFacts.antisym; [exact l0|exact MAX0|..]. i. congr.
        - inv x3. exploit Memory.get_ts; try exact GET0. i. des.
          + subst. rewrite x3 in *. inv x4.
          + exploit Memory.max_ts_spec; try exact GET0. i. des.
            rewrite l0 in MAX0.
            exploit TimeFacts.lt_le_lt; try exact x3; try exact MAX0. i. timetac.
        - subst. rewrite x4 in *. ss.
      }
      apply Memory.ext. i.
      erewrite Memory.remove_o; eauto. condtac; ss.
      + des. subst.
        erewrite Memory.add_o; eauto. condtac; ss.
        * des. specialize (Time.incr_spec (Memory.max_ts l mem1_src)). i.
          rewrite <- a0 in *. timetac.
        * des; ss.
          exploit Memory.remove_get0; try exact MEM0. i. des. ss.
      + erewrite (@Memory.add_o mem0); eauto. condtac; ss.
        * des; ss. subst.
          exploit Memory.remove_get0; try exact REMOVE. i. des. ss.
        * erewrite (@Memory.remove_o mem2_src); eauto. condtac; ss.
          erewrite (@Memory.remove_o mem1_src0); eauto. condtac; ss.
  Qed.

  Lemma sim_thread_reserve_consistent
        l e_src e_tgt
        (SIM: sim_thread_reserve l e_src e_tgt)
        (WF_SRC: Local.wf (Thread.local e_src) (Thread.memory e_src))
        (WF_TGT: Local.wf (Thread.local e_tgt) (Thread.memory e_tgt))
        (SC_SRC: Memory.closed_timemap (Thread.sc e_src) (Thread.memory e_src))
        (SC_TGT: Memory.closed_timemap (Thread.sc e_tgt) (Thread.memory e_tgt))
        (CLOSED_SRC: Memory.closed (Thread.memory e_src))
        (CLOSED_TGT: Memory.closed (Thread.memory e_tgt))
        (CONSISTENT_TGT: Thread.consistent e_tgt):
    <<CONSISTENT_SRC: Thread.consistent e_src>>.
  Proof.
    exploit Memory.cap_exists; try exact CLOSED_TGT. i. des.
    exploit Memory.cap_closed; eauto. i.
    ii. rename mem1 into cap_src, mem2 into cap_tgt.
    exploit Local.cap_wf; try exact WF_SRC; eauto. intro WF_CAP_SRC.
    exploit Local.cap_wf; try exact WF_TGT; eauto. intro WF_CAP_TGT.
    hexploit Memory.cap_closed_timemap; try exact SC_SRC; eauto. intro SC_CAP_SRC.
    hexploit Memory.cap_closed_timemap; try exact SC_TGT; eauto. intro SC_CAP_TGT.
    exploit Memory.cap_closed; try exact CAP0; eauto. i.
    exploit cap_sim_thread; try exact SIM; eauto. i. des.
    exploit Thread.step_future; try exact STEP; eauto. s. i. des.
    exploit CONSISTENT_TGT; eauto. i. des.
    - left. unfold Thread.steps_failure in *. des.
      exploit sim_thread_plus_step; try exact STEPS; eauto. s. i. des.
      exploit (@CompressSteps.compress_steps_failure
                 (lang _) e2_src
                 (Thread.mk (lang _) (Thread.state e2_src) (Thread.local e2_src) (Thread.sc e2_src) mem_src)); eauto.
      { econs; eauto. }
      { unfold Thread.steps_failure.
        inv STEP_SRC; ss; try congr.
        destruct pf; try by inv STEP0; inv STEP1; ss; congr.
        esplits; eauto. congr.
      }
      unfold Thread.steps_failure. i. des.
      esplits; try exact STEP_FAILURE0; ss.
      econs 2.
      + econs; [econs; exact STEP|]. ss.
      + ss.
    - right.
      exploit sim_thread_rtc_tau_step; try exact STEPS; eauto. i. des.
      exploit (@CompressSteps.compress_steps_fulfill
                 (lang _) e2_src
                 (Thread.mk (lang _) (Thread.state e2_src) (Thread.local e2_src) (Thread.sc e2_src) mem_src)); eauto.
      { econs; eauto. }
      { inv SIM2. apply Memory.ext. i.
        rewrite Memory.bot_get.
        destruct (Loc.eq_dec loc l); subst; ss.
        inv LOCAL. eapply sim_memory_get_None_tgt; eauto.
        rewrite PROMISES. apply Memory.bot_get.
      }
      i. des.
      esplits; [|exact PROMISES_SRC].
      econs 2.
      + econs; [econs; exact STEP|]. ss.
      + ss.
  Qed.
  End TYPE.
End SimThreadPromotion.


Require MirrorCore.Lambda.TypedFoldLazy.

Set Implicit Arguments.
Set Strict Implicit.

Definition typed_mfold_lazy
           (typ : Set) (typD : list Type -> typ -> Type) (func : Set)
           (_ : SymI.RSym typD func)
           (_ : TypesI2.Typ2 typD PreFun.Fun)
           (ts : list Type)
           (T : Type)
       (do_var : ExprCore.var -> typ -> TypedFoldLazy.Lazy T)
       (do_uvar : ExprCore.uvar -> typ -> TypedFoldLazy.Lazy T)
       (do_inj : func -> typ -> TypedFoldLazy.Lazy T)
       (do_app : list typ -> list typ -> typ -> typ ->
                 TypedFoldLazy.Lazy T -> TypedFoldLazy.Lazy T -> TypedFoldLazy.Lazy T)
       (do_abs : list typ -> list typ -> typ -> typ ->
                 TypedFoldLazy.Lazy T -> TypedFoldLazy.Lazy T)
       (tus tvs : list typ) (t : typ) (e : ExprCore.expr typ func)
: option T :=
  @TypedFoldLazy.typed_mfold_cpsL typ typD func _ _ ts T
                                  do_var do_uvar do_inj do_app do_abs
                                  (option T) tus tvs t e
                                  (fun x => x tt)
                                  None.

Definition typed_mfold_infer_lazy
           (typ : Type) (typD : list Type -> typ -> Type) (func : Type)
           (_ : SymI.RSym typD func)
           (_ : TypesI2.Typ2 typD PreFun.Fun)
           (ts : list Type)
           (T : Type)
       (do_var : ExprCore.var -> typ -> TypedFoldLazy.Lazy T)
       (do_uvar : ExprCore.uvar -> typ -> TypedFoldLazy.Lazy T)
       (do_inj : func -> typ -> TypedFoldLazy.Lazy T)
       (do_app : list typ -> list typ -> typ -> typ ->
                 TypedFoldLazy.Lazy T -> TypedFoldLazy.Lazy T -> TypedFoldLazy.Lazy T)
       (do_abs : list typ -> list typ -> typ -> typ ->
                 TypedFoldLazy.Lazy T -> TypedFoldLazy.Lazy T)
       (tus tvs : list typ) (e : ExprCore.expr typ func)
: option (typ * T) :=
  @TypedFoldLazy.typed_mfold_infer_cpsL typ typD func _ _ ts T
                                  do_var do_uvar do_inj do_app do_abs
                                  (option (typ * T)) tus tvs e
                                  (fun t x => match x tt with
                                                | None => None
                                                | Some val => Some (t,val)
                                              end)
                                  None.


From mathcomp Require Import
     all_ssreflect
     finmap.

Require Import Relations.

From PoS_NSB Require Import
     Network
     Protocol
     GlobalState
     Blocks
     Messages
     MessageTuple
     Parameters
     BlockTree
     LocalState
     StateMonad.

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

(** * Schedule
      This file contains the semantics for an execution of the protocol.
**)

Definition upd_local (p: Party) (l: LocalState) (N: GlobalState) : GlobalState :=
  N[[state_map := setf (state_map N) p l ]].

(** Handy functions for using the network functionality to broadcast
    several messages. **)
Definition flood_msgs (msgs : Messages) (N : GlobalState) : GlobalState :=
  foldr flood_msg N msgs.

Definition flood_msgs_adv (msgs : seq (Message * DelayMap)) (N : GlobalState) : GlobalState :=
  foldr (fun ' (m , ϕ) => flood_msg_adv m ϕ) N msgs.

(** Our development is parameterised by a map deciding the honesty of
    parties. **)
Parameter CorruptionStatus : Party -> Honesty.

(** The adversary is modelled as two functions:
    1) Decides how the adversary acts when baking.
    2) Decides how the adversary acts when recieving
       messages. *)
Parameter AdversarialBake:
  Slot ->
  History ->
  MessagePool ->
  State AdversarialState (seq (Message * DelayMap)).

Parameter AdversarialRcv:
  Messages ->
  Slot ->
  History ->
  MessagePool ->
  State AdversarialState (seq (Message * DelayMap)).

(** We translate the map of honesty a boolean value. **)
Definition is_corrupt p : bool := CorruptionStatus p == Corrupt.
Definition is_honest p : bool := CorruptionStatus p == Honest.

(** If the party is honest an honest step is taken with the correct
    messages. Otherwise will the [AdversarialStep] function be called with
    the correct inputs and the world updated accordingly to this.  **)
Definition party_bake_step_world (p : Party) (N : GlobalState) : GlobalState :=
  if (state_map N).[? p] is Some l
  then if ~~(is_corrupt p)
       then let '(n_msgs, new_ls) := honest_bake (t_now N) l
            in flood_msgs n_msgs (upd_local p new_ls N)
       else let '(n_msgs, adv_state') := AdversarialBake (t_now N) (history N) (msg_buff N) (adv_state N)
            in (flood_msgs_adv n_msgs N)[[adv_state := adv_state']]
  else N.

(** If the party is honest he calls the honest recieve functions.
    Otherwise the [AdversarialRcv] function.  **)
Definition party_rcv_step_world (p : Party) (N : GlobalState) : GlobalState :=
  if (state_map N).[? p] is Some l
  then let '(msgs, N') := fetch_msgs p N in
       if ~~(is_corrupt p)
       then let '(_, new_ls) := honest_rcv msgs (t_now N') l
            in (upd_local p new_ls N')
       else let '(n_msgs, adv_state') := AdversarialRcv msgs (t_now N') (history N') (msg_buff N') (adv_state N')
            in (flood_msgs_adv n_msgs N')[[adv_state := adv_state']]
  else N.

Definition inc_round (N : GlobalState) : GlobalState :=
  N[[t_now := S (t_now N)]].

(** ** Definition: Related states **)

Reserved Notation "A ⤳ B" (at level 80, no associativity).

Notation "N '@' p" := (progress N = p) (at level 20).

Inductive SingleStep: GlobalState -> GlobalState -> Prop :=
(* Delivering messages to all parties *)
| Deliver : forall N, N @ Ready -> N ⤳
                 (foldr party_rcv_step_world N (exec_order N))[[progress := Delivered]]
(* Executing all party concurrenctly *)
| Bake : forall N, N @ Delivered -> N ⤳
              (foldr party_bake_step_world N (exec_order N))[[progress := Baked]]
(* When messages are delivered and  *)
| NextRound : forall N, N @ Baked -> N ⤳ (inc_round (round_tick N))[[progress := Ready]]
(* Permuting parties leads to related states *)
| PermParties : forall N ps, perm_eq (exec_order N) ps -> N ⤳ N[[exec_order := ps]]
(* Permuting message buffer leads to related states  *)
| PermMsgs : forall N mb, perm_eq (msg_buff N) mb -> N ⤳ N[[msg_buff := mb]]
where "N ⤳ N'" := (SingleStep N N').

(** BigStep semantics are just the reflexive transitive closure of the
    SingleStep relation **)
Definition BigStep (N N' : GlobalState) := clos_refl_trans_n1 GlobalState SingleStep N N'.

Notation "N '⇓' N'" := (BigStep N N') (at level 20).
Notation "N '⇓[' s ']' N'" := (N ⇓ N' /\ (s + t_now N) = (t_now N')) (at level 20).
Notation "N '⇓^+' N'" := (N ⇓ N' /\ t_now N < t_now N') (at level 20).


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents_tacs.
(*Require Import rules_pertype2.*)
Require Export subst_tacs.
Require Export cequiv_tacs.
Require Export tactics2.
Require Export per_props_per.
Require Export rwper.
Require Export list. (* why *)

(* begin hide *)

Lemma unfold_mk_iper_function_rel2 {o} :
  forall A B : @NTerm o,
    {va, vb, vf, vg, vx : NVar
     $ mk_iper_function_rel A B
       = mk_lam vf (mk_lam vg (mk_per_function_base va vb vf vg vx A B))
     # (va, vb, vf, vg, vx) = newvars5 [A, B] }.
Proof.
  apply unfold_mk_iper_function_rel.
Qed.

Lemma equality_in_iper_function {o} :
  forall lib f g A B w s c,
    @equality o lib f g (lsubstc (mk_iper_function A B) w s c)
    -> {wa : wf_term A
        , {wb : wf_term B
        , {ca : cover_vars A s
        , {cb : cover_vars B s
        , let cA := lsubstc A wa s ca in
          let cB := lsubstc B wb s cb in
          type lib cA
          # forall a a',
              equality lib a a' cA
              -> equality lib (mkc_apply f a) (mkc_apply g a') (mkc_apply cB a)
                 # tequality lib (mkc_apply cB a) (mkc_apply cB a')}}}}.
Proof.
  introv eq.

  assert (wf_term A)
    as wA by (dup w as w'; apply wf_term_mk_iper_function in w'; sp).
  assert (wf_term B)
    as wB by (dup w as w'; apply wf_term_mk_iper_function in w'; sp).

  assert (cover_vars A s)
    as cA by (dup c as c'; apply cover_vars_iper_function in c'; sp).
  assert (cover_vars B s)
    as cB by (dup c as c'; apply cover_vars_iper_function in c'; sp).

  exists wA wB cA cB; cbv zeta.

  unfold mk_iper_function in eq.
  lsubst_tac.
  rwpers.
  generalize (unfold_mk_iper_function_rel2 A B); intro e; exrepnd.
  apply newvars5_prop2 in e0; simpl in e0;
  repeat (rw app_nil_r in e0); repeat (rw in_app_iff in e0);
  repeat (rw not_over_or in e0); repnd.

  revert dependent eq0.
  revert dependent w1.
  revert dependent c1.
  rw e1; introv isper ty inh.
  lsubst_tac.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac; auto).
  unfold mk_per_function_base in inh.
  lsubst_tac.
  unfold inhabited_type in inh; exrepnd.
  rwpers.

  dands.

  generalize (inh0 mkc_axiom mkc_axiom); intro k.
  autodimp k hyp; repnd.
  rwpers; auto.
  repeat substc_lsubstc_vars3; lsubst_tac.
  rwpers.
  generalize (k0 mkc_axiom mkc_axiom); intro j.
  autodimp j hyp; repnd.
  rwpers; auto.
  repeat substc_lsubstc_vars3; lsubst_tac.
  rwpers.

  introv ea.
  generalize (inh0 a a); clear inh0; intro k.
  autodimp k hyp; repnd.
  rwpers.
  clear k.
  repeat substc_lsubstc_vars3; lsubst_tac.
  rwpers.
  generalize (k0 a' a'); clear k0; intro eq.
  autodimp eq hyp; repnd.
  rwpers.
  clear eq.
  repeat substc_lsubstc_vars3; lsubst_tac.
  rwpers.
  generalize (eq0 mkc_axiom mkc_axiom); clear eq0; intro eq'.
  autodimp eq' hyp; repnd.
  rwpers.
  clear eq'.
  repeat substc_lsubstc_vars3; lsubst_tac.
  apply equality_in_uand_implies in eq'0; exrepnd.
  lsubst_tac.
  rwpers; repnd; dands; auto.
  apply inhabited_implies_tequality in eq'0.
  rw @tequality_iff_mkc_tequality in eq'0; auto.
Qed.

Lemma tequality_mk_iper_function_implies {o} :
  forall lib A B w s1 s2 c1 c2,
    @tequality o lib (lsubstc (mk_iper_function A B) w s1 c1)
              (lsubstc (mk_iper_function A B) w s2 c2)
    -> {wa : wf_term A
        , {wb : wf_term B
        , {ca1 : cover_vars A s1
        , {ca2 : cover_vars A s2
        , {cb1 : cover_vars B s1
        , {cb2 : cover_vars B s2
        , let A1 := lsubstc A wa s1 ca1 in
          let A2 := lsubstc A wa s2 ca2 in
          let B1 := lsubstc B wb s1 cb1 in
          let B2 := lsubstc B wb s2 cb2 in
          tequality lib A1 A2
          # forall a1 a2,
              equality lib a1 a2 A1
              -> tequality lib (mkc_apply B1 a1) (mkc_apply B2 a2)}}}}}}.
Proof.
  introv teq.

  assert (wf_term A)
    as wA by (dup w as w'; apply wf_term_mk_iper_function in w'; sp).
  assert (wf_term B)
    as wB by (dup w as w'; apply wf_term_mk_iper_function in w'; sp).

  assert (cover_vars A s1)
    as cA1 by (dup c1 as c'; apply cover_vars_iper_function in c'; sp).
  assert (cover_vars B s1)
    as cB1 by (dup c1 as c'; apply cover_vars_iper_function in c'; sp).
  assert (cover_vars A s2)
    as cA2 by (dup c2 as c'; apply cover_vars_iper_function in c'; sp).
  assert (cover_vars B s2)
    as cB2 by (dup c2 as c'; apply cover_vars_iper_function in c'; sp).

  exists wA wB cA1 cA2 cB1 cB2; cbv zeta.

  unfold mk_iper_function in teq.
  lsubst_tac.
  rwpers.
  generalize (unfold_mk_iper_function_rel2 A B); intro e; exrepnd.
  apply newvars5_prop2 in e0; simpl in e0;
  repeat (rw app_nil_r in e0); repeat (rw in_app_iff in e0);
  repeat (rw not_over_or in e0); repnd.

  revert dependent teq0.
  revert dependent w1.
  revert dependent c0.
  revert dependent c3.
  rw e1; introv isper teq.
  lsubst_tac.

  generalize (teq mkc_axiom mkc_axiom); clear teq; intro teq.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac; auto).
  unfold mk_per_function_base in teq.
  lsubst_tac.
  rwpers.

  dands.

  generalize (teq mkc_axiom mkc_axiom); clear teq; intro teq.
  autodimp teq hyp.
  rwpers.
  repeat substc_lsubstc_vars3; lsubst_tac; auto; rwpers.
  generalize (teq mkc_axiom mkc_axiom); clear teq; intro teq.
  autodimp teq hyp.
  rwpers.
  repeat substc_lsubstc_vars3; lsubst_tac; auto; rwpers; repnd; auto.

  introv ea.
  generalize (teq a1 a1); clear teq; intro teq.
  autodimp teq hyp.
  rwpers.
  repeat substc_lsubstc_vars3; lsubst_tac; auto; rwpers.
  generalize (teq a2 a2); clear teq; intro teq.
  autodimp teq hyp.
  rwpers.
  repeat substc_lsubstc_vars3; lsubst_tac; auto; rwpers; repnd; auto.
  generalize (teq mkc_axiom mkc_axiom); clear teq; intro teq.
  autodimp teq hyp.
  rwpers.
  repeat substc_lsubstc_vars3.
  apply tequality_uand_implies in teq; exrepnd.
  clear teq3.
  lsubst_tac.
  rw @tequality_mkc_tequality in teq4; repnd.
  apply tequality_trans with (t2 := mkc_apply (lsubstc B wB s1 cB1) a2); auto.
Qed.

(* end hide *)

(* [29] ============ IPER-FUNCTION ELIMINATION ============ *)

  (*
   H, f : iper-function(A,B), J |- C ext e[z\axiom]

     By iperFunctionElimination s y z

     H, f : iper-function(A,B), J |- a in A
     H, f : iper-function(A,B), J, z : (f a) in (B a) |- C ext e
 *)
Definition rule_iper_function_elimination {o}
           (A B C a e : NTerm)
           (f z : NVar)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_bseq
       (snoc H (mk_hyp f (mk_iper_function A B)) ++ J)
       (mk_concl C (subst e z mk_axiom)))
    [ mk_bseq
        (snoc H (mk_hyp f (mk_iper_function A B)) ++ J)
        (mk_conclax (mk_member a A)),
      mk_bseq
        (snoc (snoc H (mk_hyp f (mk_iper_function A B)) ++ J)
              (mk_hyp z (mk_member (mk_apply (mk_var f) a) (mk_apply B a))))
        (mk_concl C e)
    ]
    [sarg_term a, sarg_var z].

Lemma rule_iper_function_elimination_true {o} :
  forall lib (A B C a e : NTerm),
  forall f z : NVar,
  forall H J : @barehypotheses o,
    rule_true lib (rule_iper_function_elimination
                 A B C a e
                 f z
                 H J).
Proof.
  unfold rule_iper_function_elimination, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  assert (covered
            (subst e z mk_axiom)
            (nh_vars_hyps (snoc H (mk_hyp f (mk_iper_function A B)) ++ J))) as cv.
  (* begin proof of assert *)
  clear hyp1 hyp2.
  dwfseq.
  intros.
  generalize (isprogram_lsubst2 e [(z,mk_axiom)]); simpl; intro k.
  dest_imp k hyp; sp; cpx.
  unfold subst in X; rw k in X; clear k.
  rw in_remove_nvars in X; simpl in X; sp.
  apply not_over_or in X; sp.
  generalize (ce x); sp.
  allrw in_app_iff; allrw in_snoc; sp.
  allrw in_app_iff; allrw in_snoc; sp.
  (* end proof of assert *)

  exists cv.

  (* We prove some simple facts on our sequents *)
  assert (!LIn f (vars_hyps H)
          # !LIn f (vars_hyps J)
          # !LIn z (vars_hyps H)
          # !LIn z (vars_hyps J)
          # !(z = f)
          # !LIn f (free_vars (mk_iper_function_rel A B))
          # disjoint (free_vars (mk_iper_function_rel A B)) (vars_hyps J)
          # !LIn z (free_vars C)) as vhyps.

  clear hyp1 hyp2.
  remember (mk_iper_function A B) as pf.
  remember (mk_iper_function_rel A B) as pfr.
  dwfseq.
  subst.
  allrw @free_vars_mk_iper_function.
  allrw @free_vars_iper_function_rel_eq.
  sp;
    try (complete (allunfold @disjoint; introv k; discover; allrw in_app_iff; sp));
    try (complete (discover; repeat (first [ progress (allrw in_app_iff) | progress (allrw in_snoc) ]); sp));
    try (complete (unfold disjoint; unfold disjoint in wfh11; introv i; discover; sp)).

  destruct vhyps as [ nifH vhyps ].
  destruct vhyps as [ nifJ vhyps ].
  destruct vhyps as [ nizH vhyps ].
  destruct vhyps as [ nizJ vhyps ].
  destruct vhyps as [ nezf vhyps ].
  destruct vhyps as [ nifFR vhyps ].
  destruct vhyps as [ disjFRJ nizC ].
  (* done with proving these simple facts *)

  (* The following is used by lsubst_tac to clean some substitutions *)
  assert (!LIn f (free_vars (mk_iper_function_rel A B))) as nffrel.
  (* begin proof of assert *)
  clear hyp1 hyp2.
  allapply @vswf_hypotheses_nil_implies.
  rw @wf_hypotheses_app in wfh; destruct wfh as [wfha wfhb].
  rw @wf_hypotheses_snoc in wfha; destruct wfha as [isp wfha].
  destruct wfha as [ni wfh]; simphyps.
  rw @isprog_vars_eq in isp; destruct isp as [sv ntwf].
  intro k; rw subvars_prop in sv.
  rw <- @free_vars_mk_iper_function in k.
  apply sv in k; sp.
  (* end proof of assert *)

  assert (!LIn z (free_vars (subst e z mk_axiom))) as nizs.
  (* begin proof of assert *)
  unfold subst.
  rw @isprogram_lsubst2; try (complete (simpl; sp; cpx)).
  rw in_remove_nvars; simpl; sp.
  (* end proof of assert *)

  assert (disjoint (free_vars A) (vars_hyps J))
    as disjAJ
      by (allrw @free_vars_iper_function_rel_eq; allrw disjoint_app_l; sp).

  assert (disjoint (free_vars B) (vars_hyps J))
    as disjBJ
      by (allrw @free_vars_iper_function_rel_eq; allrw disjoint_app_l; sp).

  assert (!LIn f (free_vars A))
    as nifA
      by (allrw @free_vars_iper_function_rel_eq; allrw in_app_iff; sp).

  assert (!LIn f (free_vars B))
    as nifB
      by (allrw @free_vars_iper_function_rel_eq; allrw in_app_iff; sp).

  vr_seq_true.

  dup sim as simapp.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  rw @similarity_snoc in sim5; simpl in sim5; exrepnd; subst; cpx.

  apply equality_in_iper_function in sim2; exrepnd; cbv zeta in sim2; repnd.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc (snoc s1a0 (f, t1) ++ s1b) (z, mkc_axiom))
                   (snoc (snoc s2a0 (f, t2) ++ s2b) (z, mkc_axiom)));
    clear hyp2; intros hyp2.
  repeat (autodimp hyp2 h); exrepnd.

  (* hyps_functionality *)

  generalize (hyps_functionality_snoc
                lib (snoc H (mk_hyp f (mk_iper_function A B)) ++ J)
                (mk_hyp z (mk_member (mk_apply (mk_var f) a) (mk_apply B a)))
                (snoc s1a0 (f, t1) ++ s1b)
                mkc_axiom); simpl; intro k.
  apply k; try (complete auto); clear k.
  introv eq sim; GC; lsubst_tac.
  rw @tequality_mkc_member.
  apply equality_refl in eq.
  rw <- @member_member_iff in eq.

  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s1a0 (f, t1) ++ s1b) s'); clear hyp1; intros hyp1.
  repeat (autodimp hyp1 h); exrepnd.
  lsubst_tac.
  rw @member_eq in hyp1.
  rw <- @member_member_iff in hyp1.
  rw @tequality_mkc_member in hyp0; repnd.

  assert (equality lib (lsubstc a w2 (snoc s1a0 (f, t1) ++ s1b) c2)
                   (lsubstc a w2 s' c4)
                   (lsubstc A wa s1a0 ca)) as eqa.
  sp.
  unfold member in hyp1.
  spcast; apply @equality_respects_cequivc_right with (t2 := lsubstc a w2 (snoc s1a0 (f, t1) ++ s1b) c2); sp.
  clear hyp0.

  applydup sim2 in eqa.

  duplicate sim as sim'.
  apply eqh in sim'.

  rw @eq_hyps_app in sim'; simpl in sim'; exrepnd; subst; cpx.
  apply app_split in sim'0; repnd; allrw length_snoc;
  try (complete (allrw; sp)); subst; cpx.

  rw @eq_hyps_snoc in sim'5; simpl in sim'5; exrepnd; subst; cpx.
  lsubst_tac.

  apply tequality_mk_iper_function_implies in sim'0; exrepnd;
  cbv zeta in sim'0; repnd; proof_irr; GC.

  applydup sim'0 in eqa as teq.

  split; try (complete auto).

  rw @similarity_app in sim; simpl in sim; exrepnd; subst; inj.
  allrw length_snoc.
  apply app_split in sim5; repnd; allrw length_snoc; try (complete (allrw; sp)); subst; inj.
  apply app_split in sim8; repnd; allrw length_snoc; try (complete (allrw; sp)); subst; inj.
  allrw length_snoc; inj; GC.
  rw @similarity_snoc in sim11; simpl in sim11; exrepnd; subst; inj.
  apply equality_in_iper_function in sim8; exrepnd; cbv zeta in sim8; repnd; proof_irr; GC.
  applydup sim8 in eqa as eqf; repnd.

  split; try (complete (left; auto)).

  split; intro m; try (complete auto).
  apply equality_sym in eqf0.
  apply equality_refl in eqf0.
  allunfold @member.
  apply @tequality_preserving_equality with (A := mkc_apply (lsubstc B wb s1a0 cb)
                                                           (lsubstc a w2 (snoc s1a0 (f, t1) ++ s1b) c2)); sp.

  (* similarity *)

  assert (wf_term (mk_member (mk_apply (mk_var f) a) (mk_apply B a))) as wm.
  clear hyp1.
  apply wf_member; sp; try (apply wf_apply; sp); apply wf_member_iff in wfct1; sp.

  assert (cover_vars (mk_member (mk_apply (mk_var f) a) (mk_apply B a))
                     (snoc s1a0 (f, t1) ++ s1b)) as cm.
  (* end proof of assert *)
  apply cover_vars_member; sp; apply cover_vars_apply; sp.
  apply cover_vars_var.
  rw @dom_csub_app; rw @dom_csub_snoc; rw in_app_iff; rw in_snoc; simpl; sp.
  dup ct0 as cvm.
  apply covered_iff_cover_vars with (s := snoc s1a0 (f, t1) ++ s1b) in cvm.
  rw @cover_vars_member in cvm; sp.
  rw @dom_csub_app; rw @dom_csub_snoc; rw @vars_hyps_app; rw @vars_hyps_snoc; simpl.
  allapply @similarity_dom; repnd; allrw; rw @vars_hyps_substitute_hyps; sp.
  apply cover_vars_app_weak; apply cover_vars_snoc_weak; auto.
  dup ct0 as cvm.
  apply covered_iff_cover_vars with (s := snoc s1a0 (f, t1) ++ s1b) in cvm.
  rw @cover_vars_member in cvm; sp.
  rw @dom_csub_app; rw @dom_csub_snoc; rw @vars_hyps_app; rw @vars_hyps_snoc; simpl.
  allapply @similarity_dom; repnd; allrw; rw @vars_hyps_substitute_hyps; sp.
  (* end proof of assert *)

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (f, t1) ++ s1b)
         (snoc s2a0 (f, t2) ++ s2b)
         (@mkc_axiom o) (@mkc_axiom o)
         wm cm; sp.
  lsubst_tac.
  rw @member_eq.
  rw <- @member_member_iff.

  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s1a0 (f, t1) ++ s1b)
                   (snoc s2a0 (f, t2) ++ s2b));
    clear hyp1; intros hyp1.
  repeat (autodimp hyp1 h); exrepnd.
  lsubst_tac.
  rw @member_eq in hyp1.
  rw <- @member_member_iff in hyp1.
  rw @tequality_mkc_member in hyp0; repnd.
  unfold member in hyp1.
  apply sim2 in hyp1; repnd; auto.
  apply equality_refl in hyp4; auto.

  (* conclusion *)

  lsubst_tac; sp.

  assert (lsubstc e wfce0 (snoc (snoc s1a0 (f, t1) ++ s1b) (z, mkc_axiom)) pt0
          = lsubstc (subst e z mk_axiom) wfce (snoc s1a0 (f, t1) ++ s1b) pt1) as eq1.
  apply lsubstc_eq_if_csubst.
  rw <- @csubst_swap.
  rw cons_as_app.
  rw <- @csubst_app.
  unfold csubst, subst; simpl; sp.
  rw @dom_csub_app; rw @dom_csub_snoc; simpl; rw in_app_iff; rw in_snoc.
  insub.

  assert (lsubstc e wfce0 (snoc (snoc s2a0 (f, t2) ++ s2b) (z, mkc_axiom)) pt3
          = lsubstc (subst e z mk_axiom) wfce (snoc s2a0 (f, t2) ++ s2b) pt2) as eq2.
  apply lsubstc_eq_if_csubst.
  rw <- @csubst_swap.
  rw cons_as_app.
  rw <- @csubst_app.
  unfold csubst, subst; simpl; sp.
  rw @dom_csub_app; rw @dom_csub_snoc; simpl; rw in_app_iff; rw in_snoc.
  insub.

  rw eq1 in hyp2; rw eq2 in hyp2; sp.
Qed.

(* begin hide *)


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

(** RTL function inlining *)

Require Import Coqlib.
Require Import Wfsimpl.
Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Op.
Require Import Registers.
Require Import RTL.

(** ** Environment of inlinable functions *)

(** We maintain a mapping from function names to their definitions.
  In this mapping, we only include internal functions that are eligible for
  inlining, as determined by the external heuristic
  [should_inline]. *)

Definition funenv : Type := PTree.t function.

Definition size_fenv (fenv: funenv) := PTree_Properties.cardinal fenv.

Parameter should_inline: ident -> function -> bool.

(** [CompCertX:test-compcert-void-symbols] We now allow a symbol to be
associated to no variable or function. *)

Definition add_globdef (fenv: funenv) (idg: ident * option (globdef fundef unit)) : funenv :=
  match idg with
  | (id, Some (Gfun (Internal f))) =>
      if should_inline id f
      then PTree.set id f fenv
      else PTree.remove id fenv
  | (id, _) =>
      PTree.remove id fenv
  end.

Definition funenv_program (p: program) : funenv :=
  List.fold_left add_globdef p.(prog_defs) (PTree.empty function).

(** State monad *)

(** To construct incrementally the CFG of a function after inlining,
  we use a state monad similar to that used in module [RTLgen].
  It records the current state of the CFG, plus counters to generate
  fresh pseudo-registers and fresh CFG nodes.  It also records the
  stack size needed for the inlined function. *)

Record state : Type := mkstate {
  st_nextreg: positive;                 (**r last used pseudo-register *)
  st_nextnode: positive;                (**r last used CFG node *)
  st_code: code;                        (**r current CFG  *)
  st_stksize: Z                         (**r current stack size *)
}.

(** Monotone evolution of the state. *)

Inductive sincr (s1 s2: state) : Prop :=
  Sincr (NEXTREG: Ple s1.(st_nextreg) s2.(st_nextreg))
        (NEXTNODE: Ple s1.(st_nextnode) s2.(st_nextnode))
        (STKSIZE: s1.(st_stksize) <= s2.(st_stksize)).

Remark sincr_refl: forall s, sincr s s.
Proof.
  intros; constructor; xomega.
Qed.

Lemma sincr_trans: forall s1 s2 s3, sincr s1 s2 -> sincr s2 s3 -> sincr s1 s3.
Proof.
  intros. inv H; inv H0. constructor; xomega.
Qed.

(** Dependently-typed state monad, ensuring that the final state is
  greater or equal (in the sense of predicate [sincr] above) than
  the initial state. *)

Inductive res {A: Type} {s: state}: Type := R (x: A) (s': state) (I: sincr s s').

Definition mon (A: Type) : Type := forall (s: state), @res A s.

(** Operations on this monad. *)

Definition ret {A: Type} (x: A): mon A :=
  fun s => R x s (sincr_refl s).

Definition bind {A B: Type} (x: mon A) (f: A -> mon B): mon B :=
  fun s1 => match x s1 with R vx s2 I1 =>
              match f vx s2 with R vy s3 I2 =>
                R vy s3 (sincr_trans s1 s2 s3 I1 I2)
              end
            end.

Notation "'do' X <- A ; B" := (bind A (fun X => B))
   (at level 200, X ident, A at level 100, B at level 200).

Definition initstate :=
  mkstate 1%positive 1%positive (PTree.empty instruction) 0.

Program Definition set_instr (pc: node) (i: instruction): mon unit :=
  fun s =>
    R tt
      (mkstate s.(st_nextreg) s.(st_nextnode) (PTree.set pc i s.(st_code)) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition add_instr (i: instruction): mon node :=
  fun s =>
    let pc := s.(st_nextnode) in
    R pc
      (mkstate s.(st_nextreg) (Psucc pc) (PTree.set pc i s.(st_code)) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition reserve_nodes (numnodes: positive): mon positive :=
  fun s =>
    R s.(st_nextnode)
      (mkstate s.(st_nextreg) (Pplus s.(st_nextnode) numnodes) s.(st_code) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition reserve_regs (numregs: positive): mon positive :=
  fun s =>
    R s.(st_nextreg)
      (mkstate (Pplus s.(st_nextreg) numregs) s.(st_nextnode) s.(st_code) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition request_stack (sz: Z): mon unit :=
  fun s =>
    R tt
      (mkstate s.(st_nextreg) s.(st_nextnode) s.(st_code) (Zmax s.(st_stksize) sz))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition ptree_mfold {A: Type} (f: positive -> A -> mon unit) (t: PTree.t A): mon unit :=
  fun s =>
    R tt
      (PTree.fold (fun s1 k v => match f k v s1 return _ with R _ s2 _ => s2 end) t s)
      _.
Next Obligation.
  apply PTree_Properties.fold_rec.
  auto.
  apply sincr_refl.
  intros. destruct (f k v a). eapply sincr_trans; eauto.
Qed.

(** ** Inlining contexts *)

(** A context describes how to insert the CFG for a source function into
  the CFG for the function after inlining:
- a source instruction at PC [n] is relocated to PC [n + ctx.(dpc)];
- all pseudo-registers of this instruction are shifted by [ctx.(dreg)];
- all stack references are shifted by [ctx.(dstk)];
- "return" instructions are transformed into "return" or "move" instructions
  as governed by [ctx.(retinfo)].
*)

Record context: Type := mkcontext {
  dpc: positive;                        (**r offset for PCs *)
  dreg: positive;                       (**r offset for pseudo-regs *)
  dstk: Z;                              (**r offset for stack references *)
  mreg: positive;                       (**r max pseudo-reg number *)
  mstk: Z;                              (**r original stack block size *)
  retinfo: option(node * reg)           (**r where to branch on return *)
                                        (**r and deposit return value *)
}.

(** The following functions "shift" (relocate) PCs, registers, operations, etc. *)

Definition shiftpos (p amount: positive) := Ppred (Pplus p amount).

Definition spc (ctx: context) (pc: node) := shiftpos pc ctx.(dpc).

Definition sreg (ctx: context) (r: reg) := shiftpos r ctx.(dreg).

Definition sregs (ctx: context) (rl: list reg) := List.map (sreg ctx) rl.

Definition sros (ctx: context) (ros: reg + ident) := sum_left_map (sreg ctx) ros.

Definition sop (ctx: context) (op: operation) :=
  shift_stack_operation (Int.repr ctx.(dstk)) op.

Definition saddr (ctx: context) (addr: addressing) :=
  shift_stack_addressing (Int.repr ctx.(dstk)) addr.

(** The initial context, used to copy the CFG of a toplevel function. *)

Definition initcontext (dpc dreg nreg: positive) (sz: Z) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := 0;
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := None |}.

(** The context used to inline a call to another function. *)

Definition min_alignment (sz: Z) :=
  if zle sz 1 then 1
  else if zle sz 2 then 2
  else if zle sz 4 then 4 else 8.

Definition callcontext (ctx: context)
                      (dpc dreg nreg: positive) (sz: Z)
                      (retpc: node) (retreg: reg) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := align (ctx.(dstk) + ctx.(mstk)) (min_alignment sz);
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := Some (spc ctx retpc, sreg ctx retreg) |}.

(** The context used to inline a tail call to another function. *)

Definition tailcontext (ctx: context) (dpc dreg nreg: positive) (sz: Z) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := align ctx.(dstk) (min_alignment sz);
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := ctx.(retinfo) |}.

(** ** Recursive expansion and copying of a CFG *)

(** Insert "move" instructions to copy the arguments of an inlined
    function into its parameters. *)

Fixpoint add_moves (srcs dsts: list reg) (succ: node): mon node :=
  match srcs, dsts with
  | s1 :: sl, d1 :: dl =>
      do n <- add_instr (Iop Omove (s1 :: nil) d1 succ);
      add_moves sl dl n
  | _, _ =>
      ret succ
  end.

(** To prevent infinite inlining of a recursive function, when we
  inline the body of a function [f], this function is removed from the
  environment of inlinable functions and therefore becomes ineligible
  for inlining.  This decreases the size (number of entries) of the
  environment and guarantees termination.  Inlining is, therefore,
  presented as a well-founded recursion over the size of the environment. *)

Section EXPAND_CFG.

Variable fenv: funenv.

(** The [rec] parameter is the recursor: [rec fenv' P ctx f] copies
  the body of function [f], with inline expansion within, as governed
  by context [ctx].  It can only be called for function environments
  [fenv'] strictly smaller than the current environment [fenv]. *)

Variable rec: forall fenv', (size_fenv fenv' < size_fenv fenv)%nat -> context -> function -> mon unit.

(** Given a register-or-symbol [ros], can we inline the corresponding call? *)

Inductive inline_decision (ros: reg + ident) : Type :=
  | Cannot_inline
  | Can_inline (id: ident) (f: function) (P: ros = inr reg id) (Q: fenv!id = Some f).

Program Definition can_inline (ros: reg + ident): inline_decision ros :=
  match ros with
  | inl r => Cannot_inline _
  | inr id => match fenv!id with Some f => Can_inline _ id f _ _ | None => Cannot_inline _ end
  end.

(** Inlining of a call to function [f].  An appropriate context is
  created, then the CFG of [f] is recursively copied, then moves
  are inserted to copy the arguments of the call to the parameters of [f]. *)

Definition inline_function (ctx: context) (id: ident) (f: function)
                           (P: PTree.get id fenv = Some f)
                           (args: list reg)
                           (retpc: node) (retreg: reg) : mon node :=
  let npc := max_pc_function f in
  let nreg := max_reg_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx' := callcontext ctx dpc dreg nreg f.(fn_stacksize) retpc retreg in
  do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f;
  add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)).

(** Inlining of a tail call to function [f].  Similar to [inline_function],
  but the new context is different. *)

Definition inline_tail_function (ctx: context) (id: ident) (f: function)
                               (P: PTree.get id fenv = Some f)
                               (args: list reg): mon node :=
  let npc := max_pc_function f in
  let nreg := max_reg_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx' := tailcontext ctx dpc dreg nreg f.(fn_stacksize) in
  do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f;
  add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)).

(** The instruction generated for a [Ireturn] instruction found in an
  inlined function body. *)

Definition inline_return (ctx: context) (or: option reg) (retinfo: node * reg) :=
  match retinfo, or with
  | (retpc, retreg), Some r => Iop Omove (sreg ctx r :: nil) retreg retpc
  | (retpc, retreg), None   => Inop retpc
  end.

(** Expansion and copying of an instruction.  For most instructions,
  its registers and successor PC are shifted as per the context [ctx],
  then the instruction is inserted in the final CFG at its final position
  [spc ctx pc].

  [Icall] instructions are either replaced by a "goto" to the expansion
  of the called function, or shifted as described above.

  [Itailcall] instructions are similar, with one additional case.  If
  the [Itailcall] occurs in the body of an inlined function, and
  cannot be inlined itself, it must be turned into an [Icall]
  instruction that branches to the return point of the inlined
  function.

  Finally, [Ireturn] instructions within an inlined function are
  turned into a "move" or "goto" that stores the result, if any,
  into the destination register, then branches back to the successor
  of the inlined call. *)

Definition expand_instr (ctx: context) (pc: node) (i: instruction): mon unit :=
  match i with
  | Inop s =>
      set_instr (spc ctx pc) (Inop (spc ctx s))
  | Iop op args res s =>
      set_instr (spc ctx pc)
                (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s))
  | Iload chunk addr args dst s =>
      set_instr (spc ctx pc)
                (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx dst) (spc ctx s))
  | Istore chunk addr args src s =>
      set_instr (spc ctx pc)
                (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s))
  | Icall sg ros args res s =>
      match can_inline ros with
      | Cannot_inline =>
          set_instr (spc ctx pc)
                    (Icall sg (sros ctx ros) (sregs ctx args) (sreg ctx res) (spc ctx s))
      | Can_inline id f P Q =>
          do n <- inline_function ctx id f Q args s res;
          set_instr (spc ctx pc) (Inop n)
      end
  | Itailcall sg ros args =>
      match can_inline ros with
      | Cannot_inline =>
          match ctx.(retinfo) with
          | None =>
              set_instr (spc ctx pc)
                        (Itailcall sg (sros ctx ros) (sregs ctx args))
          | Some(rpc, rreg) =>
              set_instr (spc ctx pc)
                        (Icall sg (sros ctx ros) (sregs ctx args) rreg rpc)
          end
      | Can_inline id f P Q =>
          do n <- inline_tail_function ctx id f Q args;
          set_instr (spc ctx pc) (Inop n)
      end
  | Ibuiltin ef args res s =>
      set_instr (spc ctx pc)
                (Ibuiltin ef (sregs ctx args) (sreg ctx res) (spc ctx s))
  | Icond cond args s1 s2 =>
      set_instr (spc ctx pc)
                (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2))
  | Ijumptable r tbl =>
      set_instr (spc ctx pc)
                (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl))
  | Ireturn or =>
      match ctx.(retinfo) with
      | None =>
          set_instr (spc ctx pc) (Ireturn (option_map (sreg ctx) or))
      | Some rinfo =>
          set_instr (spc ctx pc) (inline_return ctx or rinfo)
      end
  end.

(** The expansion of a function [f] iteratively expands all its
  instructions, after recording how much stack it needs. *)

Definition expand_cfg_rec (ctx: context) (f: function): mon unit :=
  do x <- request_stack (ctx.(dstk) + ctx.(mstk));
  ptree_mfold (expand_instr ctx) f.(fn_code).

End EXPAND_CFG.

(** Here we "tie the knot" of the recursion, taking the fixpoint
  of [expand_cfg_rec]. *)

Definition expand_cfg := Fixm size_fenv expand_cfg_rec.

(** Start of the recursion: copy and inline function [f] in the
  initial context. *)

Definition expand_function (fenv: funenv) (f: function): mon context :=
  let npc := max_pc_function f in
  let nreg := max_reg_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx := initcontext dpc dreg nreg f.(fn_stacksize) in
  do x <- expand_cfg fenv ctx f;
  ret ctx.

(** ** Inlining in functions and whole programs. *)

Local Open Scope string_scope.

(** Inlining can increase the size of the function's stack block.  We must
  make sure that the new size does not exceed [Int.max_unsigned], otherwise
  address computations within the stack would overflow and produce incorrect
  results. *)

Definition transf_function (fenv: funenv) (f: function) : Errors.res function :=
  let '(R ctx s _) := expand_function fenv f initstate in
  if zlt s.(st_stksize) Int.max_unsigned then
    OK (mkfunction f.(fn_sig)
                   (sregs ctx f.(fn_params))
                   s.(st_stksize)
                   s.(st_code)
                   (spc ctx f.(fn_entrypoint)))
  else
    Error(msg "Inlining: stack too big").

Definition transf_fundef (fenv: funenv) (fd: fundef) : Errors.res fundef :=
  AST.transf_partial_fundef (transf_function fenv) fd.

Definition transf_program (p: program): Errors.res program :=
  let fenv := funenv_program p in
  AST.transform_partial_program (transf_fundef fenv) p.