Set Warnings "-notation-overridden".
Set Warnings "-duplicate-clear".
Set Warnings "-spurious-ssr-injection".

Require Import Coq.Strings.String.
Require Import LinearScan.Lib.
Require Import LinearScan.UsePos.
Require Import LinearScan.Range.
Require Import LinearScan.Interval.
Require Import LinearScan.ScanState.
Require Import LinearScan.Spec.
Require Import LinearScan.Morph.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Generalizable All Variables.

Section Spill.

Variable maxReg : nat.          (* max number of registers *)
Definition PhysReg := 'I_maxReg.

Inductive SpillCondition (sd : ScanStateDesc maxReg) (uid : IntervalId sd)
  (i : IntervalSig) :=
  | NewToHandled : SpillCondition uid i
  | UnhandledToHandled :
      vnth (intervals sd) uid = i -> SpillCondition uid i
  | ActiveToHandled xid reg   :
      vnth (intervals sd) xid = i ->
      (xid, reg) \in active sd    -> SpillCondition uid i
  | InactiveToHandled xid reg :
      vnth (intervals sd) xid = i ->
      (xid, reg) \in inactive sd -> SpillCondition uid i.

Definition SpillConditionToT `(x : @SpillCondition sd uid i) :=
  match x with
  | NewToHandled                  => NewToHandledT uid
  | UnhandledToHandled _          => UnhandledToHandledT uid
  | ActiveToHandled xid reg _ _   => ActiveToHandledT xid reg
  | InactiveToHandled xid reg _ _ => InactiveToHandledT xid reg
  end.

Tactic Notation "SpillCondition_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "NewToHandled"
  | Case_aux c "UnhandledToHandled"
  | Case_aux c "ActiveToHandled"
  | Case_aux c "InactiveToHandled"
  ].

(* Determine the optimal split position between an absolute lower bound
   (anything lower and we cannot insert the split interval onto the unhandled
   list for reprocessing) and an absolute upper bound (anything higher is not
   valid according to the algorithm). Anything in between is fair game. *)
Program Definition optimalSplitPosition `(i : Interval d) (lb ub : nat) :
  nat := ub.

Theorem optimalSplitPosition_spec `(i : Interval d) (lb ub : nat) :
  optimalSplitPosition i lb ub <= ub.
Proof. by []. Qed.

Lemma widen_fst_inj : forall a n, injective (@widen_fst n a).
Proof.
  move=> a n.
  rewrite /injective => [[[x1a H1] x1b] [[x2a H2] x2b]].
  invert.
  congr (_, _).
  rewrite H0 in H1 *.
  congr (Ordinal _).
  exact: eq_irrelevance.
Qed.

Definition spillInterval `(st : ScanState InUse sd)
  (i1 : IntervalSig) `(Hunh : unhandled sd = (uid, beg) :: us)
  (Hbeg : beg <= ibeg i1.1) (spill : SpillCondition uid i1) (e : seq SSTrace) :
  seq SSTrace +
    { ss : ScanStateSig maxReg InUse
    | if spill is UnhandledToHandled _
      then if firstUseReqReg i1.2 is Some _
           then SSMorphLen sd ss.1
           else SSMorph sd ss.1
      else SSMorphHasLen sd ss.1 }.
Proof.
  have e2 := ESpillInterval (SpillConditionToT spill) :: e.

  (* Is there a use position requiring a register in the interval?  If yes,
     then split it again; otherwise, spill it. *)
  case S: (firstUseReqReg i1.2) => [[splitPos2 /= Hmid2] |]; last first.
    move/eqP in S.
    SpillCondition_cases
      (case: spill => [|Heqe|xid reg Heqe Hin|xid reg Heqe Hin]) Case.
    - Case "NewToHandled".
      move: (ScanState_newHandled st S) => st'.
      apply: inr _.
      exists (_; st').
      apply Build_SSMorphHasLen => //=;
      try apply Build_SSMorphLen => //=;
      try apply Build_SSMorph => //=;
      by rewrite size_map Hunh.

    - Case "UnhandledToHandled".
      rewrite [firstUseReqReg]lock in S.
      destruct sd; simpl in *.
      rewrite Hunh in st.
      have Hreq: firstUseReqReg (vnth intervals uid).2 == None.
        rewrite -lock in S.
        by rewrite Heqe S.
      move: (ScanState_moveUnhandledToHandled st Hreq) => st'.
      apply: inr _.
      exists (_; st').
      exact: Build_SSMorph.

    - Case "ActiveToHandled".
      have Hreq : (firstUseReqReg (getInterval xid) == None)
        by rewrite /getInterval Heqe.
      move: (moveActiveToHandled st Hin (spilled:=true) Hreq)
        => [sd' st' [[[?] H] _]].
      apply: inr _.
      exists (sd'; st').
      apply Build_SSMorphHasLen => //=.
      apply H.
      by rewrite Hunh.

    - Case "InactiveToHandled".
      have Hreq : (firstUseReqReg (getInterval xid) == None)
        by rewrite /getInterval Heqe.
      move: (moveInactiveToHandled st Hin (spilled:=true) Hreq)
        => [sd' st' [[[?] H] _]].
      apply: inr _.
      exists (sd'; st').
      apply Build_SSMorphHasLen => //=.
      apply H.
      by rewrite Hunh.

  have e3 := EIntervalHasUsePosReqReg splitPos2 :: e2.

  pose optSplitPos2 := optimalSplitPosition i1.2 beg splitPos2.

  case E: (ibeg i1.1 >= optSplitPos2).
    (* This interval goes back on the unhandled list, to be processed in a
       later iteration. Note: this cannot change the head of the unhandled
       list. *)
    case Hincr: (beg < ibeg i1.1); last first.
      move=> *.
      exact: inl (ECannotInsertUnhandled
                    beg (ibeg i1.1) optSplitPos2 (iend i1.1) ::
                  EIntervalBeginsAtSplitPosition :: e3).

    have := ScanState_newUnhandled st i1.2.
    rewrite Hunh => /=.
    move/(_ Hincr).
    rewrite /= => {st} st.

    apply: inr (packScanState st; _).
    case: spill => [|*|*|*];
    apply Build_SSMorphHasLen => //=;
    try apply Build_SSMorphLen => //=;
    try apply Build_SSMorph => //=;
    by rewrite /= insert_size /=.

  have Hmid3 : ibeg i1.1 < optSplitPos2 < iend i1.1.
    clear -Hbeg Hmid2 E.
    rewrite /optSplitPos2 /optimalSplitPosition.
    move/negbT in E.
    rewrite -ltnNge in E.
    by ordered.

  (* Wimmer: "All active and inactive intervals for this register intersecting
     with current are split before the start of current and spilled to the
     stack.  These split children are not considered during allocation any
     more because they do not have a register assigned.  If they have a use
     positions requiring a register, however, they must be reloaded again to a
     register later on.  Therefore, they are split a second time before these
     use positions, and the second split children are sorted into the
     unhandled list.  They get a register assigned when the allocator advances
     to the start position of these intervals." *)
  case: (splitInterval i1.2 Hmid3) => [[i1_0 i1_1] [/= H1_1 H2_1 H3_1]] //.

  (* jww (2015-05-21): This should be [None] by definition, but I lack the
     evidence for now, from the first use of [firstUseReqReg] and then
     [splitInterval] at the returned position. *)
  case Hreq: (firstUseReqReg i1_0.2) => [[pos ?]|].
    exact: inl (ECannotSpillIfRegisterRequiredBefore optSplitPos2 pos :: e3).
  rewrite [firstUseReqReg]lock in Hreq.
  move/eqP in Hreq.

  (* The second interval will go back on the unhandled list, to be processed
     in a later iteration. Note: By definition of [insert] and
     [ScanState_newUnhandled], it cannot become the new first element.

     jww (2015-05-22): This should be proven. *)
  have := ScanState_newUnhandled st i1_1.2.
  rewrite Hunh => /=.
  have Hincr: (beg < ibeg i1_1.1) by ordered.
  move/(_ Hincr).
  rewrite /= => {st} st.

  move: st.
  set unh' := insert _ _ _.
  set sd' := (X in ScanState _ X).
  rewrite /= in sd' *.
  move=> st.

  have Hle : nextInterval sd <= nextInterval sd' by ordered.

  (* The first interval goes onto the handled list, with no register assigned
     to indicate a spill. *)
  SpillCondition_cases
    (case: spill => [|Heqe|xid reg Heqe Hin|xid reg Heqe Hin]) Case.
  - Case "NewToHandled".
    rewrite -lock in Hreq.
    move: (ScanState_newHandled st Hreq) => {st} st.
    apply: inr _.
    exists (_; st).
    apply Build_SSMorphHasLen => //=;
    try apply Build_SSMorphLen => //=;
    try apply Build_SSMorph => //=;
    try by rewrite size_map insert_size;
    by ordered.
    by ordered.

  - Case "UnhandledToHandled".
    (* Update the state with the new dimensions of the first interval. *)
    move: (ScanState_setInterval st)
      => /= /(_ (widen_ord Hle uid) i1_0.1 i1_0.2).

    have Hint : ibeg i1_0.1 ==
                ibeg (vnth (vshiftin (intervals sd) (i1_1.1; i1_1.2))
                           (widen_ord Hle uid)).1.
      have ->: widen_ord Hle uid = widen_id uid.
        rewrite /widen_id.
        f_equal.
        exact: eq_irrelevance.
      by rewrite vnth_vshiftin Heqe -H2_1.

    have Hend : iend i1_0.1 <=
                iend (vnth (vshiftin (intervals sd) (i1_1.1; i1_1.2))
                           (widen_ord Hle uid)).1.
      have ->: widen_ord Hle uid = widen_id uid.
        rewrite /widen_id.
        f_equal.
        exact: eq_irrelevance.
      rewrite vnth_vshiftin Heqe.
      by ordered.

    case Hnot: (widen_ord Hle uid \notin handledIds sd'); last first.
      move=> *.
      exact: inl (ECannotModifyHandledInterval uid :: e3).

    move/(_ Hint Hend is_true_true).
    rewrite /= => {Hint Hend Hnot st} st.

    rewrite /sd' in st.
    case U: unh' => [|u' us'] in sd' Hle st.
      move: U.
      rewrite /unh'.
      clear.
      rewrite /insert /= -/insert.
      set b := lebf _ _ _.
      by case: b; discriminate.
    rewrite /unh' /insert /= -/insert /widen_fst in U.

    have Hreq' : firstUseReqReg
                   (vnth (vreplace (vshiftin (intervals sd) (i1_1.1; i1_1.2))
                                   (widen_ord Hle uid)
                                   (i1_0.1; i1_0.2)) (fst u')).2 == None.
      case F: (lebf (@snd _ _)
                    (widen_fst (uid, beg)) (ord_max, ibeg i1_1.1)) in U;
      inversion U.
        have ->: widen_id uid = widen_ord Hle uid.
          rewrite /widen_id.
          f_equal.
          exact: eq_irrelevance.
        rewrite -lock in Hreq.
        by rewrite vnth_vreplace.
      rewrite /lebf /= in F.
      by ordered.

    move: (ScanState_moveUnhandledToHandled st Hreq') => {Hreq' st} st.

    apply: inr _.
    exists (_; st).

    apply Build_SSMorphLen => //=;
    try apply Build_SSMorph => //=;
    case F: (lebf (@snd _ _)
                  (widen_fst (uid, beg)) (ord_max, ibeg i1_1.1)) in U;
    inversion U => //;
    by rewrite insert_size.

  - Case "ActiveToHandled".
    move: (ScanState_setInterval st)
      => /= /(_ (widen_ord Hle xid) i1_0.1 i1_0.2).

    have Hint : ibeg i1_0.1 ==
                ibeg (vnth (vshiftin (intervals sd) (i1_1.1; i1_1.2))
                           (widen_ord Hle xid)).1.
      have ->: widen_ord Hle xid = widen_id xid.
        rewrite /widen_id.
        f_equal.
        exact: eq_irrelevance.
      by rewrite vnth_vshiftin Heqe -H2_1.

    have Hend : iend i1_0.1 <=
                iend (vnth (vshiftin (intervals sd) (i1_1.1; i1_1.2))
                           (widen_ord Hle xid)).1.
      have ->: widen_ord Hle xid = widen_id xid.
        rewrite /widen_id.
        f_equal.
        exact: eq_irrelevance.
      rewrite vnth_vshiftin Heqe.
      by ordered.

    case Hnot: (widen_ord Hle xid \notin handledIds sd'); last first.
      move=> *.
      exact: inl (ECannotModifyHandledInterval xid :: e3).

    move/(_ Hint Hend is_true_true).
    rewrite /= => {Hint Hend Hnot st} st.

    move: st.
    set sd'' := (X in ScanState _ X).
    rewrite /= in sd'' *.
    move=> st.

    pose elem := widen_fst (xid, reg).
    have Hin' : elem \in active sd'.
      rewrite /sd' /= mem_map //=.
      exact: widen_fst_inj.
    case Helem: elem => [a b] in Hin'.

    have Hreq' : if true
                 then firstUseReqReg (vnth (intervals sd'') a).2 == None
                 else true.
      rewrite /elem /widen_fst in Helem.
      inversion Helem.
      rewrite -lock in Hreq.
      have ->: widen_id xid = widen_ord Hle xid.
        rewrite /widen_id.
        f_equal.
        exact: eq_irrelevance.
      by rewrite /sd'' [vnth _]/= vnth_vreplace.

    move: (moveActiveToHandled st Hin' (spilled:=true) Hreq')
      => [sd3 st3 [[[?] H] _]].
    apply: inr _.
    exists (sd3; st3).
    apply Build_SSMorphHasLen => //=;
    try apply Build_SSMorphLen => //=;
    try apply Build_SSMorph => //=.
    + by ordered.
    + replace (unhandled sd') with unh' in H; last by auto.
      rewrite /unh' insert_size /= in H.
      by auto.
    + replace (unhandled sd') with unh' in H; last by auto.
      rewrite /unh' insert_size /= in H.
      by auto.

  - Case "InactiveToHandled".
    move: (ScanState_setInterval st)
      => /= /(_ (widen_ord Hle xid) i1_0.1 i1_0.2).

    have Hint : ibeg i1_0.1 ==
                ibeg (vnth (vshiftin (intervals sd) (i1_1.1; i1_1.2))
                           (widen_ord Hle xid)).1.
      have ->: widen_ord Hle xid = widen_id xid.
        rewrite /widen_id.
        f_equal.
        exact: eq_irrelevance.
      by rewrite vnth_vshiftin Heqe -H2_1.

    have Hend : iend i1_0.1 <=
                iend (vnth (vshiftin (intervals sd) (i1_1.1; i1_1.2))
                           (widen_ord Hle xid)).1.
      have ->: widen_ord Hle xid = widen_id xid.
        rewrite /widen_id.
        f_equal.
        exact: eq_irrelevance.
      rewrite vnth_vshiftin Heqe.
      by ordered.

    case Hnot: (widen_ord Hle xid \notin handledIds sd'); last first.
      move=> *.
      exact: inl (ECannotModifyHandledInterval xid :: e3).

    move/(_ Hint Hend is_true_true).
    rewrite /= => {Hint Hend Hnot st} st.

    move: st.
    set sd'' := (X in ScanState _ X).
    rewrite /= in sd'' *.
    move=> st.

    pose elem := widen_fst (xid, reg).
    have Hin' : elem \in inactive sd'.
      rewrite /sd' /= mem_map //=.
      exact: widen_fst_inj.
    case Helem: elem => [a b] in Hin'.

    have Hreq' : if true
                 then firstUseReqReg (vnth (intervals sd'') a).2 == None
                 else true.
      rewrite /elem /widen_fst in Helem.
      inversion Helem.
      rewrite -lock in Hreq.
      have ->: widen_id xid = widen_ord Hle xid.
        rewrite /widen_id.
        f_equal.
        exact: eq_irrelevance.
      by rewrite /sd'' [vnth _]/= vnth_vreplace.

    move: (moveInactiveToHandled st Hin' (spilled:=true) Hreq')
      => [sd3 st3 [[[?] H] _]].
    apply: inr _.
    exists (sd3; st3).
    apply Build_SSMorphHasLen => //=;
    try apply Build_SSMorphLen => //=;
    try apply Build_SSMorph => //=.
    + by ordered.
    + replace (unhandled sd') with unh' in H; last by auto.
      rewrite /unh' insert_size /= in H.
      by auto.
    + replace (unhandled sd') with unh' in H; last by auto.
      rewrite /unh' insert_size /= in H.
      by auto.
Defined.

Definition spillCurrentInterval {pre} :
  SState pre (@SSMorphHasLen maxReg) (@SSMorph maxReg) unit.
Proof.
  move=> e ssi.
  have e2 := ESpillCurrentInterval :: e.
  case: ssi => sd.
  case=> H. case: H => /=; case.
  case Hunh: (unhandled sd) => //= [[uid beg] us].
  move=> H1 H2 H3.
  have := getInterval uid.
  set d := (X in Interval X).
  move=> i st.
  case Hbeg2: (beg <= ibeg d); last first.
    exact: inl (EIntervalBeginsBeforeUnhandled uid :: e).
  case: (spillInterval st Hunh Hbeg2 (UnhandledToHandled (refl_equal _)) e)
    => [err|[[sd' st'] H]].
    exact: inl err.
  apply: inr (tt, _).
  apply: (Build_SSInfo _ st').
  case: (firstUseReqReg (vnth (intervals sd) uid).2) => [[pos /= ?]|] in H.
  case: H => [[/= ?] _].
  apply Build_SSMorph => //=; by ordered.
  case: H => [/= ?].
  apply Build_SSMorph => //=; by ordered.
Defined.

End Spill.


(** * Grothendieck Construction of a functor to Cat *)
Require Import Category.Core Functor.Core.
Require Import Pseudofunctor.FromFunctor.
Require Import Cat.Core.
Require Import Grothendieck.PseudofunctorToCat.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.

Section Grothendieck.
  Context `{Funext}.

  Variable P : PreCategory -> Type.
  (*Context `{forall C, IsHProp (P C)}.*)
  Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}.

  Local Notation cat := (@sub_pre_cat _ P HF).

  Variable C : PreCategory.
  Variable F : Functor C cat.

  (** ** Category of elements *)
  Definition category : PreCategory
    := category (pseudofunctor_of_functor_to_cat F).

  (** ** First projection functor *)
  Definition pr1 : Functor category C
    := pr1 (pseudofunctor_of_functor_to_cat F).
End Grothendieck.


Require Import Prelude.
Require Import Infrastructure.

Open Scope list_scope.

(* Proofs regarding proposition 2.1 from the paper *)
Section SimpleEquationProperties.

  Variable Σ : GADTEnv.

  Lemma teq_reflexivity : forall Δ T,
      entails_semantic Σ Δ (T ≡ T).
    cbn.
    intros.
    auto.
  Qed.

  Lemma teq_symmetry : forall Δ T U,
      entails_semantic Σ Δ (T ≡ U) ->
      entails_semantic Σ Δ (U ≡ T).
    cbn. intros.
    symmetry.
    auto.
  Qed.

  Lemma teq_transitivity : forall Δ T U V,
      entails_semantic Σ Δ (T ≡ U) ->
      entails_semantic Σ Δ (U ≡ V) ->
      entails_semantic Σ Δ (T ≡ V).
    cbn. intros.
    transitivity (subst_tt' U Θ); auto.
  Qed.

  Lemma subst_has_no_fv : forall Σ Δ Θ,
      subst_matches_typctx Σ Δ Θ ->
      (forall X U, List.In (X, U) Θ -> fv_typ U = \{}).
  Proof.
    induction 1; introv Hin.
    - false.
    - cbn in Hin.
      destruct Hin as [Hin | Hin].
      + inversions Hin.
        lets Hfv: wft_gives_fv H.
        cbn in Hfv.
        apply~ fset_extens.
      + apply* IHsubst_matches_typctx.
    - apply* IHsubst_matches_typctx.
  Qed.

  Lemma teq_axiom : forall Δ T U,
      List.In (tc_eq (T ≡ U)) Δ ->
      entails_semantic Σ Δ (T ≡ U).
  Proof.
    unfold entails_semantic.
    induction Δ; introv Hin M.
    - contradiction.
    - cbn in Hin.
      destruct Hin as [Hin | Hin].
      + subst. inversion M.
        easy.
      + inversion M; auto.
        cbn.
        repeat rewrite subst_tt_inside; auto.
        * f_equal.
          apply IHΔ; auto.
        * introv Uin.
          lets Fr: subst_has_no_fv Uin.
          -- eauto.
          -- rewrite Fr. apply notin_empty.
        * introv Uin.
          lets Fr: subst_has_no_fv Uin.
          -- eauto.
          -- rewrite Fr. apply notin_empty.
  Qed.

End SimpleEquationProperties.

Ltac fold_from_list :=
  repeat progress match goal with
  | [ H: context[LibList.fold_right (fun (x : var) (acc : fset var) => \{ x} \u acc) \{} ?L]  |- _ ] =>
    fold (from_list L) in H
  | |- context[LibList.fold_right (fun (x : var) (acc : fset var) => \{ x} \u acc) \{} ?L] =>
    fold (from_list L)
                  end.

Lemma notin_from_list : forall As (A : var),
    ~ (List.In A As) ->
    A \notin from_list As.
  intros.
  intro HF.
  lets [A' [Hin Heq]]: in_from_list HF.
  subst.
  auto.
Qed.

Lemma spawn_unit_subst : forall Σ As,
    DistinctList As ->
    exists Θ, length Θ = length As /\ subst_matches_typctx Σ (tc_vars As) Θ /\ substitution_sources Θ = from_list As.
Proof.
  induction As as [| Ah Ats]; introv ADist.
  - cbn.
    exists (@nil (var * typ)).
    splits~.
    constructor.
  - inversions ADist.
    destruct IHAts as [LT [Len [Match Src]]]; auto.
    exists ((Ah, typ_unit) :: LT).
    splits.
    + cbn. auto.
    + constructor;
        fold (List.map tc_var Ats);
        fold (tc_vars Ats);
        auto.
      * rewrite Src.
        apply~ notin_from_list.
      * apply notin_dom_tc_vars.
        apply~ notin_from_list.
    + cbn.
      fold_from_list.
      fold (substitution_sources LT).
      rewrite Src.
      trivial.
Qed.

Lemma only_vars_is_tc_vars : forall Δ,
    (forall tc, List.In tc Δ -> exists A, tc = tc_var A) ->
    exists As, Δ = tc_vars As.
Proof.
  induction Δ as [| [A | eq] Δt].
  - cbn. intros. exists (@nil var). cbn. trivial.
  - cbn. intro Hin.
    lets* [Ats EQ]: IHΔt.
    exists (A :: Ats). cbn.
    fold (tc_vars Ats).
    f_equal.
    auto.
  - cbn. intro Hin.
    false~ Hin. congruence.
Qed.

Lemma contradictory_env_test_0 : forall Σ Δ,
    entails_semantic Σ Δ (typ_unit ≡ (typ_unit ** typ_unit)) ->
    contradictory_bounds Σ Δ.
Proof.
  introv Heq.
  unfold contradictory_bounds.
  intros.
  unfold entails_semantic in *.
  introv Hmatch.
  exfalso.
  lets HF: Heq Hmatch.
  rewrite subst_ttΘ_fresh in HF.
  - rewrite subst_ttΘ_fresh in HF.
    + false.
    + cbn. rewrite union_empty_r.
      rewrite~ inter_empty_r.
  - cbn.
    rewrite~ inter_empty_r.
Qed.

Lemma subst_ttΘ_into_abs : forall Θ A B,
    subst_tt' (A ==> B) Θ
    =
    (subst_tt' A Θ) ==> (subst_tt' B Θ).
  induction Θ as [| [X T] Θ]; cbn in *; trivial.
Qed.
Lemma subst_ttΘ_into_tuple : forall Θ A B,
    subst_tt' (A ** B) Θ
    =
    (subst_tt' A Θ) ** (subst_tt' B Θ).
  induction Θ as [| [X T] Θ]; cbn in *; trivial.
Qed.

Lemma contradictory_env_test : forall Σ Δ A B C D,
    entails_semantic Σ Δ ((A ==> B) ≡ (C ** D)) ->
    contradictory_bounds Σ Δ.
Proof.
  introv Heq.
  unfold contradictory_bounds.
  intros.
  unfold entails_semantic in *.
  introv Hmatch.
  exfalso.
  lets HF: Heq Hmatch.
  rewrite subst_ttΘ_into_abs in HF.
  rewrite subst_ttΘ_into_tuple in HF.
  congruence.
Qed.

Lemma empty_is_not_contradictory : forall Σ,
    ~ (contradictory_bounds Σ emptyΔ).
Proof.
  intros.
  intro HF.
  unfold contradictory_bounds in HF.
  asserts M: (subst_matches_typctx Σ emptyΔ (@nil (var*typ)));
    try econstructor.
  lets F: HF typ_unit (typ_unit ** typ_unit) (@nil (var * typ)) M.
  cbn in F.
  false.
Qed.

Lemma typing_exfalso : forall Σ Δ E e T1 T2 TT,
    {Σ, Δ, E} ⊢(TT) e ∈ T1 ->
    contradictory_bounds Σ Δ ->
    wft Σ Δ T2 ->
    {Σ, Δ, E} ⊢(Tgen) e ∈ T2.
  introv Typ Bounds.
  eapply typing_eq; eauto.
Qed.

Lemma inversion_typing_eq : forall Σ Δ E e T TT,
    {Σ, Δ, E} ⊢(TT) e ∈ T ->
    exists T',
      {Σ, Δ, E} ⊢(Treg) e ∈ T' /\ entails_semantic Σ Δ (T ≡ T').
Proof.
  introv Htyp.
  lets Htyp2: Htyp.
  induction Htyp;
    try match goal with
        | [ H: {Σ, Δ, E} ⊢(Treg) ?e ∈ ?T |- _ ] =>
          exists T; split~; auto using teq_reflexivity
        end.
  lets [T' [IHTyp IHeq]]: IHHtyp Htyp.
  exists T'.
  split~.
  eauto using teq_symmetry, teq_transitivity.
Qed.

Lemma subst_has_no_fv2 : forall Σ Δ Θ Y,
    subst_matches_typctx Σ Δ Θ ->
    (forall A U, List.In (A, U) Θ -> Y \notin fv_typ U).
Proof.
  introv M Hin.
  lets EQ: subst_has_no_fv M Hin.
  rewrite EQ.
  auto.
Qed.

Lemma inversion_eq_arrow : forall Σ Δ TA1 TB1 TA2 TB2,
    entails_semantic Σ Δ ((TA1 ==> TB1) ≡ (TA2 ==> TB2)) ->
    entails_semantic Σ Δ (TA1 ≡ TA2) /\
    entails_semantic Σ Δ (TB1 ≡ TB2).
Proof.
  introv Sem; cbn in *.
  split~;
       introv M;
    lets EQ: Sem M;
    repeat rewrite subst_tt_prime_reduce_arrow in EQ;
    inversion~ EQ.
Qed.

Lemma inversion_eq_tuple : forall Σ Δ TA1 TB1 TA2 TB2,
    entails_semantic Σ Δ ((TA1 ** TB1) ≡ (TA2 ** TB2)) ->
    entails_semantic Σ Δ (TA1 ≡ TA2) /\
    entails_semantic Σ Δ (TB1 ≡ TB2).
Proof.
  introv Sem; cbn in *.
  split~;
       introv M;
    lets EQ: Sem M;
    repeat rewrite subst_tt_prime_reduce_tuple in EQ;
    inversion~ EQ.
Qed.

Lemma inversion_eq_typ_all : forall Σ Δ T U,
    entails_semantic Σ Δ (typ_all T ≡ typ_all U) ->
    entails_semantic Σ Δ (T ≡ U).
Proof.
  introv Sem; cbn in *.
  introv M;
    lets EQ: Sem M;
    repeat rewrite subst_tt_prime_reduce_typ_all in EQ;
    inversion~ EQ.
Qed.

Lemma inversion_eq_typ_gadt : forall Σ Δ Ts Us N,
    List.length Ts = List.length Us ->
    entails_semantic Σ Δ (typ_gadt Ts N ≡ typ_gadt Us N) ->
    List.Forall2 (fun T U => entails_semantic Σ Δ (T ≡ U)) Ts Us.
Proof.
  introv Len Sem.
  apply F2_iff_In_zip.
  split~.
  intros T U In.
  cbn in *.
  introv M.
  lets EQ: Sem M.
  repeat rewrite subst_tt_prime_reduce_typ_gadt in EQ.
  inversion EQ as [EQ2].
  lets~ : lists_map_eq EQ2 In.
Qed.

Lemma equations_from_lists_map : forall F F1 F2 Ts Us,
    List.length Ts = List.length Us ->
    (forall T U, List.In (T,U) (zip Ts Us) -> F (tc_eq (T ≡ U)) = tc_eq (F1 T ≡ F2 U)) ->
    List.map F (equations_from_lists Ts Us)
    =
    equations_from_lists (List.map F1 Ts) (List.map F2 Us).
Proof.
  induction Ts as [| T Ts]; destruct Us as [| U Us];
    introv Len;  try solve [inversion~ Len].
  introv EQ.
  cbn.
  fold (equations_from_lists Ts Us).
  fold (equations_from_lists (List.map F1 Ts) (List.map F2 Us)).
  f_equal.
  - apply EQ. cbn. auto.
  - apply* IHTs.
    introv In.
    apply EQ. cbn. auto.
Qed.

Lemma empty_eq_is_equivalent : forall Σ T1 T2,
  entails_semantic Σ emptyΔ (T1 ≡ T2) ->
  T1 = T2.
Proof.
  introv Sem.
  cbn in *.
  lets M: Sem (@nil (var * typ)).
  forwards * : M.
  constructor.
Qed.


From F_mu_ref_conc_sub Require Export context_refinement.
From iris.algebra Require Import auth frac agree.
From iris.proofmode Require Import tactics.
From iris.program_logic Require Import adequacy.
From F_mu_ref_conc_sub Require Import soundness_unary.

Lemma basic_soundness Σ `{heapPreIG Σ, inG Σ (authR cfgUR)}
    e e' τ v thp hp :
  (∀ `{heapIG Σ, cfgSG Σ}, [] ∣ [] ⊨ e ≤log≤ e' : τ) →
  rtc erased_step ([e], ∅) (of_val v :: thp, hp) →
  (∃ thp' hp' v', rtc erased_step ([e'], ∅) (of_val v' :: thp', hp')).
Proof.
  intros Hlog Hsteps.
  cut (adequate NotStuck e ∅ (λ _ _, ∃ thp' h v, rtc erased_step ([e'], ∅) (of_val v :: thp', h))).
  { destruct 1; naive_solver. }
  eapply (wp_adequacy Σ _); iIntros (Hinv ?).
  iMod (gen_heap_init (∅ : gmap loc val)) as (GHG) "Hh".
  iMod (own_alloc (● (to_tpool [e'], ∅)
    ⋅ ◯ ((to_tpool [e'] : tpoolUR, ∅) : cfgUR))) as (γc) "[Hcfg1 Hcfg2]".
  { apply auth_both_valid. split=>//. split=>//. apply to_tpool_valid. }
  set (Hcfg := CFGSG _ _ γc).
  iMod (inv_alloc specN _ (spec_inv ([e'], ∅)) with "[Hcfg1]") as "#Hcfg".
  { iNext. iExists [e'], ∅. rewrite /to_gen_heap fin_maps.map_fmap_empty. auto. }
  set (HeapΣ := (HeapIG Σ Hinv GHG)).
  iExists (λ σ _, gen_heap_ctx σ); iFrame.
  iExists (λ _, True)%I.
  iApply wp_fupd. iApply wp_wand_r.
  iSplitL.
  iPoseProof ((Hlog _ _ [] [] ([e'], ∅)) with "[$Hcfg] [] []") as "Hrel".
  { iSplit; eauto. by iIntros (? ?); rewrite lookup_nil; iIntros (?). }
  { iApply (@logrel_binary.interp_env_nil Σ HeapΣ). }
  simpl.
  replace e with e.[env_subst[]] at 2 by by asimpl.
  iApply ("Hrel" $! 0 []).
  { rewrite /tpool_mapsto. asimpl. by iFrame. }
  iModIntro. iIntros (v1); iDestruct 1 as (v2) "[Hj #Hinterp]".
  iInv specN as (tp σ) ">[Hown Hsteps]" "Hclose"; iDestruct "Hsteps" as %Hsteps'.
  rewrite /tpool_mapsto /=.
  iDestruct (own_valid_2 with "Hown Hj") as %Hvalid.
  move: Hvalid=> /auth_both_valid
    [/prod_included [/tpool_singleton_included Hv2 _] _].
  destruct tp as [|? tp']; simplify_eq/=.
  iMod ("Hclose" with "[-]") as "_"; [iExists (_ :: tp'), σ; auto|].
  iIntros "!> !%"; eauto.
Qed.

Lemma binary_soundness Σ `{heapPreIG Σ, inG Σ (authR cfgUR)}
    Ξ Γ e e' τ :
  (Ξ |ₜ Γ ⊢ₜ e : τ) → (Ξ |ₜ Γ ⊢ₜ e' : τ) →
  (∀ `{heapIG Σ, cfgSG Σ}, Ξ ∣ Γ ⊨ e ≤log≤ e' : τ) →
  Ξ ∣ Γ ⊨ e ≤ctx≤ e' : τ.
Proof.
  intros He He' Hlog; repeat split; auto.
  intros K thp σ v ?. eapply (basic_soundness Σ _)=> ??.
  eapply (bin_log_related_under_typed_ctx); eauto.
Qed.


From iris.algebra Require Import excl auth frac cmra gmap agree gset numbers.
From iris.algebra.lib Require Import frac_agree.
From iris.heap_lang Require Export notation locations lang.
From iris.base_logic.lib Require Export invariants.
From iris.program_logic Require Export atomic.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode par.
From iris.bi.lib Require Import fractional.
Set Default Proof Using "All".
Require Export multicopy_df auth_ext.
Require Export multicopy_util.

Section multicopy_df_upsert.
  Context {Σ} `{!heapG Σ, !multicopyG Σ, !multicopy_dfG Σ}.
  Notation iProp := (iProp Σ).
  Local Notation "m !1 i" := (nzmap_total_lookup i m) (at level 20).

  Lemma nodePred_lockR_true γ_s γ_cn r n Cn Vn Vn' Tn bn :
    node r n Vn' -∗
      lockR bn n (nodePred γ_s γ_cn r n Cn Vn Tn) -∗
        ⌜bn = true⌝.
  Proof.
    iIntros "node Hl_n".
    destruct bn; try done.
    iDestruct "Hl_n" as "(Hl & HnP')".
    iDestruct "HnP'" as "(n' & _)".
    iExFalso. iApply (node_sep_star r n). iFrame.
  Qed.

  Lemma upsert_spec N γ_te γ_he γ_s Prot γ_cr γ_cd γ_d r d (k: K) (v: V) :
    ⊢ ⌜k ∈ KS⌝ -∗
        (ghost_update_protocol N γ_te γ_he Prot k) -∗
        mcs_inv N γ_te γ_he γ_s Prot
          (Inv_DF γ_s γ_cr γ_cd γ_d r d) -∗
            <<< ∀ (t: T) H, MCS γ_te γ_he t H >>>
                   upsert r #k #v @ ⊤ ∖ (↑(mcsN N))
            <<< MCS γ_te γ_he (t + 1) (H ∪ {[(k, (v, t))]}), RET #() >>>.
  Proof.
    iIntros "%".
    rename H into k_in_KS.
    (* perform Löb induction by generating a hypothesis IH : ▷ goal *)
    iLöb as "IH".
    iIntros "Ghost_updP #HInv" (Φ) "AU". wp_lam. wp_pures.
    iApply fupd_wp.
    (** Open invariant to establish root node in footprint **)
    iInv "HInv" as (t0 H0)"(mcs_high & >Inv_DF)".
    iDestruct "Inv_DF" as (Cr0 Vr0 Tr0 Cd0 Vd0 Td0) "(r_neq_d & Hcir
            & Hset & HlockR_r & Half_r & Hcts_r
            & HlockR_d & Half_d & Hcts_d)".
    iModIntro. iSplitR "AU Ghost_updP". iNext.
    iExists t0, H0. iFrame "mcs_high".
    iExists Cr0, Vr0, Tr0, Cd0, Vd0, Td0. iFrame "∗ #".

    iModIntro.
    awp_apply lockNode_spec_high without "Ghost_updP"; try done.
    iPureIntro. auto.
    (** Lock the node r **)
    iAaccIntro with ""; try eauto with iFrame.

    iIntros (γ_cn Cr Vr Tr) "HnP_n". iModIntro.
    iIntros "Ghost_updP". wp_pures.
    iDestruct "HnP_n" as "(HnP_n & #r_is_locked)".
    iDestruct "HnP_n" as "(node_r & HnP_C & HnP_frac)".
    wp_apply (addContents_spec with "[$node_r]"); try done.
    iIntros (b Vr') "(node_r & Hif)".

    (** Case analysis on whether addContents is successful **)
    destruct b; last first.
    - (** Case : addContents fails. Unlock root node and apply
                 inductive hypothesis IH **)
      iDestruct "Hif" as %HVr. replace Vr'. wp_pures.
      awp_apply (unlockNode_spec_high
          with "[] [] [HnP_frac HnP_C node_r ]")
            without "Ghost_updP" ; try done.
      {
        iFrame.
      }
      iAaccIntro with ""; try eauto with iFrame.
      iIntros "_". iModIntro.
      iIntros "Ghost_updP". wp_pures.
      iApply ("IH" with "Ghost_updP"); try done.
    - (** Case : addContent successful **)
      (** Linearization Point: open invariant and update the resources **)
      wp_pures.

      (* Need to unfold unlockNode here in order to apply
         ghost_udpate_protocol, which requires stripping off
         a later modality. This requires a physical step in heapLang,
         which is available by unfolding the unlockNode *)

      unfold unlockNode.
      wp_pures. wp_bind(getLockLoc _)%E.
      wp_apply getLockLoc_spec; first done.
      iIntros (l) "%"; subst l; wp_pures.

      iInv "HInv" as (t1 H1)"(mcs_high & >Inv_DF)".
      iDestruct "Inv_DF" as (Cr1 Vr1 Tr1 Cd1 Vd1 Td1) "(r_neq_d & Hcir
            & Hset & HlockR_r & Half_r & Hcts_r
            & HlockR_d & Half_d & Hcts_d)".

      iDestruct "mcs_high" as "(>MCS_auth & >HH & >HInit
        & >HClock & >HUniq & Prot)".

      iDestruct "HlockR_r" as (br) "HlockR_r".
      iDestruct "HlockR_d" as (bd) "HlockR_d".
      iDestruct "Hif" as %HCr.

      set (Tr' := <[k := t1]> Tr).
      set (Cr' := <[k := (v, t1)]> Cr).
      set (H1' := H1 ∪ {[(k, (v, t1))]}).

      iPoseProof ((auth_own_incl γ_s H1 _) with "[$HH $HnP_C]") as "%".
      rename H into Cr_sub_H1. apply gset_included in Cr_sub_H1.
      iDestruct "HClock" as %HClock_H1.
      (** Re-establish maxTS for updated T and H **)
      assert (HClock (t1 + 1) H1') as HClock_H1'.
      { subst H1'. intros k' v' t' H'.
        assert (((k', (v', t')) ∈ H1) ∨ (k' = k ∧ v' = v ∧ t' = t1))
              as Hor by set_solver.
        destruct Hor as [Hor | Hor].
        pose proof HClock_H1 k' v' t' Hor as Hres. lia.
        destruct Hor as [_ [_ Hor]]. replace t'. lia. }
      iAssert (⌜set_of_map Cr' ⊆ H1'⌝)%I as %Cr'_sub_H1'.
      { subst H1'. iPureIntro. subst Cr'.
        pose proof (set_of_map_insert_subseteq Cr k v t1) as H'.
        assert (set_of_map Cr = set_of_map Cr) as H'' by done.
        set_solver. }
      (** Update the (● H) resource **)
      iMod (own_update γ_s (● H1) (● H1')
          with "[$HH]") as "HH".
      { apply (auth_update_auth _ _ H1').
        apply gset_local_update. set_solver. }
      iMod (own_update γ_s (● H1')
             (● H1' ⋅ ◯ (set_of_map Cr'))
              with "[$HH]") as "HH".
      { subst H1'.
        apply (auth_update_alloc _ (H1 ∪ {[(k, (v, t1))]}) (set_of_map Cr')).
        apply local_update_discrete. intros m Valid_H1 H1_eq.
        split; try done. rewrite /(ε ⋅? m) in H1_eq.
        destruct m. rewrite gset_op in H1_eq.
        rewrite left_id in H1_eq *; intros H1_eq.
        rewrite <-H1_eq.
        rewrite /(set_of_map Cr' ⋅? Some (H1 ∪ {[k, (v, t1)]})).
        rewrite gset_op.
        rewrite /(ε) in H1_eq. unfold ucmra_unit in H1_eq.
        simpl in H1_eq.
        assert ((k, (v, t1)) ∈ set_of_map Cr') as H'.
        { subst Cr'. apply set_of_map_member.
          apply lookup_insert. }
        clear - H' Cr_sub_H1 Cr'_sub_H1'. set_solver.
        exfalso. clear -H1_eq. set_solver. }
      (** Re-establish HInit **)
      iAssert (⌜HInit H1'⌝)%I with "[HInit]" as "HInit".
      { subst H1'. iDestruct "HInit" as %HInit.
        unfold multicopy.HInit. iPureIntro.
        clear -HInit k_in_KS. intros k' Hk'.
        pose proof HInit k' Hk' as H'. set_solver. }
      iDestruct "HnP_C" as "Hown_Cr".
      iDestruct "HH" as "(HH & HnP_C)".

      rewrite (big_sepS_delete _ KS k); last by eauto.
      iDestruct "HInit" as %HInit.

      iPoseProof (nodePred_lockR_true with "[$node_r] [HlockR_r]")
         as "%". iFrame. subst br.

      (** Update contents-in-reach of r **)
      iAssert (⌜map_of_set H1' =
                        <[k:= (v, t1)]> (map_of_set H1)⌝)%I as %Htrans_union.
      {
        iDestruct "HUniq" as %HUniq.
        iPureIntro.
        pose proof map_of_set_insert_eq k v t1 H1 HUniq HClock_H1 as mos_eq.
        by subst H1'.
      }

      iAssert (⌜γ_cn = γ_cr⌝)%I as %gamma_cn_cr.
      {

        iDestruct "r_is_locked" as %r_is_locked.
        iDestruct "r_neq_d" as %r_neq_d.
        destruct r_is_locked as [ r_is_locked | r_not_locked].
        destruct r_is_locked as [ r_is_r  gh_cn_cr ]. done.
        destruct r_not_locked as [ r_is_d  gh_cn_cr ]. done.
      }
      subst γ_cn.

      iAssert (⌜Cr = Cr1⌝∗ ⌜Vr = Vr1⌝ ∗ ⌜Tr = Tr1⌝)%I as "(%&%&%)".
      { iPoseProof (own_valid_2 _ _ _ with "[$Half_r] [$HnP_frac]")
                as "#HCr_equiv".
        iDestruct "HCr_equiv" as %HCr_equiv.
        apply frac_agree_op_valid in HCr_equiv.
        destruct HCr_equiv as [_ HCr_equiv].
        apply leibniz_equiv_iff in HCr_equiv.
        inversion HCr_equiv. iPureIntro. done. } subst Cr1 Vr1 Tr1.

      iAssert (⌜cir H1' Cr' Cd1⌝)%I with "[Hcir]" as "Hcir".
      {
        iDestruct "Hcir" as %Hcir.
        iPureIntro.
        intros k' v' t'.
        rewrite -> Htrans_union.
        destruct (decide (k' = k)).
        - subst k'. subst Cr'.
          rewrite !lookup_insert.
          split; try done.
        - subst Cr'.
          rewrite !lookup_insert_ne; try done.
      }

      (*
      iAssert (⌜(map_of_set H1) !!! k ≤ T⌝)%I as %H_le_T.
      {
        iPureIntro.
        rewrite lookup_total_alt.
        destruct ((map_of_set H1) !! k) eqn: hist_has_k.
        - simpl.
          unfold maxTS in MaxTS_H1.
          destruct MaxTS_H1 as [MaxTS_H1 T_not_zero].
          pose proof map_of_set_lookup_cases H1 k as H'.
          destruct H' as [H' | [_ H']]; last first.
          + rewrite H' in hist_has_k. inversion hist_has_k.
          + destruct H' as [Tk [H' [_ H'']]].
            rewrite H'' in hist_has_k. inversion hist_has_k.
            subst Tk.
            pose proof MaxTS_H1 k n H' as H'''.
            clear -H'''; lia.
        - simpl. lia.
      }
      *)

      iAssert (⌜HUnique H1'⌝)%I with "[HUniq]" as %HUniq.
      { iDestruct "HUniq" as %HUniq.
        iPureIntro. subst H1'.
        intros k' t' v' v'' H' H''.
        assert (((k', (v', t')) ∈ H1) ∨ (k' = k ∧ v' = v ∧ t' = t1))
              as Hor by set_solver.
        assert (((k', (v'', t')) ∈ H1) ∨ (k' = k ∧ v'' = v ∧ t' = t1))
              as Hor' by set_solver.
        destruct Hor as [Hor | Hor].
        - destruct Hor' as [Hor' | Hor'].
          + apply (HUniq k' t' v' v'' Hor Hor'); try done.
          + destruct Hor' as [? [? ?]]. subst k' v'' t'.
            apply (HClock_H1 k v' t1) in Hor.
            clear -Hor; lia.
        - destruct Hor as [? [? ?]]. subst k' v' t'.
          destruct Hor' as [Hor' | Hor'].
          + apply (HClock_H1 k v'' t1) in Hor'.
            clear -Hor'; lia.
          + destruct Hor' as [? [? ?]]. by subst v''. }

      iAssert (contents_proj Cr' Vr' Tr')%I with "[Hcts_r]" as "Hcts_r".
      { iDestruct "Hcts_r" as "(% & % & %)".
        rename H into dom_Cr_Vr; rename H2 into dom_Cr_Tr;
        rename H3 into Cr_eq_Vr_Tr.
        iPureIntro. subst Cr' Vr' Tr'. split; last split.
        - apply leibniz_equiv. rewrite !dom_insert.
          rewrite dom_Cr_Vr. clear; set_solver.
        - apply leibniz_equiv. rewrite !dom_insert.
          rewrite dom_Cr_Tr. clear; set_solver.
        - intros k' v' t'. destruct (decide (k' = k)).
          + subst k'. rewrite !lookup_insert. split.
            * intros H'; by inversion H'.
            * intros [H' H'']; inversion H'; by inversion H''.
          + rewrite !lookup_insert_ne; try done. }

      iDestruct "HlockR_r" as "(Hlockr & _)". wp_store.

      (** Linearization **)
      iMod "AU" as (t' H1'')"[MCS [_ Hclose]]".
      iAssert (⌜t' = t1 ∧ H1'' = H1⌝)%I as "(% & %)".
      { iPoseProof (MCS_agree with "[$MCS_auth] [$MCS]") as "(% & %)".
        by iPureIntro. } subst t' H1''.
      iDestruct "MCS" as "(MCS◯t & MCS◯h & _)".
      iDestruct "MCS_auth" as "(MCS●t & MCS●h)".
      iMod ((auth_excl_update γ_te (t1+1) t1 t1) with "MCS●t MCS◯t")
                                          as "(MCS●t & MCS◯t)".
      iMod ((auth_excl_update γ_he (H1 ∪ {[(k, (v, t1))]}) H1 H1) with "MCS●h MCS◯h")
                                          as "(MCS●h & MCS◯h)".
      iCombine "MCS◯t MCS◯h" as "(MCS_t & MCS_h)".
      iCombine "MCS●t MCS●h" as "MCS_auth".
      iMod ("Hclose" with "[MCS_t MCS_h]") as "HΦ".
      iFrame. by iPureIntro.

      (** Use ghost_update_protocol to update Prot(H) **)
      iSpecialize ("Ghost_updP" $! v t1 H1).

      iMod ("Ghost_updP" with "[] [$MCS_auth] [$Prot]")
                        as "(Prot & MCS_auth)".
      { assert ((k, (v, t1)) ∈ H1') as H' by set_solver.
        assert ((∀ (v' : V) (t' : nat), (k, (v', t')) ∈ H1' → t' ≤ t1))
          as H''.
        { intros v' t' Hvt'. subst H1'.
          rewrite elem_of_union in Hvt'*; intros Hvt'.
          destruct Hvt' as [Hvt' | Hvt'].
          - apply HClock_H1 in Hvt'. clear -Hvt'; lia.
          - assert (t' = t1) by (clear -Hvt'; set_solver).
            subst t'; clear; lia. }
        pose proof map_of_set_lookup H1' k v t1 HUniq H' H'' as H'''.
        iPureIntro. rewrite lookup_total_alt.
        rewrite H'''. by simpl. }

      (* Combine fractional ownerships of Cr. *)
      iCombine "HnP_frac Half_r" as "Half_r".
      iEval (rewrite <-frac_agree_op) in "Half_r".
      iEval (rewrite Qp_half_half) in "Half_r".

      (* Use combined ownerships to update Cr -> Cr'. *)
      iMod ((own_update (γ_cr) (to_frac_agree 1 (Cr, Vr, Tr))
              (to_frac_agree 1 (Cr', Vr', Tr'))) with "[$Half_r]")
              as "Half_r".
      { apply cmra_update_exclusive.
        unfold valid, cmra_valid. simpl. unfold prod_valid_instance.
        split; simpl; try done. }

      (* Break apart ownerships to be used separately. *)
      iEval (rewrite <- Qp_half_half) in "Half_r".
      iEval (rewrite frac_agree_op) in "Half_r".
      iDestruct "Half_r" as "(HnP_frac & Half_r)".

      iModIntro. iFrame "HΦ".
      iNext. iExists (t1+1), H1'. iFrame "∗".
      iSplitR; first by iPureIntro.
      iExists Cr', Vr', Tr', Cd1, Vd1, Td1.
      iFrame "Hcir".
      rewrite (big_sepS_delete _ (KS) k); last by eauto.
      iFrame.
      iSplitR "HlockR_d"; last first.
      { by iExists bd. }
      iExists false; iFrame.
  Qed.

End multicopy_df_upsert.


(* *********************************************************************)
(*                                                                     *)
(*              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: relational specification *)

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

(** ** Soundness of function environments. *)

(** A (compile-time) function environment is compatible with a
  (run-time) global environment if the following condition holds. *)

Definition fenv_compat (ge: genv) (fenv: funenv) : Prop :=
  forall id b f,
  fenv!id = Some f -> Genv.find_symbol ge id = Some b ->
  Genv.find_funct_ptr ge b = Some (Internal f).

Remark add_globdef_compat:
  forall ge fenv idg,
  fenv_compat ge fenv ->
  fenv_compat (Genv.add_global ge idg) (Inlining.add_globdef fenv idg).
Proof.
  intros. destruct idg as [id gd]. red; simpl; intros.
  unfold Genv.find_symbol in H1; simpl in H1.
  unfold Genv.find_funct_ptr; simpl.
  rewrite PTree.gsspec in H1. destruct (peq id0 id).
  (* same *)
  subst id0. inv H1. destruct gd. destruct f0.
  destruct (should_inline id f0).
  rewrite PTree.gss in H0. rewrite ZMap.gss. inv H0; auto.
  rewrite PTree.grs in H0; discriminate.
  rewrite PTree.grs in H0; discriminate.
  rewrite PTree.grs in H0; discriminate.
  (* different *)
  destruct gd. rewrite ZMap.gso. eapply H; eauto.
  destruct f0. destruct (should_inline id f0).
  rewrite PTree.gso in H0; auto.
  rewrite PTree.gro in H0; auto.
  rewrite PTree.gro in H0; auto.
  exploit Genv.genv_symb_range; eauto. intros [A B]. unfold ZIndexed.t; omega.
  rewrite PTree.gro in H0; auto. eapply H; eauto.
Qed.

Lemma funenv_program_compat:
  forall p, fenv_compat (Genv.globalenv p) (funenv_program p).
Proof.
  intros.
  unfold Genv.globalenv, funenv_program.
  assert (forall gl ge fenv,
         fenv_compat ge fenv ->
         fenv_compat (Genv.add_globals ge gl) (fold_left add_globdef gl fenv)).
    induction gl; simpl; intros. auto. apply IHgl. apply add_globdef_compat; auto.
  apply H. red; intros. rewrite PTree.gempty in H0; discriminate.
Qed.

(** ** Soundness of the computed bounds over function resources *)

Remark Pmax_l: forall x y, Ple x (Pmax x y).
Proof. intros; xomega. Qed.

Remark Pmax_r: forall x y, Ple y (Pmax x y).
Proof. intros; xomega. Qed.

Lemma max_pc_function_sound:
  forall f pc i, f.(fn_code)!pc = Some i -> Ple pc (max_pc_function f).
Proof.
  intros until i. unfold max_pc_function.
  apply PTree_Properties.fold_rec with (P := fun c m => c!pc = Some i -> Ple pc m).
  (* extensionality *)
  intros. apply H0. rewrite H; auto.
  (* base case *)
  rewrite PTree.gempty. congruence.
  (* inductive case *)
  intros. rewrite PTree.gsspec in H2. destruct (peq pc k).
  inv H2. apply Pmax_r.
  apply Ple_trans with a. auto. apply Pmax_l.
Qed.

Lemma max_def_function_instr:
  forall f pc i, f.(fn_code)!pc = Some i -> Ple (max_def_instr i) (max_def_function f).
Proof.
  intros. unfold max_def_function. eapply Ple_trans. 2: eapply Pmax_l.
  revert H.
  apply PTree_Properties.fold_rec with (P := fun c m => c!pc = Some i -> Ple (max_def_instr i) m).
  (* extensionality *)
  intros. apply H0. rewrite H; auto.
  (* base case *)
  rewrite PTree.gempty. congruence.
  (* inductive case *)
  intros. rewrite PTree.gsspec in H2. destruct (peq pc k).
  inv H2. apply Pmax_r.
  apply Ple_trans with a. auto. apply Pmax_l.
Qed.

Lemma max_def_function_params:
  forall f r, In r f.(fn_params) -> Ple r (max_def_function f).
Proof.
  assert (A: forall l m, Ple m (fold_left (fun m r => Pmax m r) l m)).
    induction l; simpl; intros.
    apply Ple_refl.
    eapply Ple_trans. 2: eauto. apply Pmax_l.
  assert (B: forall l m r, In r l -> Ple r (fold_left (fun m r => Pmax m r) l m)).
    induction l; simpl; intros.
    contradiction.
    destruct H. subst a. eapply Ple_trans. 2: eapply A. apply Pmax_r.
    eauto.
  unfold max_def_function; intros.
  eapply Ple_trans. 2: eapply Pmax_r. eauto.
Qed.

(** ** Working with the state monad *)

Remark bind_inversion:
  forall (A B: Type) (f: mon A) (g: A -> mon B)
         (y: B) (s1 s3: state) (i: sincr s1 s3),
  bind f g s1 = R y s3 i ->
  exists x, exists s2, exists i1, exists i2,
  f s1 = R x s2 i1 /\ g x s2 = R y s3 i2.
Proof.
  unfold bind; intros. destruct (f s1). exists x; exists s'; exists I.
  destruct (g x s'). inv H. exists I0; auto.
Qed.

Ltac monadInv1 H :=
  match type of H with
  | (R _ _ _ = R _ _ _) =>
      inversion H; clear H; try subst
  | (ret _ _ = R _ _ _) =>
      inversion H; clear H; try subst
  | (bind ?F ?G ?S = R ?X ?S' ?I) =>
      let x := fresh "x" in (
      let s := fresh "s" in (
      let i1 := fresh "INCR" in (
      let i2 := fresh "INCR" in (
      let EQ1 := fresh "EQ" in (
      let EQ2 := fresh "EQ" in (
      destruct (bind_inversion _ _ F G X S S' I H) as [x [s [i1 [i2 [EQ1 EQ2]]]]];
      clear H;
      try (monadInv1 EQ2)))))))
  end.

Ltac monadInv H :=
  match type of H with
  | (ret _ _ = R _ _ _) => monadInv1 H
  | (bind ?F ?G ?S = R ?X ?S' ?I) => monadInv1 H
  | (?F _ _ _ _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  end.

(** ** Relational specification of the translation of moves *)

Inductive tr_moves (c: code) : node -> list reg -> list reg -> node -> Prop :=
  | tr_moves_cons: forall pc1 src srcs dst dsts pc2 pc3,
      tr_moves c pc1 srcs dsts pc2 ->
      c!pc2 = Some(Iop Omove (src :: nil) dst pc3) ->
      tr_moves c pc1 (src :: srcs) (dst :: dsts) pc3
  | tr_moves_nil: forall srcs dsts pc,
      srcs = nil \/ dsts = nil ->
      tr_moves c pc srcs dsts pc.

Lemma add_moves_unchanged:
  forall srcs dsts pc2 s pc1 s' i pc,
  add_moves srcs dsts pc2 s = R pc1 s' i ->
  Ple pc s.(st_nextnode) \/ Plt s'.(st_nextnode) pc ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  induction srcs; simpl; intros.
  monadInv H. auto.
  destruct dsts; monadInv H. auto.
  transitivity (st_code s0)!pc. eapply IHsrcs; eauto. monadInv EQ; simpl. xomega.
  monadInv EQ; simpl. apply PTree.gso.
  inversion INCR0; simpl in *. xomega.
Qed.

Lemma add_moves_spec:
  forall srcs dsts pc2 s pc1 s' i c,
  add_moves srcs dsts pc2 s = R pc1 s' i ->
  (forall pc, Plt s.(st_nextnode) pc -> Ple pc s'.(st_nextnode) -> c!pc = s'.(st_code)!pc) ->
  tr_moves c pc1 srcs dsts pc2.
Proof.
  induction srcs; simpl; intros.
  monadInv H. apply tr_moves_nil; auto.
  destruct dsts; monadInv H. apply tr_moves_nil; auto.
  apply tr_moves_cons with x. eapply IHsrcs; eauto.
  intros. inversion INCR. apply H0; xomega.
  monadInv EQ.
  rewrite H0. erewrite add_moves_unchanged; eauto.
  simpl. apply PTree.gss.
  simpl. xomega.
  xomega.
  inversion INCR; inversion INCR0; simpl in *; xomega.
Qed.

(** ** Relational specification of CFG expansion *)

Section INLINING_SPEC.

Variable fenv: funenv.

Definition context_below (ctx1 ctx2: context): Prop :=
  Ple (Pplus ctx1.(dreg) ctx1.(mreg)) ctx2.(dreg).

Definition context_stack_call (ctx1 ctx2: context): Prop :=
  ctx1.(mstk) >= 0 /\ ctx1.(dstk) + ctx1.(mstk) <= ctx2.(dstk).

Definition context_stack_tailcall (ctx1: context) (f: function) (ctx2: context) : Prop :=
  ctx2.(dstk) = align ctx1.(dstk) (min_alignment f.(fn_stacksize)).

Section INLINING_BODY_SPEC.

Variable stacksize: Z.

Inductive tr_instr: context -> node -> instruction -> code -> Prop :=
  | tr_nop: forall ctx pc c s,
      c!(spc ctx pc) = Some (Inop (spc ctx s)) ->
      tr_instr ctx pc (Inop s) c
  | tr_op: forall ctx pc c op args res s,
      Ple res ctx.(mreg) ->
      c!(spc ctx pc) = Some (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Iop op args res s) c
  | tr_load: forall ctx pc c chunk addr args res s,
      Ple res ctx.(mreg) ->
      c!(spc ctx pc) = Some (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Iload chunk addr args res s) c
  | tr_store: forall ctx pc c chunk addr args src s,
      c!(spc ctx pc) = Some (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s)) ->
      tr_instr ctx pc (Istore chunk addr args src s) c
  | tr_call: forall ctx pc c sg ros args res s,
      Ple res ctx.(mreg) ->
      c!(spc ctx pc) = Some (Icall sg (sros ctx ros) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Icall sg ros args res s) c
  | tr_call_inlined:forall ctx pc sg id args res s c f pc1 ctx',
      Ple res ctx.(mreg) ->
      fenv!id = Some f ->
      c!(spc ctx pc) = Some(Inop pc1) ->
      tr_moves c pc1 (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)) ->
      tr_funbody ctx' f c ->
      ctx'.(retinfo) = Some(spc ctx s, sreg ctx res) ->
      context_below ctx ctx' ->
      context_stack_call ctx ctx' ->
      tr_instr ctx pc (Icall sg (inr _ id) args res s) c
  | tr_tailcall: forall ctx pc c sg ros args,
      c!(spc ctx pc) = Some (Itailcall sg (sros ctx ros) (sregs ctx args)) ->
      ctx.(retinfo) = None ->
      tr_instr ctx pc (Itailcall sg ros args) c
  | tr_tailcall_call: forall ctx pc c sg ros args res s,
      c!(spc ctx pc) = Some (Icall sg (sros ctx ros) (sregs ctx args) res s) ->
      ctx.(retinfo) = Some(s, res) ->
      tr_instr ctx pc (Itailcall sg ros args) c
  | tr_tailcall_inlined: forall ctx pc sg id args c f pc1 ctx',
      fenv!id = Some f ->
      c!(spc ctx pc) = Some(Inop pc1) ->
      tr_moves c pc1 (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)) ->
      tr_funbody ctx' f c ->
      ctx'.(retinfo) = ctx.(retinfo) ->
      context_below ctx ctx' ->
      context_stack_tailcall ctx f ctx' ->
      tr_instr ctx pc (Itailcall sg (inr _ id) args) c
  | tr_builtin: forall ctx pc c ef args res s,
      Ple res ctx.(mreg) ->
      c!(spc ctx pc) = Some (Ibuiltin ef (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Ibuiltin ef args res s) c
  | tr_cond: forall ctx pc cond args s1 s2 c,
      c!(spc ctx pc) = Some (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2)) ->
      tr_instr ctx pc (Icond cond args s1 s2) c
  | tr_jumptable: forall ctx pc r tbl c,
      c!(spc ctx pc) = Some (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl)) ->
      tr_instr ctx pc (Ijumptable r tbl) c
  | tr_return: forall ctx pc or c,
      c!(spc ctx pc) = Some (Ireturn (option_map (sreg ctx) or)) ->
      ctx.(retinfo) = None ->
      tr_instr ctx pc (Ireturn or) c
  | tr_return_inlined: forall ctx pc or c rinfo,
      c!(spc ctx pc) = Some (inline_return ctx or rinfo) ->
      ctx.(retinfo) = Some rinfo ->
      tr_instr ctx pc (Ireturn or) c

with tr_funbody: context -> function -> code -> Prop :=
  | tr_funbody_intro: forall ctx f c,
      (forall r, In r f.(fn_params) -> Ple r ctx.(mreg)) ->
      (forall pc i, f.(fn_code)!pc = Some i -> tr_instr ctx pc i c) ->
      ctx.(mstk) = Zmax f.(fn_stacksize) 0 ->
      (min_alignment f.(fn_stacksize) | ctx.(dstk)) ->
      ctx.(dstk) >= 0 -> ctx.(dstk) + ctx.(mstk) <= stacksize ->
      tr_funbody ctx f c.

Definition fenv_agree (fe: funenv) : Prop :=
  forall id f, fe!id = Some f -> fenv!id = Some f.

Section EXPAND_INSTR.

Variable fe: funenv.
Hypothesis FE: fenv_agree fe.

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

Hypothesis rec_unchanged:
  forall fe' (L: (size_fenv fe' < size_fenv fe)%nat) ctx f s x s' i pc,
  rec fe' L ctx f s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Ple pc ctx.(dpc) ->
  s'.(st_code)!pc = s.(st_code)!pc.

Remark set_instr_other:
  forall pc instr s x s' i pc',
  set_instr pc instr s = R x s' i ->
  pc' <> pc ->
  s'.(st_code)!pc' = s.(st_code)!pc'.
Proof.
  intros. monadInv H; simpl. apply PTree.gso; auto.
Qed.

Remark set_instr_same:
  forall pc instr s x s' i c,
  set_instr pc instr s = R x s' i ->
  c!(pc) = s'.(st_code)!pc ->
  c!(pc) = Some instr.
Proof.
  intros. rewrite H0. monadInv H; simpl. apply PTree.gss.
Qed.

Lemma expand_instr_unchanged:
  forall ctx pc instr s x s' i pc',
  expand_instr fe rec ctx pc instr s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Ple pc' s.(st_nextnode) ->
  pc' <> spc ctx pc ->
  s'.(st_code)!pc' = s.(st_code)!pc'.
Proof.
  generalize set_instr_other; intros A.
  intros. unfold expand_instr in H; destruct instr; eauto.
(* call *)
  destruct (can_inline fe s1). eauto.
  monadInv H. unfold inline_function in EQ. monadInv EQ.
  transitivity (s2.(st_code)!pc'). eauto.
  transitivity (s5.(st_code)!pc'). eapply add_moves_unchanged; eauto.
    left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. xomega.
  transitivity (s4.(st_code)!pc'). eapply rec_unchanged; eauto.
    simpl. monadInv EQ; simpl. monadInv EQ1; simpl. xomega.
    simpl. monadInv EQ1; simpl. auto.
  monadInv EQ; simpl. monadInv EQ1; simpl. auto.
(* tailcall *)
  destruct (can_inline fe s1).
  destruct (retinfo ctx) as [[rpc rreg]|]; eauto.
  monadInv H. unfold inline_tail_function in EQ. monadInv EQ.
  transitivity (s2.(st_code)!pc'). eauto.
  transitivity (s5.(st_code)!pc'). eapply add_moves_unchanged; eauto.
    left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. xomega.
  transitivity (s4.(st_code)!pc'). eapply rec_unchanged; eauto.
    simpl. monadInv EQ; simpl. monadInv EQ1; simpl. xomega.
    simpl. monadInv EQ1; simpl. auto.
  monadInv EQ; simpl. monadInv EQ1; simpl. auto.
(* return *)
  destruct (retinfo ctx) as [[rpc rreg]|]; eauto.
Qed.

Lemma iter_expand_instr_unchanged:
  forall ctx pc l s x s' i,
  mlist_iter2 (expand_instr fe rec ctx) l s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Ple pc s.(st_nextnode) ->
  ~In pc (List.map (spc ctx) (List.map (@fst _ _) l)) ->
  list_norepet (List.map (@fst _ _) l) ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  induction l; simpl; intros.
  (* base case *)
  monadInv H. auto.
  (* inductive case *)
  destruct a as [pc1 instr1]; simpl in *.
  monadInv H. inv H3.
  transitivity ((st_code s0)!pc).
  eapply IHl; eauto. destruct INCR; xomega. destruct INCR; xomega.
  eapply expand_instr_unchanged; eauto.
Qed.

Lemma expand_cfg_rec_unchanged:
  forall ctx f s x s' i pc,
  expand_cfg_rec fe rec ctx f s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Ple pc ctx.(dpc) ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  intros. unfold expand_cfg_rec in H. monadInv H. inversion EQ.
  transitivity ((st_code s0)!pc).
  eapply iter_expand_instr_unchanged; eauto.
    subst s0; auto.
    subst s0; simpl. xomega.
    red; intros. exploit list_in_map_inv; eauto. intros [pc1 [A B]].
    subst pc. unfold spc in H1. xomega.
    apply PTree.elements_keys_norepet.
  subst s0; auto.
Qed.

Hypothesis rec_spec:
  forall fe' (L: (size_fenv fe' < size_fenv fe)%nat) ctx f s x s' i c,
  rec fe' L ctx f s = R x s' i ->
  fenv_agree fe' ->
  Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) ->
  ctx.(mreg) = max_def_function f ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 ->
  ctx.(mstk) = Zmax (fn_stacksize f) 0 ->
  (min_alignment (fn_stacksize f) | ctx.(dstk)) ->
  ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc, Plt ctx.(dpc) pc -> Ple pc s'.(st_nextnode) -> c!pc = s'.(st_code)!pc) ->
  tr_funbody ctx f c.

Remark min_alignment_pos:
  forall sz, min_alignment sz > 0.
Proof.
  intros; unfold min_alignment.
  destruct (zle sz 1). omega. destruct (zle sz 2). omega. destruct (zle sz 4); omega.
Qed.

Ltac inv_incr :=
  match goal with
  | [ H: sincr _ _ |- _ ] => destruct H; inv_incr
  | _ => idtac
  end.

Lemma expand_instr_spec:
  forall ctx pc instr s x s' i c,
  expand_instr fe rec ctx pc instr s = R x s' i ->
  Ple (max_def_instr instr) ctx.(mreg) ->
  Ple (spc ctx pc) s.(st_nextnode) ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 -> ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Plt s.(st_nextnode) pc' -> Ple pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  c!(spc ctx pc) = s'.(st_code)!(spc ctx pc) ->
  tr_instr ctx pc instr c.
Proof.
  intros until c; intros EXP DEFS OPC OREG STK1 STK2 STK3 S1 S2.
  generalize set_instr_same; intros BASE.
  unfold expand_instr in EXP; destruct instr; simpl in DEFS;
  try (econstructor; eauto; fail).
(* call *)
  destruct (can_inline fe s1) as [|id f P Q].
  (* not inlined *)
  eapply tr_call; eauto.
  (* inlined *)
  subst s1.
  monadInv EXP. unfold inline_function in EQ; monadInv EQ.
  set (ctx' := callcontext ctx x1 x2 (max_def_function f) (fn_stacksize f) n r).
  inversion EQ0; inversion EQ1; inversion EQ. inv_incr.
  apply tr_call_inlined with (pc1 := x0) (ctx' := ctx') (f := f); auto.
  eapply BASE; eauto.
  eapply add_moves_spec; eauto.
    intros. rewrite S1. eapply set_instr_other; eauto. unfold node; xomega. xomega. xomega.
  eapply rec_spec; eauto.
    red; intros. rewrite PTree.grspec in H. destruct (PTree.elt_eq id0 id); try discriminate. auto.
    simpl. subst s2; simpl in *; xomega.
    simpl. subst s3; simpl in *; xomega.
    simpl. xomega.
    simpl. apply align_divides. apply min_alignment_pos.
    assert (dstk ctx + mstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. omega.
    omega.
    intros. simpl in H. rewrite S1.
    transitivity s1.(st_code)!pc0. eapply set_instr_other; eauto. unfold node in *; xomega.
    eapply add_moves_unchanged; eauto. unfold node in *; xomega. xomega.
  red; simpl. subst s2; simpl in *; xomega.
  red; simpl. split. auto. apply align_le. apply min_alignment_pos.
(* tailcall *)
  destruct (can_inline fe s1) as [|id f P Q].
  (* not inlined *)
  destruct (retinfo ctx) as [[rpc rreg] | ] eqn:?.
  (* turned into a call *)
  eapply tr_tailcall_call; eauto.
  (* preserved *)
  eapply tr_tailcall; eauto.
  (* inlined *)
  subst s1.
  monadInv EXP. unfold inline_function in EQ; monadInv EQ.
  set (ctx' := tailcontext ctx x1 x2 (max_def_function f) (fn_stacksize f)) in *.
  inversion EQ0; inversion EQ1; inversion EQ. inv_incr.
  apply tr_tailcall_inlined with (pc1 := x0) (ctx' := ctx') (f := f); auto.
  eapply BASE; eauto.
  eapply add_moves_spec; eauto.
    intros. rewrite S1. eapply set_instr_other; eauto. unfold node; xomega. xomega. xomega.
  eapply rec_spec; eauto.
    red; intros. rewrite PTree.grspec in H. destruct (PTree.elt_eq id0 id); try discriminate. auto.
    simpl. subst s2; simpl in *; xomega.
    simpl. subst s3; simpl in *; xomega.
    simpl. xomega.
    simpl. apply align_divides. apply min_alignment_pos.
    assert (dstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. omega.
    omega.
    intros. simpl in H. rewrite S1.
    transitivity s1.(st_code)!pc0. eapply set_instr_other; eauto. unfold node in *; xomega.
    eapply add_moves_unchanged; eauto. unfold node in *; xomega. xomega.
  red; simpl. subst s2; simpl in *; xomega.
  red; auto.
(* return *)
  destruct (retinfo ctx) as [[rpc rreg] | ] eqn:?.
  (* inlined *)
  eapply tr_return_inlined; eauto.
  (* unchanged *)
  eapply tr_return; eauto.
Qed.

Lemma iter_expand_instr_spec:
  forall ctx l s x s' i c,
  mlist_iter2 (expand_instr fe rec ctx) l s = R x s' i ->
  list_norepet (List.map (@fst _ _) l) ->
  (forall pc instr, In (pc, instr) l -> Ple (max_def_instr instr) ctx.(mreg)) ->
  (forall pc instr, In (pc, instr) l -> Ple (spc ctx pc) s.(st_nextnode)) ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 -> ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Plt s.(st_nextnode) pc' -> Ple pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  (forall pc instr, In (pc, instr) l -> c!(spc ctx pc) = s'.(st_code)!(spc ctx pc)) ->
  forall pc instr, In (pc, instr) l -> tr_instr ctx pc instr c.
Proof.
  induction l; simpl; intros.
  (* base case *)
  contradiction.
  (* inductive case *)
  destruct a as [pc1 instr1]; simpl in *. inv H0. monadInv H. inv_incr.
  assert (A: Ple ctx.(dpc) s0.(st_nextnode)).
    assert (B: Ple (spc ctx pc) (st_nextnode s)) by eauto. unfold spc in B; xomega.
  destruct H9. inv H.
  (* same pc *)
  eapply expand_instr_spec; eauto.
  omega.
  intros.
    transitivity ((st_code s')!pc').
    apply H7. auto. xomega.
    eapply iter_expand_instr_unchanged; eauto.
    red; intros. rewrite list_map_compose in H9. exploit list_in_map_inv; eauto.
    intros [[pc0 instr0] [P Q]]. simpl in P.
    assert (Ple (spc ctx pc0) (st_nextnode s)) by eauto. xomega.
  transitivity ((st_code s')!(spc ctx pc)).
    eapply H8; eauto.
    eapply iter_expand_instr_unchanged; eauto.
    assert (Ple (spc ctx pc) (st_nextnode s)) by eauto. xomega.
    red; intros. rewrite list_map_compose in H. exploit list_in_map_inv; eauto.
    intros [[pc0 instr0] [P Q]]. simpl in P. unfold spc in P.
    assert (pc = pc0) by (unfold node; xomega). subst pc0.
    elim H12. change pc with (fst (pc, instr0)). apply List.in_map; auto.
  (* older pc *)
  inv_incr. eapply IHl; eauto.
  intros. eapply Ple_trans; eauto.
  intros; eapply Ple_trans; eauto.
  intros. apply H7; auto. xomega.
Qed.

Lemma expand_cfg_rec_spec:
  forall ctx f s x s' i c,
  expand_cfg_rec fe rec ctx f s = R x s' i ->
  Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) ->
  ctx.(mreg) = max_def_function f ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 ->
  ctx.(mstk) = Zmax (fn_stacksize f) 0 ->
  (min_alignment (fn_stacksize f) | ctx.(dstk)) ->
  ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Plt ctx.(dpc) pc' -> Ple pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  tr_funbody ctx f c.
Proof.
  intros. unfold expand_cfg_rec in H. monadInv H. inversion EQ.
  constructor.
  intros. rewrite H1. eapply max_def_function_params; eauto.
  intros. eapply iter_expand_instr_spec; eauto.
    apply PTree.elements_keys_norepet.
    intros. rewrite H1. eapply max_def_function_instr; eauto.
    eapply PTree.elements_complete; eauto.
  intros.
    assert (Ple pc0 (max_pc_function f)).
      eapply max_pc_function_sound. eapply PTree.elements_complete; eauto.
    unfold spc. subst s0; simpl; xomega.
  subst s0; simpl; auto.
  intros. apply H8; auto. subst s0; simpl in H11; xomega.
  intros. apply H8. unfold spc; xomega.
    assert (Ple pc0 (max_pc_function f)).
      eapply max_pc_function_sound. eapply PTree.elements_complete; eauto.
    unfold spc. inversion i; xomega.
  apply PTree.elements_correct; auto.
  auto. auto. auto.
  inversion INCR0. subst s0; simpl in STKSIZE; xomega.
Qed.

End EXPAND_INSTR.

Lemma expand_cfg_unchanged:
  forall fe ctx f s x s' i pc,
  expand_cfg fe ctx f s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Ple pc ctx.(dpc) ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  intros fe0; pattern fe0. apply well_founded_ind with (R := ltof _ size_fenv).
  apply well_founded_ltof.
  intros. unfold expand_cfg in H0. rewrite unroll_Fixm in H0.
  eapply expand_cfg_rec_unchanged; eauto. assumption.
Qed.

Lemma expand_cfg_spec:
  forall fe ctx f s x s' i c,
  expand_cfg fe ctx f s = R x s' i ->
  fenv_agree fe ->
  Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) ->
  ctx.(mreg) = max_def_function f ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 ->
  ctx.(mstk) = Zmax (fn_stacksize f) 0 ->
  (min_alignment (fn_stacksize f) | ctx.(dstk)) ->
  ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Plt ctx.(dpc) pc' -> Ple pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  tr_funbody ctx f c.
Proof.
  intros fe0; pattern fe0. apply well_founded_ind with (R := ltof _ size_fenv).
  apply well_founded_ltof.
  intros. unfold expand_cfg in H0. rewrite unroll_Fixm in H0.
  eapply expand_cfg_rec_spec; eauto.
  simpl. intros. eapply expand_cfg_unchanged; eauto. assumption.
Qed.

End INLINING_BODY_SPEC.

(** ** Relational specification of the translation of a function *)

Inductive tr_function: function -> function -> Prop :=
  | tr_function_intro: forall f f' ctx,
      tr_funbody f'.(fn_stacksize) ctx f f'.(fn_code) ->
      ctx.(dstk) = 0 ->
      ctx.(retinfo) = None ->
      f'.(fn_sig) = f.(fn_sig) ->
      f'.(fn_params) = sregs ctx f.(fn_params) ->
      f'.(fn_entrypoint) = spc ctx f.(fn_entrypoint) ->
      0 <= fn_stacksize f' < Int.max_unsigned ->
      tr_function f f'.

Lemma transf_function_spec:
  forall f f', transf_function fenv f = OK f' -> tr_function f f'.
Proof.
  intros. unfold transf_function in H.
  destruct (expand_function fenv f initstate) as [ctx s i] eqn:?.
  destruct (zlt (st_stksize s) Int.max_unsigned); inv H.
  monadInv Heqr. set (ctx := initcontext x x0 (max_def_function f) (fn_stacksize f)) in *.
Opaque initstate.
  destruct INCR3. inversion EQ1. inversion EQ.
  apply tr_function_intro with ctx; auto.
  eapply expand_cfg_spec with (fe := fenv); eauto.
    red; auto.
    unfold ctx; rewrite <- H1; rewrite <- H2; rewrite <- H3; simpl. xomega.
    unfold ctx; rewrite <- H0; rewrite <- H1; simpl. xomega.
    simpl. xomega.
    simpl. apply Zdivide_0.
    simpl. omega.
  simpl. omega.
  simpl. split; auto. destruct INCR2. destruct INCR1. destruct INCR0. destruct INCR.
  simpl. change 0 with (st_stksize initstate). omega.
Qed.

End INLINING_SPEC.


From hahn Require Import Hahn.
From PromisingLib Require Import Basic DenseOrder Loc.

From imm Require Import Events.
From imm Require Import Execution.
From imm Require Import imm_s.
From imm Require Import imm_s_hb.
From imm Require Import imm_bob imm_s_ppo.
From imm Require Import CombRelations.
From imm Require Import CombRelationsMore.
(* Require Import TraversalConfig. *)
From imm Require Import TraversalOrder.
From imm Require Import TLSCoherency.
From imm Require Import IordCoherency.
From imm Require Import SimClosure.
Require Import TlsEventSets.
Require Import Next.
Require Import EventsTraversalOrder.

Set Implicit Arguments.

Section ViewRelHelpers.

Variable G : execution.
Variable WF : Wf G.
Variable sc : relation actid.
Variable IMMCON : imm_consistent G sc.

Notation "'co'" := (co G).
Notation "'sw'" := (sw G).
Notation "'hb'" := (hb G).
Notation "'sb'" := (sb G).
Notation "'rf'" := (rf G).
Notation "'rfi'" := (rfi G).
Notation "'rfe'" := (rfe G).
Notation "'rmw'" := (rmw G).
Notation "'lab'" := (lab G).
Notation "'release'" := (release G).

Notation "'Init'" := (fun a => is_true (is_init a)).
Notation "'E'" := (acts_set G).
Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'W_ex'" := (W_ex G).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'Loc_' l" := (fun x => loc lab x = Some l) (at level 1).
Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'W_' l" := (W ∩₁ Loc_ l) (at level 1).

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

Context
  (T : trav_label -> Prop)
  (TLSCOH  : tls_coherent G T)
  (IORDCOH : iord_coherent G sc T).

Lemma msg_rel_co_irr l :
  irreflexive (msg_rel G sc l ⨾ co).
Proof using WF IMMCON.
  unfold msg_rel.
  intros x AA.
  destruct AA as [y [[z [AA BB]] CC]].
  eapply release_co_urr_irr; eauto.
  1-4: by apply IMMCON.
  eexists; split; [|eexists]; eauto.
Qed.

Lemma s_tm_cov_sc_fence
      f ordf thread
      (TID: tid f = thread)
      (RELCOV : W ∩₁ Rel ∩₁ issued T ⊆₁ covered T)
      (NEXT : next G (covered T) f)
      (FPARAMS : lab f = Afence ordf)
      (SC : Sc f) :
  forall l,
    S_tm G l (covered T ∪₁ eq f) ≡₁
    S_tm G l (covered T) ∪₁ t_acq G sc thread l (covered T).
Proof using WF TLSCOH IORDCOH IMMCON.
  cdes IMMCON.
  intro l; split.
  - unfold S_tm, t_acq.
    rewrite s_tmr_union; relsf; unionL; splits; [basic_solver|].
    unionR right.
    rewrite (s_tmr_helper _ _ WF).
    unfold c_acq, urr.
    arewrite (sb ⨾ ⦗F ∩₁ Sc⦘ ⨾ ⦗eq f⦘ ⊆ ⦗covered T⦘ ⨾ sb ⨾ ⦗eq f⦘).
      by revert NEXT; unfold next, dom_cond; basic_solver 21.
    arewrite (⦗covered T⦘ ⨾ sb ⨾ ⦗eq f⦘ ⊆ ⦗Tid_ thread ∪₁ Init⦘ ⨾ ⦗covered T⦘ ⨾ sb^?).
      by unfolder; ins; desf; splits; eauto using sb_tid_init.
    basic_solver 42.
  - unionL; [by unfold S_tm; rewrite s_tmr_union; basic_solver|].
  unfold t_acq, S_tm.
  rewrite s_tmr_union.
  relsf.
  unfold c_acq, urr.
  rewrite (crE sc); relsf; unionL; splits.
  { unionR right.
    rewrite (s_tmr_helper _ _ WF).
    arewrite (⦗Tid_ thread ∪₁ Init⦘ ⨾ ⦗covered T⦘ ⊆ ⦗dom_rel(sb ⨾ ⦗eq f⦘)⦘).
    { rewrite <- TID; rewrite next_helper'; eauto. basic_solver. }
    arewrite (⦗eq f⦘ ⊆ ⦗F ∩₁ Sc⦘ ⨾ ⦗eq f⦘) at 1 by type_solver.
    basic_solver 42. }
  arewrite (⦗Tid_ thread ∪₁ Init⦘ ⨾ ⦗covered T⦘ ⊆ ⦗covered T⦘ ⨾ ⦗Tid_ thread ∪₁ Init⦘).
  basic_solver.

  arewrite ((release ⨾ rf)^? ⨾ ⦗covered T⦘ ⊆ ⦗covered T⦘ ⨾ (release ⨾ rf)^?).
  { by case_refl _;
      [basic_solver| rewrite !seqA; rewrite release_rf_covered; auto; basic_solver]. }
  arewrite (hb^? ⨾ ⦗covered T⦘ ⊆ ⦗covered T⦘ ⨾ hb^?).
  { by case_refl _; [basic_solver| rewrite hb_covered; auto; basic_solver]. }
  arewrite (⦗W_ l⦘ ⨾ rf^? ⨾ (hb ⨾ ⦗F ∩₁ Sc⦘)^? ⨾ sc ⊆ ⦗W_ l⦘ ⨾ rf^? ⨾ hb ⨾ ⦗F ∩₁ Sc⦘ ⨾ sc).
  rewrite (dom_l (@wf_scD G sc Wf_sc)) at 1; rewrite (dom_r (wf_rfD WF)) at 1; hahn_frame_r; type_solver 42.

  arewrite (sc ⨾ ⦗covered T⦘ ⊆ ⦗covered T⦘ ⨾ sc).
  { now eapply sc_covered; eauto. }
  unfold S_tmr; basic_solver 21.
Qed.

Lemma msg_rel_alt
      (Wf_sc : wf_sc G sc)
      w (WW : W w) (NCOV : ~ covered T w) (ISS : issuable G sc T w)
      locw (LOC : loc lab w = Some locw) l:
  dom_rel (msg_rel G sc l ⨾ ⦗ eq w ⦘) ≡₁
  (if is_rel lab w
   then t_cur G sc (tid w) l (covered T ∪₁ eq w)
   else t_rel G sc (tid w) l locw (covered T)) ∪₁
  dom_rel (msg_rel G sc l ⨾ (rf ⨾ rmw) ⨾ ⦗ eq w ⦘).
Proof using WF TLSCOH IORDCOH IMMCON.
  assert (E w) as EW.
  { apply ISS. }
  assert (~ is_init w) as WNIT.
  { intros H. apply NCOV. eapply init_covered; vauto. }

  assert (Rel w -> dom_rel (sb ⨾ ⦗eq w⦘) ≡₁ (Tid_ (tid w) ∪₁ Init) ∩₁ covered T) as TT.
  { intros REL. split.
    { intros x [y H]. apply seq_eqv_r in H; desf.
      split.
      { by destruct (sb_tid_init H); [left|right]. }

      eapply fwbob_issuable_in_C; eauto. eexists. apply seq_eqv_r. split; eauto.
      apply sb_to_w_rel_in_fwbob. apply seq_eqv_r. split; vauto. }
    intros x [TIDIN COV]. exists w.
    apply seq_eqv_r; split; auto.
    assert (E x) as EX by (eapply coveredE; eauto).
    destruct TIDIN as [TID|INIT].
    2: by eapply init_ninit_sb; eauto.
    edestruct same_thread as [H|H].
    3: by apply WNIT.
    { apply ISS. }
    { apply EX. }
    1,3: done.
    exfalso.
    destruct H as [|H]; [by desf|].
    apply NCOV.
    eapply dom_sb_covered; eauto. eexists. apply seq_eqv_r. split; eauto. }
  assert (Rel w -> dom_rel (sb ⨾ ⦗eq w⦘) ⊆₁ covered T) as TT'.
  { intros H. rewrite (TT H). basic_solver. }

  assert (~ Rel w ->
          ⦗Rel⦘ ⨾ fwbob G ⨾ ⦗eq w⦘ ⊆
          ⦗Rel⦘ ⨾ ⦗W_ locw ∪₁ F⦘ ⨾ ⦗Tid_ (tid w) ∪₁ Init⦘ ⨾ ⦗covered T⦘ ⨾ sb ⨾ ⦗eq w⦘) as QQ.
  { intros HH.
    arewrite (fwbob G ⨾ ⦗eq w⦘ ⊆ ⦗covered T⦘ ⨾ fwbob G ⨾ ⦗eq w⦘).
    { intros x y H. apply seq_eqv_l; split; [|done].
      apply seq_eqv_r in H. desc. subst.
      eapply fwbob_issuable_in_C; eauto. eexists. apply seq_eqv_r. split; eauto. }
    unfold fwbob; rewrite !seq_union_l. rewrite !seqA.
    arewrite (⦗W ∩₁ Rel⦘ ⨾ ⦗eq w⦘ ⊆ ∅₂) by basic_solver.
    arewrite (⦗F ∩₁ (fun a : actid => is_ra lab a)⦘ ⨾ ⦗eq w⦘ ⊆ ∅₂) by type_solver.
    relsf; unionL.
    - unfold same_loc; unfolder; ins; desf; splits; eauto.
      by left; splits; congruence.
      by apply (@sb_tid_init G).
    - generalize (@sb_tid_init G).
      basic_solver 21. }

  unfold msg_rel at 1.
  unfold imm_s_hb.release.
  unfold imm_s_hb.rs.
  rewrite rtE.
  rewrite !seq_union_r. rewrite seq_union_l.
  rewrite dom_union. apply set_equiv_union.
  2: { apply dom_rel_more.
       unfold msg_rel at 1. unfold imm_s_hb.release. unfold imm_s_hb.rs.
       rewrite ct_end. basic_solver. }
  rewrite seq_id_r.
  unfold t_cur, t_rel.
  split.
  { rewrite !seqA.
    arewrite (⦗Rel⦘ ⨾ (⦗F⦘ ⨾ sb)^? ⨾ ⦗W⦘ ⨾ (sb ∩ same_loc lab)^? ⨾ ⦗W⦘ ⨾ ⦗eq w⦘ ⊆
              ⦗Rel⦘ ⨾ fwbob G ⨾ ⦗eq w⦘ ∪ ⦗Rel ∩₁ eq w⦘).
    { case_refl _; case_refl _.
      { basic_solver. }
      all: unfold fwbob.
      { basic_solver 42. }
      all: arewrite (⦗Rel⦘ ⨾ ⦗F⦘ ⊆ ⦗Rel⦘ ⨾ ⦗F ∩₁ (fun a => is_ra lab a)⦘) by mode_solver.
      2: arewrite (sb ⨾ ⦗W⦘ ⨾ sb ∩ same_loc lab ⊆ sb) by
          (generalize (@sb_trans G); basic_solver).
      all: basic_solver 42. }
    rewrite seq_union_r.
    desf.
    { arewrite (Rel ∩₁ eq w ≡₁ eq w); [basic_solver|].
      arewrite (urr G sc l ⨾ ⦗Rel⦘ ⨾ fwbob G ⨾ ⦗eq w⦘ ∪ urr G sc l ⨾ ⦗eq w⦘ ⊆
                urr G sc l ⨾ ⦗eq w⦘).
      { rewrite union_absorb_l; [done|].
        hahn_frame. etransitivity.
        2: by apply urr_hb.
        hahn_frame.
        rewrite fwbob_in_bob. rewrite bob_in_sb.
        rewrite sb_in_hb. basic_solver. }
      rewrite urr_w_alt_union_eqv; auto.
      apply dom_rel_mori.
      arewrite (⦗eq w⦘ ⊆ ⦗W⦘ ⨾ ⦗eq w⦘) at 1 by basic_solver.
      seq_rewrite (urr_w WF); relsf; unionL; [unionR left| basic_solver 12].
      generalize (TT' Heq); basic_solver 21. }
    arewrite (Rel ∩₁ eq w ≡₁ ∅) by basic_solver.
    rewrite <- dom_rel_ext with
        (r := c_rel G sc (tid w) l locw (covered T))
        (r' := (sb ⨾ ⦗ eq w ⦘) ).
    apply dom_rel_mori.
    unfold c_rel.
    rewrite crE. rewrite !seq_union_r. unionR right.
    rewrite !seqA; rewrite QQ; [basic_solver 12| by rewrite Heq]. }
  desf.
  { rewrite urr_w_alt_union_eqv; auto.
    relsf; unionL; splits; [|unfold urr; basic_solver 42].
    rewrite crE at 1; relsf; unionL; splits.
    - rewrite seq_eqvC; rewrite <- id_inter.
      rewrite <- (TT Heq).
      rewrite dom_rel_eqv_dom_rel.
      apply dom_rel_mori.
      rewrite !crE; relsf.
      unionR left -> left. rewrite !seqA.
      arewrite (⦗eq w⦘ ⊆ ⦗Rel⦘ ⨾ ⦗eq w⦘) at 1 by basic_solver.
      arewrite (⦗eq w⦘ ⊆ ⦗W⦘ ⨾ ⦗eq w⦘) at 1 by basic_solver.
      hahn_frame. etransitivity;[|by apply urr_hb].
      rewrite sb_in_hb. basic_solver.
    - rewrite sb_in_hb at 1.
      arewrite (hb ⊆ hb^?) at 1 .
      arewrite_id ⦗covered T⦘; rels.
      sin_rewrite (@urr_hb G sc l).
      basic_solver 21. }
  unfold c_rel.
  rewrite <- !id_inter.
  intros x [y [z [HH [H'' JJ]]]]; subst.
  exists w. apply seq_eqv_r; split; auto.
  exists y; split; auto.
  destruct JJ as [JJ1 [JJ2 [JJ3 JJ4]]].
  assert (E y) as EY by (eapply coveredE; eauto).
  assert (sb y w) as SBYW.
  { destruct JJ3 as [TID|INIT].
    2: by eapply init_ninit_sb; eauto.
    edestruct same_thread as [H|H].
    3: by apply WNIT.
    { apply ISS. }
    { apply EY. }
    1,3: done.
    exfalso.
    destruct H as [|H]; [by desf|].
    apply NCOV.
    eapply dom_sb_covered; eauto. eexists. apply seq_eqv_r. split; eauto. }
  apply seq_eqv_l; split; auto.
  destruct JJ2.
  { exists y; split; [by left|].
    apply seq_eqv_l; split; [apply H|].
    apply seq_eqv_r; split; auto.
    right; split; auto. red. rewrite LOC; apply H. }
  basic_solver 12.
Qed.

Lemma msg_rel_alt2
      (Wf_sc : wf_sc G sc)
      w (WW : W w) (NCOV : ~ covered T w) (ISS : issuable G sc T w)
      locw (LOC : loc lab w = Some locw) l:
  dom_rel (msg_rel G sc l ⨾ ⦗ eq w ⦘) ≡₁
  (if is_rel lab w
   then t_cur G sc (tid w) l (covered T)
   else t_rel G sc (tid w) l locw (covered T)) ∪₁
  dom_rel (msg_rel G sc l ⨾ (rf ⨾ rmw) ⨾ ⦗ eq w ⦘) ∪₁
  Rel ∩₁ Loc_ l ∩₁ eq w.
Proof using WF TLSCOH IORDCOH IMMCON.
  rewrite msg_rel_alt; eauto.
  desf.
  2: by arewrite (Rel ∩₁ Loc_ l ∩₁ eq w ≡₁ ∅); basic_solver 10.
  rewrite t_cur_urr_union_eqv_w; auto.
  { arewrite (Rel ∩₁ Loc_ l ∩₁ eq w ≡₁ Loc_ l ∩₁ eq w).
    2: by unfold t_cur, c_cur; basic_solver 10.
    basic_solver 10. }
  etransitivity; [| apply fwbob_issuable_in_C]; eauto.
  generalize (@sb_to_w_rel_in_fwbob G) Heq. basic_solver 10.
Qed.

Lemma msg_rel_rfrmw_helper
      w (WW : W w) (NCOV : ~ covered T w) (ISS : issuable G sc T w)
      locw (LOC : loc lab w = Some locw) l:
  dom_rel ((urr G sc l ⨾ release) ⨾ (rf ⨾ rmw) ⨾ ⦗eq w⦘) ⊆₁
  dom_rel (urr G sc l ⨾ ⦗Rel⦘ ⨾ ⦗W_ locw ∪₁ F⦘ ⨾ ⦗Tid_ (tid w) ∪₁ Init⦘ ⨾ ⦗covered T⦘)
  ∪₁ dom_rel ((urr G sc l ⨾ release) ⨾ (⦗W_ex⦘ ⨾ rfi ∪ rfe) ⨾ rmw ⨾ ⦗eq w⦘).
Proof using WF TLSCOH IMMCON.
rewrite rfi_union_rfe; relsf; unionL; splits.
2: basic_solver 12.
unfold imm_s_hb.release.
unfold imm_s_hb.rs.
rewrite rtE; relsf.
unionL; splits; cycle 1.
rewrite rmw_W_ex at 1.
rewrite <- !seqA.
rewrite inclusion_ct_seq_eqv_r.
unionR right -> left -> right; basic_solver 21.
unionR left.
rewrite !seqA.
arewrite ((sb ∩ same_loc lab)^? ⨾ ⦗W⦘ ⨾ rfi ⨾ rmw ⊆ sb ∩ same_loc lab).
{ arewrite_id ⦗W⦘; rewrite (rfi_in_sbloc' WF), (rmw_in_sb_loc WF).
  generalize (@sb_same_loc_trans G); ins; relsf. }
arewrite (⦗Rel⦘ ⨾ (⦗F⦘ ⨾ sb)^? ⨾ ⦗W⦘ ⨾ sb ∩ same_loc lab ⨾ ⦗eq w⦘
   ⊆ ⦗Rel⦘ ⨾ ⦗W_ locw ∪₁ F⦘ ⨾ ⦗Tid_ (tid w) ∪₁ Init⦘ ⨾ fwbob G ⨾ ⦗eq w⦘).
{
rewrite crE at 1; relsf; unionL.
- unfold fwbob.
rewrite sb_tid_init' at 1.
rewrite (init_pln WF) at 1.
unfold same_tid.
relsf.
unionR left -> left -> right.
unfolder; ins; desf; splits; eauto 20.
unfold same_loc in *; desf; eauto; left; splits; congruence.
unfold same_loc in *; desf; eauto; left; splits; congruence.
mode_solver 42.
-
rewrite !seqA.
arewrite (sb ⨾ ⦗W⦘ ⨾ sb ∩ same_loc lab ⊆ sb).
by generalize (@sb_trans G); basic_solver.
arewrite (⦗Rel⦘ ⨾ ⦗F⦘ ⨾ sb ⨾ ⦗eq w⦘ ⊆ ⦗Rel⦘ ⨾ ⦗F⦘ ⨾ ⦗Tid_ (tid w)⦘ ⨾ fwbob G ⨾ ⦗eq w⦘).
{ unfold fwbob.
rewrite sb_tid_init' at 1.
rewrite (init_w WF).
unfold same_tid.
mode_solver 21. }
basic_solver.

}

arewrite (⦗eq w⦘ ⊆ ⦗dom_cond (fwbob G) (covered T)⦘).
{ apply eqv_rel_mori. apply set_subset_eq.
  eapply AuxDef.dom_rel_to_cond; eauto. apply fwbob_issuable_in_C; auto. }
rewrite dom_cond_elim.
basic_solver 12.
Qed.

Lemma t_rel_msg_rel_rfrmw
      w (WW : W w) (NCOV : ~ covered T w) (ISS : issuable G sc T w)
      locw (LOC : loc lab w = Some locw) l:
  t_rel G sc (tid w) l locw (covered T) ∪₁ dom_rel (msg_rel G sc l ⨾ (rf ⨾ rmw) ⨾ ⦗eq w⦘) ≡₁
  t_rel G sc (tid w) l locw (covered T) ∪₁
  dom_rel (msg_rel G sc l ⨾ (⦗ W_ex ⦘ ⨾ rfi ∪ rfe) ⨾ rmw ⨾ ⦗eq w⦘).
Proof using WF TLSCOH IMMCON.
ins; split; unionL; desf.
1,3: basic_solver.
2: rewrite rfi_union_rfe; basic_solver 12.
unfold t_rel, c_rel, msg_rel.
by apply msg_rel_rfrmw_helper.
Qed.

Lemma t_cur_msg_rel_rfrmw
      w (WW : W w) (NCOV : ~ covered T w) (ISS : issuable G sc T w) l:
  t_cur G sc (tid w) l (covered T) ∪₁ dom_rel (msg_rel G sc l ⨾ (rf ⨾ rmw) ⨾ ⦗eq w⦘) ≡₁
  t_cur G sc (tid w) l (covered T) ∪₁
  dom_rel (msg_rel G sc l ⨾ (⦗ W_ex ⦘ ⨾ rfi ∪ rfe) ⨾ rmw ⨾ ⦗eq w⦘).
Proof using WF TLSCOH IMMCON.
ins; split; unionL; desf.
1,3: basic_solver.
2: rewrite rfi_union_rfe; basic_solver 12.
unfold t_cur, c_cur, msg_rel.
assert (exists locw, loc lab w = Some locw).
by unfold loc, is_w in *; destruct (lab w); eauto.
desc.
rewrite msg_rel_rfrmw_helper; try edone.
basic_solver 21.
Qed.

Lemma t_cur_n_sc_fence_step
      (Wf_sc : wf_sc G sc)
      f (FENCE : F f) (NSC : ~ Sc f) (NEXT : next G (covered T) f)
      (RELCOV : W ∩₁ Rel ∩₁ issued T ⊆₁ covered T):
  forall l,
    t_cur G sc (tid f) l (covered T ∪₁ eq f) ≡₁
    if is_acq lab f
    then t_acq G sc (tid f) l (covered T)
    else t_cur G sc (tid f) l (covered T).
Proof using WF TLSCOH IORDCOH IMMCON.
ins; split; rewrite t_cur_union; unionL; desf.
by apply t_cur_in_t_acq.
4: basic_solver.
all: unfold t_cur, t_acq, c_cur, c_acq.
- arewrite (⦗Tid_ (tid f) ∪₁ Init⦘ ⨾ ⦗eq f⦘ ⊆ ⦗eq f⦘ ⨾ ⦗Tid_ (tid f) ∪₁ Init⦘) by basic_solver.
  arewrite (⦗eq f⦘ ⊆ ⦗ F ∩₁ set_compl Sc ⦘ ⨾ ⦗eq f⦘) by basic_solver.
  sin_rewrite (urr_f_non_sc WF); auto.
  rewrite next_helper'; basic_solver 21.
- arewrite (⦗Tid_ (tid f) ∪₁ Init⦘ ⨾ ⦗eq f⦘ ⊆ ⦗eq f⦘ ⨾ ⦗Tid_ (tid f) ∪₁ Init⦘) by basic_solver.
  arewrite (⦗eq f⦘ ⊆ ⦗ F∩₁set_compl Acq ⦘ ⨾ ⦗eq f⦘) by basic_solver.
  sin_rewrite (urr_f_non_acq WF); auto.
  rewrite next_helper'; basic_solver 21.
- rewrite crE at 1; relsf; unionL; splits; [basic_solver 12|].
  unionR right.
  rewrite next_helper'; eauto.
  rewrite <- !seqA.
  rewrite !dom_rel_eqv_dom_rel.
  rewrite !seqA.
  arewrite (⦗eq f⦘ ⊆ ⦗ F∩₁ Acq ⦘ ⨾ ⦗eq f⦘) at 1 by basic_solver.
  arewrite (release ⨾ rf ⨾ sb ⨾ ⦗F ∩₁ Acq⦘ ⊆ sw).
  unfold imm_s_hb.sw; basic_solver 16.
  arewrite (sw ⊆ hb^?).
  sin_rewrite urr_hb.
  basic_solver 21.
Qed.

Lemma t_acq_n_sc_fence_step
      (Wf_sc : wf_sc G sc)
      f (FENCE : F f) (NSC : ~ Sc f) (NEXT : next G (covered T) f):
  forall l,
    t_acq G sc (tid f) l (covered T ∪₁ eq f) ≡₁
    t_acq G sc (tid f) l (covered T).
Proof using WF TLSCOH IORDCOH IMMCON.
ins; split; rewrite t_acq_union; unionL; splits; desf; [|basic_solver].
unfold t_acq, c_acq.
arewrite (⦗Tid_ (tid f) ∪₁ Init⦘ ⨾ ⦗eq f⦘ ⊆ ⦗eq f⦘ ⨾ ⦗Tid_ (tid f) ∪₁ Init⦘) by basic_solver.
rewrite next_helper'; eauto.
rewrite <- !seqA.
rewrite !dom_rel_eqv_dom_rel.
rewrite !seqA.
rewrite (dom_r (wf_rfD WF)) at 1.
rewrite crE at 1; relsf; unionL; splits; [|type_solver].
arewrite (⦗eq f⦘ ⊆ ⦗ F∩₁set_compl Sc ⦘ ⨾ ⦗eq f⦘) at 1 by basic_solver.
sin_rewrite (urr_f_non_sc WF); auto.
basic_solver 21.
Qed.

Lemma t_rel_n_sc_fence_step
      (Wf_sc : wf_sc G sc)
      f (FENCE : F f) (NSC : ~ Sc f) (NEXT : next G (covered T) f):
  forall l l',
    t_rel G sc (tid f) l l' (covered T ∪₁ eq f) ∪₁
    (if LocSet.Facts.eq_dec l l'
     then W ∩₁ Loc_ l' ∩₁ Tid_ (tid f) ∩₁ (covered T ∪₁ eq f)
     else ∅) ≡₁
    if is_acqrel lab f
    then t_acq G sc (tid f) l (covered T)
    else
      if is_rel lab f
      then t_cur G sc (tid f) l (covered T)
      else
        t_rel G sc (tid f) l l' (covered T) ∪₁
        (if LocSet.Facts.eq_dec l l'
         then W ∩₁ Loc_ l' ∩₁ Tid_ (tid f) ∩₁ (covered T)
         else ∅).
Proof using WF TLSCOH IORDCOH IMMCON.
ins; split; try rewrite t_rel_union; unionL; desf.
by apply t_rel_in_t_acq.
by apply t_rel_in_t_cur.
all: try rewrite set_inter_union_r.
all: unionL.
all: try  basic_solver 8.
all: try type_solver.
5: unfold t_acq, c_acq, urr; basic_solver 42.
5: unfold t_cur, c_cur, urr; basic_solver 42.
all: try rewrite set_union_empty_r.
all: unfold t_rel, c_rel, t_acq, c_acq, t_cur, c_cur.
all: rewrite next_helper'; eauto.
all: rewrite <- !seqA, dom_rel_eqv_dom_rel, !seqA.
- arewrite ( ⦗Rel⦘ ⨾ ⦗W_ l' ∪₁ F⦘ ⨾ ⦗Tid_ (tid f) ∪₁ Init⦘ ⨾ ⦗eq f⦘ ⊆ ⦗F∩₁set_compl Sc⦘ ⨾ ⦗eq f⦘).
  type_solver.
  sin_rewrite (urr_f_non_sc WF); auto.
  basic_solver 21.
- arewrite ( ⦗Rel⦘ ⨾ ⦗W_ l' ∪₁ F⦘ ⨾ ⦗Tid_ (tid f) ∪₁ Init⦘ ⨾ ⦗eq f⦘ ⊆ ⦗F∩₁set_compl Acq⦘ ⨾ ⦗eq f⦘).
  mode_solver.
  sin_rewrite (urr_f_non_acq WF); auto.
  basic_solver 21.
- arewrite ( ⦗Rel⦘ ⨾ ⦗W_ l' ∪₁ F⦘ ⨾ ⦗Tid_ (tid f) ∪₁ Init⦘ ⨾ ⦗eq f⦘ ⊆ ⦗F∩₁set_compl Acq⦘ ⨾ ⦗Rel⦘ ⨾ ⦗W_ l' ∪₁ F⦘ ⨾ ⦗eq f⦘).
  mode_solver.
  sin_rewrite (urr_f_non_acq WF); auto.
  basic_solver 21.
- arewrite ( ⦗Rel⦘ ⨾ ⦗W_ l' ∪₁ F⦘ ⨾ ⦗Tid_ (tid f) ∪₁ Init⦘ ⨾ ⦗eq f⦘ ⊆ ⦗F∩₁set_compl Acq⦘ ⨾ ⦗Rel⦘ ⨾ ⦗W_ l' ∪₁ F⦘ ⨾ ⦗eq f⦘).
  mode_solver.
  sin_rewrite (urr_f_non_acq WF); auto.
  basic_solver 21.
- arewrite ((release ⨾ rf)^? ⨾ sb ⨾ ⦗eq f⦘ ⊆ hb^? ⨾ ⦗eq f⦘) at 1.
  { rewrite crE at 1; relsf; unionL.
    arewrite (sb ⊆ hb^?) at 1; basic_solver.
    arewrite (⦗eq f⦘ ⊆ ⦗ F∩₁ Acq ⦘ ⨾ ⦗eq f⦘) at 1 by mode_solver.
    arewrite (release ⨾ rf ⨾ sb ⨾ ⦗F ∩₁ Acq⦘ ⊆ sw).
    unfold imm_s_hb.sw; basic_solver 16.
    arewrite (sw ⊆ hb^?); basic_solver. }
  sin_rewrite urr_hb.
  arewrite (⦗eq f⦘ ⊆ ⦗ F∩₁ Rel ⦘ ⨾ ⦗eq f⦘) at 1 by mode_solver.
  basic_solver 21.
- arewrite ((release ⨾ rf)^? ⨾ sb ⨾ ⦗eq f⦘ ⊆ hb^? ⨾ ⦗eq f⦘) at 1.
  { rewrite crE at 1; relsf; unionL.
    arewrite (sb ⊆ hb^?) at 1; basic_solver.
    arewrite (⦗eq f⦘ ⊆ ⦗ F∩₁ Acq ⦘ ⨾ ⦗eq f⦘) at 1 by mode_solver.
    arewrite (release ⨾ rf ⨾ sb ⨾ ⦗F ∩₁ Acq⦘ ⊆ sw).
    unfold imm_s_hb.sw; basic_solver 16.
    arewrite (sw ⊆ hb^?); basic_solver. }
  sin_rewrite urr_hb.
  arewrite (⦗eq f⦘ ⊆ ⦗ F∩₁ Rel ⦘ ⨾ ⦗eq f⦘) at 1 by mode_solver.
  basic_solver 21.
- arewrite (sb ⊆ hb^?) at 1.
  sin_rewrite urr_hb.
  basic_solver 21.
- arewrite (sb ⊆ hb^?) at 1.
  sin_rewrite urr_hb.
  basic_solver 21.
Qed.

Lemma sc_helper' (Wf_sc : wf_sc G sc)
 f (FENCE : F f) (SC : Sc f) (COV : coverable G sc T f) (NCOV : ~ covered T f) :
 ⦗F ∩₁ Sc⦘ ⨾ ⦗covered T⦘ ≡ ⦗dom_rel (sc ⨾ ⦗eq f⦘)⦘.
Proof using WF TLSCOH IORDCOH IMMCON.
split.
- unfold coverable, dom_cond in *.
  unfolder in *; desf; try type_solver.
  ins; desf; splits; eauto.
  eexists; splits; eauto.
  eapply tot_ex.
  * apply Wf_sc.
  * basic_solver.
  * generalize coveredE; basic_solver.
  * intro; apply NCOV. eapply dom_sc_covered; vauto.
  * intro; subst; eauto.
- rewrite <- !id_inter. apply eqv_rel_mori. apply set_subset_inter_r. split.
  { rewrite (wf_scD Wf_sc). basic_solver. }
  rewrite <- dom_sc_coverable; eauto. basic_solver.
Qed.

Lemma coverable_next_covered e
      (COV: coverable G sc T e)
      (NCOV : ~ covered T e):
  next G (covered T) e.
Proof using TLSCOH.
  red. split; auto. split; [apply COV| ].
  red. erewrite <- dom_sb_coverable; eauto.
  basic_solver.
Qed.

Lemma t_cur_sc_fence_step
      (RELCOV : W ∩₁ Rel ∩₁ issued T ⊆₁ covered T)
      f (FENCE : F f) (SC: Sc f)
      (COV : coverable G sc T f) (NCOV : ~ covered T f) :
  forall l,
    t_cur G sc (tid f) l (covered T ∪₁ eq f) ≡₁
    S_tm G l (covered T) ∪₁ t_acq G sc (tid f) l (covered T).
Proof using WF TLSCOH IORDCOH IMMCON.
  cdes IMMCON.
ins; split; try rewrite t_cur_union; unionL; desf.
by rewrite t_cur_in_t_acq; basic_solver.
all: unfold t_cur, c_cur, S_tm, S_tmr, t_acq, c_acq, t_rel, c_rel.
- arewrite (⦗Tid_ (tid f) ∪₁ Init⦘ ⨾ ⦗eq f⦘ ⊆ ⦗F ∩₁ Sc⦘ ⨾  ⦗eq f⦘ ⨾ ⦗Tid_ (tid f) ∪₁ Init⦘).
  basic_solver.
  sin_rewrite (urr_f_sc WF); auto.
  rewrite !seqA.
  arewrite (⦗W_ l⦘ ⨾ rf^? ⨾ (hb ⨾ ⦗F ∩₁ Sc⦘)^? ⨾ sc^? ⨾ ⦗eq f⦘ ⊆ ⦗W_ l⦘ ⨾ rf^? ⨾ hb ⨾ ⦗F ∩₁ Sc⦘ ⨾ sc^? ⨾ ⦗eq f⦘).
  { rewrite (dom_r (wf_rfD WF)) at 1.
    arewrite (⦗eq f⦘ ⊆ ⦗F ∩₁ Sc⦘ ⨾  ⦗eq f⦘) at 1 by basic_solver.
    rewrite (dom_l (wf_scD Wf_sc)) at 1.
    hahn_frame_r; unfolder; ins; desf; eauto 20; type_solver. }
  rewrite (crE sc); relsf.
  rewrite <- !dom_eqv1.
  unionL; splits.
  * arewrite (⦗W_ l⦘ ⨾ rf^? ⨾ hb ⨾ ⦗F ∩₁ Sc⦘ ⨾ ⦗eq f⦘ ⊆ S_tmr G l (eq f)).
    rewrite (s_tmr_helper l (eq f) WF).
    rewrite next_helper'; eauto using coverable_next_covered.
    rewrite <- !seqA, dom_rel_eqv_dom_rel, !seqA.
    unfold urr.
    unionR right; basic_solver 42.
  * unfold urr.
    rewrite (sc_helper' Wf_sc FENCE); auto.
    basic_solver 21.
- unfold urr.
  rewrite (sc_helper' Wf_sc FENCE); auto.
  rewrite <- !seqA, dom_rel_eqv_dom_rel, !seqA.
  rewrite (dom_l (wf_scD Wf_sc)) at 1.
  unionR right; basic_solver 21.
- rewrite crE at 1; relsf; unionL; splits; [basic_solver 12|].
  unionR right.
  rewrite next_helper'; eauto using coverable_next_covered.
  rewrite <- !seqA.
  rewrite !dom_rel_eqv_dom_rel.
  rewrite !seqA.
  arewrite (⦗eq f⦘ ⊆ ⦗ F∩₁ Acq ⦘ ⨾ ⦗eq f⦘) at 1 by mode_solver.
  arewrite (release ⨾ rf ⨾ sb ⨾ ⦗F ∩₁ Acq⦘ ⊆ sw).
  unfold imm_s_hb.sw; basic_solver 16.
  arewrite (sw ⊆ hb^?).
  sin_rewrite urr_hb.
  basic_solver 21.
Qed.

Lemma t_acq_sc_fence_step
      f (FENCE : F f) (SC: Sc f) (COV : coverable G sc T f) (NCOV : ~ covered T f):
  forall l,
    t_acq G sc (tid f) l (covered T ∪₁ eq f) ≡₁
    t_acq G sc (tid f) l (covered T) ∪₁
    S_tm G l (covered T).
Proof using WF TLSCOH IORDCOH IMMCON.
  cdes IMMCON.
ins; split; try rewrite t_acq_union; unionL; desf.
1,3: basic_solver.
all: unfold t_cur, c_cur, S_tm, S_tmr, t_acq, c_acq, t_rel, c_rel.
- arewrite (⦗Tid_ (tid f) ∪₁ Init⦘ ⨾ ⦗eq f⦘ ⊆ ⦗F ∩₁ Sc⦘ ⨾  ⦗eq f⦘ ⨾ ⦗Tid_ (tid f) ∪₁ Init⦘).
  basic_solver.
  arewrite ((release ⨾ rf)^? ⨾ ⦗F ∩₁ Sc⦘ ⊆ ⦗F ∩₁ Sc⦘).
  rewrite (dom_r (wf_rfD WF)) at 1; type_solver.
  sin_rewrite (urr_f_sc WF); auto.
  rewrite !seqA.
  arewrite (⦗W_ l⦘ ⨾ rf^? ⨾ (hb ⨾ ⦗F ∩₁ Sc⦘)^? ⨾ sc^? ⨾ ⦗eq f⦘ ⊆ ⦗W_ l⦘ ⨾ rf^? ⨾ hb ⨾ ⦗F ∩₁ Sc⦘ ⨾ sc^? ⨾ ⦗eq f⦘).
  { rewrite (dom_r (wf_rfD WF)) at 1.
    arewrite (⦗eq f⦘ ⊆ ⦗F ∩₁ Sc⦘ ⨾  ⦗eq f⦘) at 1 by basic_solver.
    rewrite (dom_l (wf_scD Wf_sc)) at 1.
    hahn_frame_r; unfolder; ins; desf; eauto 20; type_solver. }
  rewrite (crE sc); relsf; rewrite <- !dom_eqv1; unionL; splits.
  * arewrite (⦗W_ l⦘ ⨾ rf^? ⨾ hb ⨾ ⦗F ∩₁ Sc⦘ ⨾ ⦗eq f⦘ ⊆ S_tmr G l (eq f)).
    rewrite (s_tmr_helper l (eq f) WF).
    rewrite next_helper'; eauto using coverable_next_covered.
    rewrite <- !seqA, dom_rel_eqv_dom_rel, !seqA.
    unfold urr.
    unionR left; basic_solver 42.
  * unfold urr.
    rewrite (sc_helper' Wf_sc FENCE); auto.
    basic_solver 21.
- unfold urr.
  rewrite (sc_helper' Wf_sc FENCE); auto.
  rewrite <- !seqA, dom_rel_eqv_dom_rel, !seqA.
  rewrite (dom_l (wf_scD Wf_sc)) at 1.
  unionR right; basic_solver 42.
Qed.

Lemma t_rel_sc_fence_step
      f (FENCE : F f) (SC: Sc f) (COV : coverable G sc T f) (NCOV : ~ covered T f) :
  forall l l',
    t_rel G sc (tid f) l l' (covered T ∪₁ eq f) ∪₁
    (if LocSet.Facts.eq_dec l l'
     then W ∩₁ Loc_ l' ∩₁ Tid_ (tid f) ∩₁ (covered T ∪₁ eq f)
     else ∅) ≡₁
     S_tm G l (covered T) ∪₁ t_acq G sc (tid f) l (covered T).
Proof using WF TLSCOH IORDCOH IMMCON.
  cdes IMMCON.
ins; split; try rewrite t_rel_union; unionL; desf.
by rewrite t_rel_in_t_acq; basic_solver.
all: unfold t_cur, c_cur, S_tm, S_tmr, t_acq, c_acq, t_rel, c_rel.
2: by unfold urr; type_solver 42.
- arewrite (⦗Rel⦘ ⨾ ⦗W_ l' ∪₁ F⦘ ⨾ ⦗Tid_ (tid f) ∪₁ Init⦘ ⨾ ⦗eq f⦘ ⊆ ⦗F ∩₁ Sc⦘ ⨾  ⦗eq f⦘ ⨾ ⦗Tid_ (tid f) ∪₁ Init⦘).
  basic_solver.
  sin_rewrite (urr_f_sc WF); auto.
  rewrite !seqA.
  arewrite (⦗W_ l⦘ ⨾ rf^? ⨾ (hb ⨾ ⦗F ∩₁ Sc⦘)^? ⨾ sc^? ⨾ ⦗eq f⦘ ⊆ ⦗W_ l⦘ ⨾ rf^? ⨾ hb ⨾ ⦗F ∩₁ Sc⦘ ⨾ sc^? ⨾ ⦗eq f⦘).
  { rewrite (dom_r (wf_rfD WF)) at 1.
    arewrite (⦗eq f⦘ ⊆ ⦗F ∩₁ Sc⦘ ⨾  ⦗eq f⦘) at 1 by basic_solver.
    rewrite (dom_l (wf_scD Wf_sc)) at 1.
    hahn_frame_r; unfolder; ins; desf; eauto 20; type_solver. }
  rewrite (crE sc); relsf; rewrite <- !dom_eqv1; unionL; splits.
  * arewrite (⦗W_ l⦘ ⨾ rf^? ⨾ hb ⨾ ⦗F ∩₁ Sc⦘ ⨾ ⦗eq f⦘ ⊆ S_tmr G l (eq f)).
    rewrite (s_tmr_helper l (eq f) WF).
    rewrite next_helper'; eauto using coverable_next_covered.
    rewrite <- !seqA, dom_rel_eqv_dom_rel, !seqA.
    unfold urr.
    unionR right; basic_solver 42.
  * unfold urr.
    rewrite (sc_helper' Wf_sc FENCE); auto.
    basic_solver 21.
- unfold urr.
  rewrite (sc_helper' Wf_sc FENCE); auto.
  rewrite <- !seqA, dom_rel_eqv_dom_rel, !seqA.
  rewrite (dom_l (wf_scD Wf_sc)) at 1.
  assert (Rel f) by mode_solver.
  unionR left -> right; basic_solver 42.
- unfold urr.
  rewrite (sc_helper' Wf_sc FENCE); auto.
  rewrite <- !seqA, dom_rel_eqv_dom_rel, !seqA.
  rewrite (dom_l (wf_scD Wf_sc)) at 1.
  assert (Rel f) by mode_solver.
  unionR left -> right; basic_solver 42.
- rewrite next_helper'; eauto using coverable_next_covered.
  rewrite <- !seqA, dom_rel_eqv_dom_rel, !seqA.
  arewrite ((release ⨾ rf)^? ⨾ sb ⨾ ⦗eq f⦘ ⊆ hb^? ⨾ ⦗eq f⦘) at 1.
  { rewrite crE at 1; relsf; unionL.
    arewrite (sb ⊆ hb^?) at 1; basic_solver.
    arewrite (⦗eq f⦘ ⊆ ⦗ F∩₁ Acq ⦘ ⨾ ⦗eq f⦘) at 1 by mode_solver.
    arewrite (release ⨾ rf ⨾ sb ⨾ ⦗F ∩₁ Acq⦘ ⊆ sw).
    unfold imm_s_hb.sw; basic_solver 16.
    arewrite (sw ⊆ hb^?); basic_solver. }
  sin_rewrite urr_hb.
  arewrite (⦗eq f⦘ ⊆ ⦗ F∩₁ Rel ⦘ ⨾ ⦗eq f⦘) at 1 by mode_solver.
  basic_solver 21.
- rewrite next_helper'; eauto using coverable_next_covered.
  rewrite <- !seqA, dom_rel_eqv_dom_rel, !seqA.
  arewrite ((release ⨾ rf)^? ⨾ sb ⨾ ⦗eq f⦘ ⊆ hb^? ⨾ ⦗eq f⦘) at 1.
  { rewrite crE at 1; relsf; unionL.
    arewrite (sb ⊆ hb^?) at 1; basic_solver.
    arewrite (⦗eq f⦘ ⊆ ⦗ F∩₁ Acq ⦘ ⨾ ⦗eq f⦘) at 1 by mode_solver.
    arewrite (release ⨾ rf ⨾ sb ⨾ ⦗F ∩₁ Acq⦘ ⊆ sw).
    unfold imm_s_hb.sw; basic_solver 16.
    arewrite (sw ⊆ hb^?); basic_solver. }
  sin_rewrite urr_hb.
  arewrite (⦗eq f⦘ ⊆ ⦗ F∩₁ Rel ⦘ ⨾ ⦗eq f⦘) at 1 by mode_solver.
  basic_solver 21.
Qed.

Lemma t_cur_fence_step
      (RELCOV : W ∩₁ Rel ∩₁ issued T ⊆₁ covered T)
      f (FENCE : F f) (COV : coverable G sc T f) (NCOV : ~ covered T f):
  forall l,
    t_cur G sc (tid f) l (covered T ∪₁ eq f) ≡₁
    if is_sc lab f
    then S_tm G l (covered T) ∪₁ t_acq G sc (tid f) l (covered T)
    else
      if is_acq lab f
      then t_acq G sc (tid f) l (covered T)
      else t_cur G sc (tid f) l (covered T).
Proof using WF TLSCOH IORDCOH IMMCON.
  destruct (is_sc lab f) eqn: H.
  apply t_cur_sc_fence_step; auto.
  apply t_cur_n_sc_fence_step; auto.
  by apply IMMCON.
  by ins; desf.
  apply coverable_next_covered; auto.
Qed.

Lemma t_acq_fence_step
      f (FENCE : F f) (COV : coverable G sc T f) (NCOV : ~ covered T f):
  forall l,
    t_acq G sc (tid f) l (covered T ∪₁ eq f) ≡₁
    t_acq G sc (tid f) l (covered T) ∪₁
    if is_sc lab f
    then S_tm G l (covered T)
    else ∅.
Proof using WF TLSCOH IORDCOH IMMCON.
  destruct (is_sc lab f) eqn: H.
  apply t_acq_sc_fence_step; auto.
  ins; rewrite set_union_empty_r; apply t_acq_n_sc_fence_step; auto.
  by apply IMMCON.
  by ins; desf.
  apply coverable_next_covered; auto.
Qed.

Lemma t_rel_fence_step
      f (FENCE : F f) (COV : coverable G sc T f) (NCOV : ~ covered T f) :
  forall l l',
    t_rel G sc (tid f) l l' (covered T ∪₁ eq f) ∪₁
    (if LocSet.Facts.eq_dec l l'
     then W ∩₁ Loc_ l' ∩₁ Tid_ (tid f) ∩₁ (covered T ∪₁ eq f)
     else ∅) ≡₁
    if is_sc lab f
    then S_tm G l (covered T) ∪₁ t_acq G sc (tid f) l (covered T)
    else
      if is_acqrel lab f
      then t_acq G sc (tid f) l (covered T)
      else
        if is_rel lab f
        then t_cur G sc (tid f) l (covered T)
        else
          (t_rel G sc (tid f) l l' (covered T) ∪₁
           (if LocSet.Facts.eq_dec l l'
            then W ∩₁ Loc_ l' ∩₁ Tid_ (tid f) ∩₁ (covered T)
            else ∅)).
Proof using WF TLSCOH IORDCOH IMMCON.
  destruct (is_sc lab f) eqn: H.
  apply t_rel_sc_fence_step; auto.
  apply t_rel_n_sc_fence_step; auto.
  by apply IMMCON.
  by ins; desf.
  apply coverable_next_covered; auto.
Qed.

End ViewRelHelpers.


Require Import VST.floyd.proofauto.
Require Import VST.msl.iter_sepcon.
Require Import malloc.
Require Import ASI_malloc.
Require Import malloc_lemmas.
Require Import malloc_sep.
Require Import VSU_malloc_definitions.
Local Open Scope logic.
(*
Definition Gprog : funspecs := user_specs_R ++ private_specs.
*)
Lemma body_pre_fill i: semax_body MF_Vprog MF_Gprog f_pre_fill (pre_fill_spec' R_APD i).
Proof.
start_function.
rewrite <- seq_assoc.
forward_call n. (*! b = size2bin(n) *)
destruct H as [[Hn_lo Hn_hi] Hp].
try rep_lia.
forward.
set (b:=size2binZ n).
assert (Hb: 0 <= b < BINS) by (apply size2bin_range; rep_lia).
forward_call b. (*! t2 = bin2size(b) *)
simpl. rewrite (mem_mgr_split_R gv b rvec) by apply Hb.
Intros bins idxs lens.
freeze [1; 3] Otherlists.
deadvars!.
try destruct H as [[Hn_lo Hn_hi] Hp].
forward. (*! t4 = bin[b] *)
forward_call ((bin2sizeZ b), p, (Znth b bins), (Znth b lens), b). (*! t3 = list_from_block(t2,p,t4) *)
Intros q.
forward. (*! bin[b] = t3 *)
thaw Otherlists.

(* fold lists into mem_mgr_R *)
replace (size2binZ (bin2sizeZ b)) with b
  by (subst b; rewrite claim3; try rep_lia).
simpl ASI_malloc.mem_mgr_R; unfold mem_mgr_R.
set (bins':= upd_Znth b bins q).
set (lens':= map Z.to_nat (add_resvec rvec b (chunks_from_block b))).
assert (Hrveclen: Zlength rvec = BINS) by
   ( subst lens; rewrite Zlength_map in H0; rep_lia).
Exists bins'. Exists idxs. Exists lens'.
entailer!.
{ split. unfold lens'. rewrite Zlength_map. rewrite Zlength_add_resvec; assumption.
  apply add_resvec_no_neg; try assumption.
  pose proof (chunks_from_block_nonneg (size2binZ n)).
  assert (0 <= Znth (size2binZ n) rvec)
    by (apply Forall_Znth; try rep_lia; try unfold no_neg in *; auto).
  rep_lia.
}
set (idxs:= (map Z.of_nat (seq 0 (Z.to_nat BINS)))).
set (lens:= (map Z.to_nat rvec)).
assert (Zlength lens = BINS) by (unfold lens; rewrite Zlength_map; rep_lia).
assert (Zlength idxs = BINS) by auto.
repeat (rewrite sublist_zip3; try rep_lia).
replace (sublist 0 b bins) with (sublist 0 b bins')
  by (unfold bins'; rewrite sublist_upd_Znth_l; try reflexivity; try rep_lia).
replace (sublist (b+1) BINS bins) with (sublist (b+1) BINS bins')
  by (unfold bins'; rewrite sublist_upd_Znth_r; try reflexivity; try rep_lia).
replace (sublist 0 b lens) with (sublist 0 b lens').
2: { unfold lens'. unfold lens.  do 2 rewrite sublist_map. f_equal.
     unfold add_resvec. simple_if_tac''; auto.
     rewrite sublist_upd_Znth_l; try rep_lia; reflexivity. }
replace (sublist (b + 1) BINS lens) with (sublist (b + 1) BINS lens').
2: { unfold lens'. unfold lens.  do 2 rewrite sublist_map. f_equal.
     unfold add_resvec. simple_if_tac''; auto.
     rewrite sublist_upd_Znth_r; try rep_lia; reflexivity. }
assert (Zlength bins' = BINS) by auto.
assert (Zlength lens' = BINS)
  by (unfold lens'; rewrite Zlength_map; rewrite Zlength_add_resvec; auto).
repeat (rewrite <- sublist_zip3; try rep_lia); try rep_lia.
replace (Z.to_nat (chunks_from_block b) + Znth b lens)%nat with (Znth b lens').
2: {unfold lens'.  rewrite Znth_map.
    unfold add_resvec. simple_if_tac' Hcond.
    2: { assert (Zlength rvec = BINS) by auto.
         bdestruct(Zlength rvec =? BINS); simpl in Hcond; try contradiction.
         bdestruct(0 <=? b); simpl in Hcond; try contradiction.
         bdestruct(b<?BINS); simpl in Hcond; try contradiction.
         discriminate.
         rep_lia.
         destruct Hb; contradiction.
    }
    rewrite upd_Znth_same; try rep_lia.
    replace (Znth b lens) with (Z.to_nat (Znth b rvec))
      by (unfold lens; rewrite Znth_map; rep_lia).
    rewrite <- Z2Nat.inj_add. f_equal. rep_lia.
    apply chunks_from_block_nonneg.
    apply Forall_Znth; try rep_lia; try unfold no_neg in *; auto.
    rewrite Zlength_add_resvec; rep_lia.
}
replace
 (mmlist (bin2sizeZ b) (Znth b lens') q nullval * TT *
  iter_sepcon mmlist' (sublist 0 b (zip3 lens' bins' idxs)) *
  iter_sepcon mmlist' (sublist (b + 1) BINS (zip3 lens' bins' idxs)) * TT)
with
 (iter_sepcon mmlist' (sublist 0 b (zip3 lens' bins' idxs)) *
  iter_sepcon mmlist' (sublist (b + 1) BINS (zip3 lens' bins' idxs)) *
  mmlist (bin2sizeZ b) (Znth b lens') q nullval * TT)
by (apply pred_ext; entailer!).
replace q with (Znth b bins').
2: (unfold bins'; rewrite upd_Znth_same; auto; rep_lia).
rewrite mem_mgr_split'; try entailer!; auto.
Qed.
(*
Definition module := [mk_body body_pre_fill].
*)