(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Register allocation. *)

Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import Lattice.
Require Import AST.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import RTLtyping.
Require Import Kildall.
Require Import Locations.
Require Import Coloring.

(** * Liveness analysis over RTL *)

(** A register [r] is live at a point [p] if there exists a path
  from [p] to some instruction that uses [r] as argument,
  and [r] is not redefined along this path.
  Liveness can be computed by a backward dataflow analysis.
  The analysis operates over sets of (live) pseudo-registers. *)

Notation reg_live := Regset.add.
Notation reg_dead := Regset.remove.

Definition reg_option_live (or: option reg) (lv: Regset.t) :=
  match or with None => lv | Some r => reg_live r lv end.

Definition reg_sum_live (ros: reg + ident) (lv: Regset.t) :=
  match ros with inl r => reg_live r lv | inr s => lv end.

Fixpoint reg_list_live
             (rl: list reg) (lv: Regset.t) {struct rl} : Regset.t :=
  match rl with
  | nil => lv
  | r1 :: rs => reg_list_live rs (reg_live r1 lv)
  end.

Fixpoint reg_list_dead
             (rl: list reg) (lv: Regset.t) {struct rl} : Regset.t :=
  match rl with
  | nil => lv
  | r1 :: rs => reg_list_dead rs (reg_dead r1 lv)
  end.

(** Here is the transfer function for the dataflow analysis.
  Since this is a backward dataflow analysis, it takes as argument
  the abstract register set ``after'' the given instruction,
  i.e. the registers that are live after; and it returns as result
  the abstract register set ``before'' the given instruction,
  i.e. the registers that must be live before.
  The general relation between ``live before'' and ``live after''
  an instruction is that a register is live before if either
  it is one of the arguments of the instruction, or it is not the result
  of the instruction and it is live after.
  However, if the result of a side-effect-free instruction is not
  live ``after'', the whole instruction will be removed later
  (since it computes a useless result), thus its arguments need not
  be live ``before''. *)

Definition transfer
            (f: RTL.function) (pc: node) (after: Regset.t) : Regset.t :=
  match f.(fn_code)!pc with
  | None =>
      Regset.empty
  | Some i =>
      match i with
      | Inop s =>
          after
      | Iop op args res s =>
          if Regset.mem res after then
            reg_list_live args (reg_dead res after)
          else
            after
      | Iload chunk addr args dst s =>
          if Regset.mem dst after then
            reg_list_live args (reg_dead dst after)
          else
            after
      | Istore chunk addr args src s =>
          reg_list_live args (reg_live src after)
      | Icall sig ros args res s =>
          reg_list_live args
           (reg_sum_live ros (reg_dead res after))
      | Itailcall sig ros args =>
          reg_list_live args (reg_sum_live ros Regset.empty)
      | Ibuiltin ef args res s =>
          reg_list_live args (reg_dead res after)
      | Icond cond args ifso ifnot =>
          reg_list_live args after
      | Ijumptable arg tbl =>
          reg_live arg after
      | Ireturn optarg =>
          reg_option_live optarg Regset.empty
      end
  end.

(** The liveness analysis is then obtained by instantiating the
  general framework for backward dataflow analysis provided by
  module [Kildall].  *)

Module RegsetLat := LFSet(Regset).
Module DS := Backward_Dataflow_Solver(RegsetLat)(NodeSetBackward).

Definition analyze (f: RTL.function): option (PMap.t Regset.t) :=
  DS.fixpoint (successors f)  (transfer f) nil.

(** * Translation from RTL to LTL *)

Require Import LTL.

(** Each [RTL] instruction translates to an [LTL] instruction.
  The register assignment [assign] returned by register allocation
  is applied to the arguments and results of the RTL
  instruction.  Moreover, dead instructions and redundant moves
  are eliminated (turned into a [Lnop] instruction).
  Dead instructions are instructions without side-effects ([Iop] and
  [Iload]) whose result register is dead, i.e. whose result value
  is never used.  Redundant moves are moves whose source and destination
  are assigned the same location. *)

Definition is_redundant_move
    (op: operation) (args: list reg) (res: reg) (assign: reg -> loc) : bool :=
  match is_move_operation op args with
  | None => false
  | Some src => if Loc.eq (assign src) (assign res) then true else false
  end.

Definition transf_instr
         (f: RTL.function) (live: PMap.t Regset.t) (assign: reg -> loc)
         (pc: node) (instr: RTL.instruction) : LTL.instruction :=
  match instr with
  | Inop s =>
      Lnop s
  | Iop op args res s =>
      if Regset.mem res live!!pc then
        if is_redundant_move op args res assign then
          Lnop s
        else
          Lop op (List.map assign args) (assign res) s
      else
        Lnop s
  | Iload chunk addr args dst s =>
      if Regset.mem dst live!!pc then
        Lload chunk addr (List.map assign args) (assign dst) s
      else
        Lnop s
  | Istore chunk addr args src s =>
      Lstore chunk addr (List.map assign args) (assign src) s
  | Icall sig ros args res s =>
      Lcall sig (sum_left_map assign ros) (List.map assign args)
                (assign res) s
  | Itailcall sig ros args =>
      Ltailcall sig (sum_left_map assign ros) (List.map assign args)
  | Ibuiltin ef args res s =>
      Lbuiltin ef (List.map assign args) (assign res) s
  | Icond cond args ifso ifnot =>
      Lcond cond (List.map assign args) ifso ifnot
  | Ijumptable arg tbl =>
      Ljumptable (assign arg) tbl
  | Ireturn optarg =>
      Lreturn (option_map assign optarg)
  end.

Definition transf_fun (f: RTL.function) (live: PMap.t Regset.t)
                      (assign: reg -> loc) : LTL.function :=
  LTL.mkfunction
     (RTL.fn_sig f)
     (List.map assign (RTL.fn_params f))
     (RTL.fn_stacksize f)
     (PTree.map (transf_instr f live assign) (RTL.fn_code f))
     (RTL.fn_entrypoint f).

(** The translation of a function performs liveness analysis,
  construction and coloring of the inference graph, and per-instruction
  transformation as described above. *)

Definition live0 (f: RTL.function) (live: PMap.t Regset.t) :=
  transfer f f.(RTL.fn_entrypoint) live!!(f.(RTL.fn_entrypoint)).

Open Scope string_scope.

Definition transf_function (f: RTL.function) : res LTL.function :=
  match type_function f with
  | Error msg => Error msg
  | OK env =>
    match analyze f with
    | None => Error (msg "Liveness analysis failure")
    | Some live =>
        match regalloc f live (live0 f live) env with
        | None => Error (msg "Incorrect graph coloring")
        | Some assign => OK (transf_fun f live assign)
        end
    end
  end.

Section WITHEF.
Context `{Hsc: SyntaxConfiguration}.

Definition transf_fundef (fd: RTL.fundef) : res LTL.fundef :=
  AST.transf_partial_fundef transf_function fd.

Definition transf_program (p: RTL.program) : res LTL.program :=
  transform_partial_program transf_fundef p.

End WITHEF.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.VSU.

Require Import spec_stdlib.

Require Import verif_stdlib.
Require Import verif_fastpile.
Require Import verif_fastonepile.
Require Import verif_fastapile.
Require Import verif_fasttriang.

Definition PrivPILE: spec_fastpile_private.FastpilePrivateAPD := PILEPRIV M.
Definition PILE: spec_fastpile.PileAPD := spec_fastpile_private.pilepreds PrivPILE.

Definition ONEPILE : spec_onepile.OnePileAPD := ONEPILE PILE.

Definition Onepile_Pile_VSU :=
  ltac:(linkVSUs (PilePrivateVSU M) (OnepileVSU M PILE) ).

Definition Apile_Onepile_Pile_VSU :=
  ltac:(linkVSUs (Onepile_Pile_VSU) (ApileVSU M PrivPILE)).

Definition Triang_Apile_Onepile_Pile_VSU :=
  ltac:(linkVSUs Apile_Onepile_Pile_VSU (TriangVSU M PILE)).

Definition Core_VSU :=
  ltac:(linkVSUs MallocFreeVSU Triang_Apile_Onepile_Pile_VSU).


Require Import Classical Peano_dec Setoid PeanoNat.
From hahn Require Import Hahn.

Require Import AuxDef Events Execution.
Require Import Execution_eco imm_s_hb imm_s imm_bob.
Require Import imm_s_ppo CombRelations.
Require Import imm_s_rfppo.
Require Import FinExecution.

Set Implicit Arguments.

Section TraversalConfig.

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

  Notation "'sb'" := (sb G).
  Notation "'rmw'" := (rmw G).
  Notation "'data'" := (data G).
  Notation "'addr'" := (addr G).
  Notation "'ctrl'" := (ctrl G).
  Notation "'rf'" := (rf G).
  Notation "'co'" := (co G).
  Notation "'coe'" := (coe G).
  Notation "'fr'" := (fr G).

  Notation "'eco'" := (eco G).

  Notation "'bob'" := (bob G).
  Notation "'fwbob'" := (fwbob G).
  Notation "'ppo'" := (ppo G).
  Notation "'fre'" := (fre G).
  Notation "'rfi'" := (rfi G).
  Notation "'rfe'" := (rfe G).
  Notation "'deps'" := (deps G).
  Notation "'detour'" := (detour G).
  Notation "'release'" := (release G).
  Notation "'sw'" := (sw G).
  Notation "'hb'" := (hb G).

  Notation "'ar'" := (ar G sc).

  Notation "'urr'" := (urr G sc).
  Notation "'c_acq'" := (c_acq G sc).
  Notation "'c_cur'" := (c_cur G sc).
  Notation "'c_rel'" := (c_rel G sc).
  Notation "'t_acq'" := (t_acq G sc).
  Notation "'t_cur'" := (t_cur G sc).
  Notation "'t_rel'" := (t_rel G sc).
  Notation "'S_tm'" := (S_tm G).
  Notation "'S_tmr'" := (S_tmr G).
  Notation "'msg_rel'" := (msg_rel G sc).

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

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

Notation "'Init'" := (fun a => is_true (is_init a)).
Notation "'Loc_' l" := (fun x => loc 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 x => is_true (is_only_pln lab x)).
Notation "'Rlx'" := (fun x => is_true (is_rlx lab x)).
Notation "'Rel'" := (fun x => is_true (is_rel lab x)).
Notation "'Acq'" := (fun x => is_true (is_acq lab x)).
Notation "'Acqrel'" := (fun x => is_true (is_acqrel lab x)).
Notation "'Sc'" := (fun x => is_true (is_sc lab x)).
Notation "'Acq/Rel'" := (fun a => is_true (is_ra lab a)).

(******************************************************************************)
(** **   *)
(******************************************************************************)

  Definition next C := E ∩₁ dom_cond sb C ∩₁ set_compl C.

  Record trav_config :=
    mkTC { covered : actid -> Prop; issued : actid -> Prop; }.

  Definition same_trav_config (T T' : trav_config) :=
    covered T ≡₁ covered T' /\ issued T ≡₁ issued T'.

  Definition coverable T := E ∩₁ dom_cond sb (covered T) ∩₁
                              ((W ∩₁ issued T) ∪₁
                               (R ∩₁ (dom_cond rf (issued T))) ∪₁
                               (F ∩₁ (dom_cond sc (covered T)))).

  Definition issuable T := E ∩₁ W ∩₁
                           (dom_cond fwbob (covered T)) ∩₁
                           (dom_cond (⦗W⦘ ⨾ (ar ∪ rf ⨾ (ppo ∩ same_loc))⁺) (issued T)).

  Definition tc_coherent (T : trav_config) :=
    ⟪ ICOV  : Init ∩₁ E ⊆₁ covered T ⟫ /\
    ⟪ CC    : covered T ⊆₁ coverable T ⟫ /\
    ⟪ II    : issued  T ⊆₁ issuable T ⟫.

  Lemma traversal_mon T T'
        (ICOV : covered T ⊆₁ covered T')
        (IISS : issued  T ⊆₁ issued  T'):
    coverable T ⊆₁ coverable T' /\
    issuable  T ⊆₁ issuable T'.
  Proof using.
    split.
      by unfold coverable; rewrite ICOV, IISS.
        by unfold issuable; rewrite ICOV, IISS.
  Qed.

  Lemma same_trav_config_refl : reflexive same_trav_config.
  Proof using. split; basic_solver. Qed.

  Lemma same_trav_config_sym : symmetric same_trav_config.
  Proof using. unfold same_trav_config; split; ins; desf; symmetry; auto. Qed.

  Lemma same_trav_config_trans : transitive same_trav_config.
  Proof using. unfold same_trav_config; split; ins; desf; etransitivity; eauto. Qed.

(******************************************************************************)
(** **   *)
(******************************************************************************)

  Global Add Parametric Relation : trav_config same_trav_config
      reflexivity proved by same_trav_config_refl
      symmetry proved by same_trav_config_sym
      transitivity proved by same_trav_config_trans
        as same_tc.

  Lemma same_tc_extensionality tc1 tc2 (SAME: same_trav_config tc1 tc2):
    tc1 = tc2.
  Proof using.
    destruct SAME.
    destruct tc1, tc2. ins.
    apply set_extensionality in H, H0.
    congruence.
  Qed.

  Global Add Parametric Morphism : covered with signature
      same_trav_config ==> set_equiv as covered_more.
  Proof using. by unfold same_trav_config; ins; split; ins; desf; apply H. Qed.

  Global Add Parametric Morphism : issued with signature
      same_trav_config ==> set_equiv as issued_more.
  Proof using. by unfold same_trav_config; ins; desf; apply H1. Qed.

  Global Add Parametric Morphism : coverable with signature
      same_trav_config ==> set_equiv as coverable_more.
  Proof using.
    unfold coverable, same_trav_config; split; ins; desf.
    all: unnw; try first [ rewrite <- H, <- H0 | rewrite H, H0].
    all: unfold set_equiv in *; unnw; intuition; basic_solver 12.
  Qed.

  Global Add Parametric Morphism : issuable with signature
      same_trav_config ==> set_equiv as issuable_more.
  Proof using.
    unfold issuable, same_trav_config; split; ins; desf.
    all: unnw; try first [ rewrite <- H, <- H0 | rewrite H, H0].
    all: unfold set_equiv in *; unnw; intuition; basic_solver 12.
  Qed.

  Global Add Parametric Morphism : tc_coherent with signature
      same_trav_config ==> iff as tc_coherent_more.
  Proof using.
    intros T T' EQ.
    split; [apply same_tc_Symmetric in EQ|];
      intros HH; cdes HH; red; splits.
    all: try erewrite covered_more; eauto.
    all: try erewrite coverable_more; eauto.
    all: try erewrite issued_more; eauto.
    all: erewrite issuable_more; eauto.
  Qed.

  Global Add Parametric Morphism : mkTC with signature
         (@set_equiv actid) ==> (@set_equiv actid) ==> same_trav_config as mkTC_more.
  Proof using. vauto. Qed.

(******************************************************************************)
(** **   *)
(******************************************************************************)

Section Properties.
  Variable T : trav_config.
  Variable TCCOH : tc_coherent T.

  Lemma issued_in_issuable : issued T ⊆₁ issuable T.
  Proof using TCCOH. apply TCCOH. Qed.

  Lemma issuableE :
    issuable T ⊆₁ E.
  Proof using. unfold issuable; basic_solver. Qed.

  Lemma issuedE :
    issued T ⊆₁ E.
  Proof using TCCOH. rewrite issued_in_issuable. by apply issuableE. Qed.

  Lemma issuableW :
    issuable T ⊆₁ W.
  Proof using. unfold issuable; basic_solver. Qed.

  Lemma issuedW :
    issued T ⊆₁ W.
  Proof using TCCOH.
    rewrite issued_in_issuable.
    by apply issuableW.
  Qed.

  Lemma covered_in_coverable :
    covered T ⊆₁ coverable T.
  Proof using TCCOH.
    apply TCCOH.
  Qed.

  Lemma coverableE :
    coverable T ⊆₁ E.
  Proof using.
    unfold coverable; basic_solver.
  Qed.

  Lemma coveredE :
    covered T ⊆₁ E.
  Proof using TCCOH.
    rewrite covered_in_coverable.
    by apply coverableE.
  Qed.

  Lemma w_coverable_issued :
    W ∩₁ coverable T ⊆₁ issued T.
  Proof using.
    unfold coverable; type_solver.
  Qed.

  Lemma w_covered_issued :
    W ∩₁ covered T ⊆₁ issued T.
  Proof using TCCOH.
    rewrite covered_in_coverable.
    by apply w_coverable_issued.
  Qed.

  Lemma init_issued : is_init ∩₁ E ⊆₁ issued T.
  Proof using WF TCCOH.
    unfolder; ins; desf.
    apply w_covered_issued.
    split.
    { by apply (init_w WF). }
    cdes TCCOH; unfolder in ICOV; basic_solver 21.
  Qed.

  Lemma init_covered : is_init ∩₁ E ⊆₁ covered T.
  Proof using TCCOH.
    unfolder; ins; desf.
    cdes TCCOH; unfolder in ICOV; basic_solver 21.
  Qed.

  Lemma next_n_init e
        (NEXT : next (covered T) e) :
    ~ Init e.
  Proof using TCCOH.
    intros HH. apply NEXT.
    apply init_covered. split; auto.
    apply NEXT.
  Qed.

(******************************************************************************)
(** **   *)
(******************************************************************************)

  Lemma ar_ct_issuable_is_issued  :
    dom_rel (⦗W⦘ ⨾ ar⁺ ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using.
    arewrite (ar ⊆ ar ∪ rf ⨾ ppo ∩ same_loc).
    unfold issuable. basic_solver 20.
  Qed.

  Lemma ar_issuable_is_issued  :
    dom_rel (⦗W⦘ ⨾ ar ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using.
    rewrite ct_step with (r:=ar).
    apply ar_ct_issuable_is_issued.
  Qed.

  Lemma dom_sb_coverable :
    dom_rel (sb ⨾ ⦗ coverable T ⦘) ⊆₁ covered T.
  Proof using.
    unfold coverable, dom_cond; basic_solver 21.
  Qed.

  Lemma sb_coverable :
    sb ⨾ ⦗ coverable T ⦘ ⊆ ⦗ covered T ⦘ ⨾ sb.
  Proof using.
   rewrite (dom_rel_helper dom_sb_coverable).
   basic_solver.
  Qed.

  Lemma dom_sb_covered :
    dom_rel (sb ⨾ ⦗ covered T ⦘) ⊆₁ covered T.
  Proof using TCCOH.
  rewrite covered_in_coverable at 1.
  seq_rewrite (dom_rel_helper dom_sb_coverable).
  basic_solver.
  Qed.

  Lemma sb_covered :
    sb ⨾ ⦗ covered T ⦘ ≡ ⦗ covered T ⦘ ⨾ sb ⨾ ⦗ covered T ⦘.
  Proof using TCCOH.
  rewrite (dom_rel_helper dom_sb_covered).
  basic_solver.
  Qed.

  Lemma dom_rf_coverable :
    dom_rel (rf ⨾ ⦗ coverable T ⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    unfold coverable, dom_cond.
    rewrite (dom_r (wf_rfD WF)).
    type_solver 40.
  Qed.

  Lemma dom_rf_covered :
    dom_rel (rf ⨾ ⦗ covered  T ⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite covered_in_coverable.
    apply dom_rf_coverable.
  Qed.

  Lemma rf_coverable :
    rf ⨾ ⦗ coverable T ⦘ ⊆ ⦗ issued T ⦘ ⨾ rf.
  Proof using WF TCCOH.
    rewrite (dom_rel_helper dom_rf_coverable).
    basic_solver.
  Qed.

  Lemma rf_covered :
    rf ⨾ ⦗ covered T ⦘ ≡ ⦗ issued T ⦘ ⨾ rf ⨾ ⦗ covered T ⦘.
  Proof using WF TCCOH.
    rewrite (dom_rel_helper dom_rf_covered).
    basic_solver.
  Qed.

  Lemma dom_sc_coverable :
    dom_rel (sc ⨾ ⦗ coverable T ⦘) ⊆₁ covered T.
  Proof using IMMCON.
    cdes IMMCON.
    rewrite (dom_r (@wf_scD G sc Wf_sc)).
    unfold coverable, dom_cond; type_solver 42.
  Qed.

  Lemma dom_sc_covered :
    dom_rel (sc ⨾ ⦗ covered T ⦘) ⊆₁ covered T.
  Proof using IMMCON TCCOH.
    rewrite covered_in_coverable at 1.
    seq_rewrite (dom_rel_helper dom_sc_coverable).
    basic_solver.
  Qed.

  Lemma sc_coverable  :
    sc ⨾ ⦗ coverable T ⦘ ⊆ ⦗covered T⦘ ⨾ sc.
  Proof using IMMCON.
    seq_rewrite (dom_rel_helper dom_sc_coverable).
    basic_solver.
  Qed.

  Lemma sc_covered  :
    sc ⨾ ⦗ covered T ⦘ ⊆ ⦗covered T⦘ ⨾ sc.
  Proof using IMMCON TCCOH.
    rewrite covered_in_coverable at 1.
      by apply sc_coverable.
  Qed.

  Lemma ar_coverable_in_CI  :
    dom_rel (ar ⨾ ⦗coverable T⦘) ⊆₁ covered T ∪₁ issued T.
  Proof using WF IMMCON TCCOH.
    unfold imm_s.ar.
    rewrite !seq_union_l.
    rewrite (ar_int_in_sb WF).
    arewrite (rfe ⊆ rf).
    rewrite sb_coverable, rf_coverable.
    rewrite sc_coverable.
    basic_solver.
  Qed.

  Lemma ar_C_in_CI  :
    dom_rel (ar ⨾ ⦗covered T⦘) ⊆₁ covered T ∪₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite covered_in_coverable at 1.
    apply ar_coverable_in_CI.
  Qed.

  Lemma ar_rf_ppo_loc_ct_issuable_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ (ppo ∩ same_loc))⁺ ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using.
    unfold issuable.
    basic_solver 10.
  Qed.

  Lemma ar_rfrmw_ct_issuable_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ rmw)⁺ ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using WF.
    rewrite (rmw_in_ppo_loc WF). apply ar_rf_ppo_loc_ct_issuable_in_I.
  Qed.

  Lemma ar_rf_ppo_loc_ct_I_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ (ppo ∩ same_loc))⁺ ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using TCCOH.
    rewrite issued_in_issuable at 1.
    apply ar_rf_ppo_loc_ct_issuable_in_I.
  Qed.

  Lemma ar_rfrmw_ct_I_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ rmw)⁺ ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite (rmw_in_ppo_loc WF). by apply ar_rf_ppo_loc_ct_I_in_I.
  Qed.

  Lemma ar_rf_ppo_loc_rt_I_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ (ppo ∩ same_loc))＊ ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using TCCOH.
    rewrite rtE. rewrite !seq_union_l, !seq_union_r, dom_union; unionL.
    { basic_solver. }
    apply ar_rf_ppo_loc_ct_I_in_I.
  Qed.

  Lemma ar_rfrmw_rt_I_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ rmw)＊ ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite (rmw_in_ppo_loc WF). by apply ar_rf_ppo_loc_rt_I_in_I.
  Qed.

  Lemma ar_rf_ppo_loc_issuable_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ (ppo ∩ same_loc)) ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using.
    rewrite ct_step with (r := ar ∪ rf ⨾ (ppo ∩ same_loc)).
      by apply ar_rf_ppo_loc_ct_issuable_in_I.
  Qed.

  Lemma ar_rfrmw_issuable_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ rmw) ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using WF.
    rewrite (rmw_in_ppo_loc WF). by apply ar_rf_ppo_loc_issuable_in_I.
  Qed.

  Lemma ar_rf_ppo_loc_I_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ (ppo ∩ same_loc)) ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using TCCOH.
    rewrite ct_step with (r := ar ∪ rf ⨾ (ppo ∩ same_loc)).
      by apply ar_rf_ppo_loc_ct_I_in_I.
  Qed.

  Lemma ar_rfrmw_I_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ rmw) ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite (rmw_in_ppo_loc WF). by apply ar_rf_ppo_loc_I_in_I.
  Qed.

  Lemma ar_ct_issuable_in_I  :
    dom_rel (⦗W⦘ ⨾ ar⁺ ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using WF.
    arewrite (ar ⊆ ar ∪ rf ⨾ rmw). by apply ar_rfrmw_ct_issuable_in_I.
  Qed.

  Lemma ar_ct_I_in_I  :
    dom_rel (⦗W⦘ ⨾ ar⁺ ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    arewrite (ar ⊆ ar ∪ rf ⨾ rmw). by apply ar_rfrmw_ct_I_in_I.
  Qed.

  Lemma ar_issuable_in_I  :
    dom_rel (⦗W⦘ ⨾ ar ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using WF.
    rewrite ct_step with (r:=ar). by apply ar_ct_issuable_in_I.
  Qed.

  Lemma ar_I_in_I  :
    dom_rel (⦗W⦘ ⨾ ar ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite ct_step with (r:=ar). by apply ar_ct_I_in_I.
  Qed.

  Lemma W_ar_coverable_in_I  :
    dom_rel (⦗W⦘ ⨾ ar ⨾ ⦗coverable T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite dom_eqv1. rewrite ar_coverable_in_CI.
    rewrite set_inter_union_r; unionL.
    2: basic_solver.
    apply w_covered_issued.
  Qed.

  Lemma W_ar_C_in_I  :
    dom_rel (⦗W⦘ ⨾ ar ⨾ ⦗covered T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite covered_in_coverable.
    apply W_ar_coverable_in_I.
  Qed.

  Lemma W_ar_coverable_issuable_in_CI  :
    dom_rel (⦗W⦘ ⨾ ar ⨾ ⦗coverable T ∪₁ issuable T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite id_union, !seq_union_r, dom_union; unionL.
    { by apply W_ar_coverable_in_I. }
    apply ar_issuable_in_I.
  Qed.

  Lemma ar_CI_in_CI  :
    dom_rel (⦗W⦘ ⨾ ar ⨾ ⦗covered T ∪₁ issued T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite id_union, !seq_union_r, dom_union; unionL.
    { by apply W_ar_C_in_I. }
    apply ar_I_in_I.
  Qed.

  Lemma ar_rt_I_in_I  :
    dom_rel (⦗W⦘ ⨾ ar＊ ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite rtE, !seq_union_l, !seq_union_r, seq_id_l, dom_union.
    unionL; [basic_solver|]. by apply ar_ct_I_in_I.
  Qed.

  Lemma dom_W_sb_coverable_in_I  :
    dom_rel (⦗W⦘ ⨾ sb ⨾ ⦗coverable T⦘) ⊆₁ issued T.
  Proof using TCCOH.
    rewrite sb_coverable; auto.
    etransitivity.
    2: by apply w_covered_issued.
    basic_solver.
  Qed.

  Lemma dom_W_sb_C_in_I  :
    dom_rel (⦗W⦘ ⨾ sb ⨾ ⦗covered T⦘) ⊆₁ issued T.
  Proof using TCCOH.
    rewrite covered_in_coverable.
    apply dom_W_sb_coverable_in_I.
  Qed.

  Lemma rf_ppo_loc_coverable_in_I  :
    dom_rel (rf ⨾ (ppo ∩ same_loc) ⨾ ⦗coverable T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    arewrite (ppo ∩ same_loc ⊆ ppo).
    rewrite (dom_l (wf_rfD WF)), seqA.
    rewrite rfi_union_rfe, !seq_union_l, !seq_union_r, dom_union.
    unionL.
    2: { rewrite (dom_r (@wf_ppoD G)), !seqA.
         rewrite <- id_inter.
         rewrite w_coverable_issued.
         sin_rewrite rfe_ppo_in_ar_ct; auto.
           by apply ar_ct_I_in_I. }
    arewrite (rfi ⊆ sb).
    rewrite (ppo_in_sb WF). sin_rewrite sb_sb.
    rewrite dom_W_sb_coverable_in_I; auto.
  Qed.

  Lemma rfrmw_coverable_in_I  :
    dom_rel (rf ⨾ rmw ⨾ ⦗coverable T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite (rmw_in_ppo_loc WF). by apply rf_ppo_loc_coverable_in_I.
  Qed.

  Lemma rf_ppo_loc_C_in_I  :
    dom_rel (rf ⨾ (ppo ∩ same_loc) ⨾ ⦗covered T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite covered_in_coverable.
    apply rf_ppo_loc_coverable_in_I.
  Qed.

  Lemma rfrmw_C_in_I  :
    dom_rel (rf ⨾ rmw ⨾ ⦗covered T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite covered_in_coverable.
    apply rfrmw_coverable_in_I.
  Qed.

  Lemma rf_ppo_loc_coverable_issuable_in_I  :
    dom_rel (rf ⨾ (ppo ∩ same_loc) ⨾ ⦗coverable T ∪₁ issuable T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite id_union, !seq_union_r, dom_union.
    unionL.
    { apply rf_ppo_loc_coverable_in_I. }
    rewrite (dom_l (wf_rfD WF)), !seqA.
    arewrite (rf ⨾ ppo ∩ same_loc ⊆ ar ∪ rf ⨾ ppo ∩ same_loc).
      by apply ar_rf_ppo_loc_issuable_in_I.
  Qed.

  Lemma rfrmw_coverable_issuable_in_I  :
    dom_rel (rf ⨾ rmw ⨾ ⦗coverable T ∪₁ issuable T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite (rmw_in_ppo_loc WF). by apply rf_ppo_loc_coverable_issuable_in_I.
  Qed.

  Lemma rf_ppo_loc_I_in_I  :
    dom_rel (rf ⨾ (ppo ∩ same_loc) ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite (dom_l (wf_rfD WF)), seqA.
    arewrite (rf ⨾ (ppo ∩ same_loc) ⊆ ar ∪ rf ⨾ (ppo ∩ same_loc)).
      by apply ar_rf_ppo_loc_I_in_I.
  Qed.

  Lemma rfrmw_I_in_I  :
    dom_rel (rf ⨾ rmw ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite (rmw_in_ppo_loc WF). by apply rf_ppo_loc_I_in_I.
  Qed.

  Lemma rf_ppo_loc_rt_I_in_I  :
    dom_rel ((rf ⨾ ppo ∩ same_loc)＊ ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite rtE. rewrite !seq_union_l, !seq_id_l. rewrite dom_union.
    unionL; [basic_solver|].
    rewrite (dom_l (wf_rfD WF)). rewrite !seqA.
    rewrite inclusion_ct_seq_eqv_l. rewrite !seqA.
    arewrite (rf ⨾ ppo ∩ same_loc ⊆ ar ∪ rf ⨾ ppo ∩ same_loc).
    apply ar_rf_ppo_loc_ct_I_in_I.
  Qed.

  Lemma rfrmw_rt_I_in_I  :
    dom_rel ((rf ⨾ rmw)＊ ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite (rmw_in_ppo_loc WF). by apply rf_ppo_loc_rt_I_in_I.
  Qed.

  Lemma rf_ppo_loc_CI_in_I  :
    dom_rel (rf ⨾ (ppo ∩ same_loc) ⨾ ⦗covered T ∪₁ issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite id_union, !seq_union_r, dom_union.
    unionL.
    { by apply rf_ppo_loc_C_in_I. }
      by apply rf_ppo_loc_I_in_I.
  Qed.

  Lemma rfrmw_CI_in_I  :
    dom_rel (rf ⨾ rmw ⨾ ⦗covered T ∪₁ issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite (rmw_in_ppo_loc WF). by apply rf_ppo_loc_CI_in_I.
  Qed.

  Lemma ar_rf_ppo_loc_coverable_in_CI  :
    dom_rel ((ar ∪ rf ⨾ ppo ∩ same_loc) ⨾ ⦗coverable T⦘) ⊆₁ covered T ∪₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite seq_union_l, dom_union, !seqA.
    unionL.
    { by apply ar_coverable_in_CI. }
    rewrite rf_ppo_loc_coverable_in_I; eauto with hahn.
  Qed.

  Lemma ar_rfrmw_coverable_in_CI  :
    dom_rel ((ar ∪ rf ⨾ rmw) ⨾ ⦗coverable T⦘) ⊆₁ covered T ∪₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite (rmw_in_ppo_loc WF). by apply ar_rf_ppo_loc_coverable_in_CI.
  Qed.

  Lemma ar_rf_ppo_loc_C_in_CI  :
    dom_rel ((ar ∪ rf ⨾ ppo ∩ same_loc) ⨾ ⦗covered T⦘) ⊆₁ covered T ∪₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite covered_in_coverable at 1.
    apply ar_rf_ppo_loc_coverable_in_CI.
  Qed.

  Lemma ar_rfrmw_C_in_CI  :
    dom_rel ((ar ∪ rf ⨾ rmw) ⨾ ⦗covered T⦘) ⊆₁ covered T ∪₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite (rmw_in_ppo_loc WF). by apply ar_rf_ppo_loc_C_in_CI.
  Qed.

  Lemma ar_rf_ppo_loc_coverable_issuable_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ ppo ∩ same_loc) ⨾ ⦗coverable T ∪₁ issuable T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite seq_union_l, seq_union_r, dom_union; unionL.
    { apply W_ar_coverable_issuable_in_CI. }
    arewrite_id ⦗W⦘. rewrite seq_id_l.
    apply rf_ppo_loc_coverable_issuable_in_I.
  Qed.

  Lemma ar_rfrmw_coverable_issuable_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ rmw) ⨾ ⦗coverable T ∪₁ issuable T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite (rmw_in_ppo_loc WF). by apply ar_rf_ppo_loc_coverable_issuable_in_I.
  Qed.

  Lemma ar_rf_ppo_loc_CI_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ ppo ∩ same_loc) ⨾ ⦗covered T ∪₁ issued T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite seq_union_l, seq_union_r, dom_union; unionL.
    { apply ar_CI_in_CI. }
    arewrite_id ⦗W⦘. rewrite seq_id_l.
    apply rf_ppo_loc_CI_in_I.
  Qed.

  Lemma ar_rfrmw_CI_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ rmw) ⨾ ⦗covered T ∪₁ issued T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite (rmw_in_ppo_loc WF). by apply ar_rf_ppo_loc_CI_in_I.
  Qed.

  Lemma ar_rf_ppo_loc_ct_coverable_issuable_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ ppo ∩ same_loc)⁺ ⨾ ⦗coverable T ∪₁ issuable T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    intros x [y HH].
    destruct_seq HH as [AA BB].
    apply clos_trans_tn1 in HH.
    induction HH as [y HH|y z QQ].
    { eapply ar_rf_ppo_loc_coverable_issuable_in_I. basic_solver 10. }
    apply clos_tn1_trans in HH.
    destruct QQ as [QQ|QQ].
    2: { apply IHHH. right.
         apply issued_in_issuable.
         apply rf_ppo_loc_coverable_issuable_in_I.
         exists z. apply seqA. basic_solver. }
    destruct BB as [BB|BB].
    2: { apply ar_rf_ppo_loc_ct_issuable_in_I. exists z.
         apply seq_eqv_lr. splits; auto.
         apply ct_end. exists y. split; auto.
         { by apply clos_trans_in_rt. }
           by left. }
    apply IHHH.
    destruct QQ as [[QQ|QQ]|QQ].
    { left. apply covered_in_coverable.
      apply dom_sc_coverable. exists z. basic_solver. }
    { right. apply issued_in_issuable.
      apply dom_rf_coverable. exists z.
      do 2 red in QQ. basic_solver. }
    left. apply covered_in_coverable.
    apply dom_sb_coverable. exists z.
    apply seq_eqv_r. split; auto. by apply ar_int_in_sb.
  Qed.

  Lemma ar_rfrmw_ct_coverable_issuable_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ rmw)⁺ ⨾ ⦗coverable T ∪₁ issuable T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite (rmw_in_ppo_loc WF). apply ar_rf_ppo_loc_ct_coverable_issuable_in_I.
  Qed.

  Lemma ar_rf_ppo_loc_ct_CI_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ ppo ∩ same_loc)⁺ ⨾ ⦗covered T ∪₁ issued T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite covered_in_coverable.
    rewrite issued_in_issuable at 1.
    apply ar_rf_ppo_loc_ct_coverable_issuable_in_I.
  Qed.

  Lemma ar_rfrmw_ct_CI_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ rmw)⁺ ⨾ ⦗covered T ∪₁ issued T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite (rmw_in_ppo_loc WF). apply ar_rf_ppo_loc_ct_CI_in_I.
  Qed.

  Lemma ar_rf_ppo_loc_rt_coverable_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ ppo ∩ same_loc)＊ ⨾ ⦗coverable T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite rtE. rewrite !seq_union_l, !seq_union_r, dom_union, seq_id_l.
    unionL.
    { generalize w_coverable_issued. basic_solver. }
    arewrite (coverable T ⊆₁ coverable T ∪₁ issuable T).
    apply ar_rf_ppo_loc_ct_coverable_issuable_in_I.
  Qed.

  Lemma ar_rfrmw_rt_coverable_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ rmw)＊ ⨾ ⦗coverable T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite (rmw_in_ppo_loc WF). apply ar_rf_ppo_loc_rt_coverable_in_I.
  Qed.

  Lemma ar_rf_ppo_loc_rt_CI_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ ppo ∩ same_loc)＊ ⨾ ⦗covered T ∪₁ issued T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite rtE. rewrite !seq_union_l, !seq_union_r, dom_union, seq_id_l.
    unionL.
    { generalize w_covered_issued. basic_solver. }
    apply ar_rf_ppo_loc_ct_CI_in_I.
  Qed.

  Lemma ar_rfrmw_rt_CI_in_I  :
    dom_rel (⦗W⦘ ⨾ (ar ∪ rf ⨾ rmw)＊ ⨾ ⦗covered T ∪₁ issued T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite (rmw_in_ppo_loc WF). apply ar_rf_ppo_loc_rt_CI_in_I.
  Qed.

  Lemma ar_rt_C_in_I  :
    dom_rel (⦗W⦘ ⨾ ar＊ ⨾ ⦗covered T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    unfolder.
    ins. desf.
    apply clos_rt_rtn1 in H0.
    induction H0.
    { apply w_covered_issued; basic_solver. }
    apply clos_rtn1_rt in H2.
    destruct H0 as [[AA|AA]|AA].
    3: { apply ar_int_in_sb in AA; auto.
         apply IHclos_refl_trans_n1.
         eapply dom_sb_covered; basic_solver 10. }
    { apply IHclos_refl_trans_n1.
      eapply dom_sc_covered; basic_solver 10. }
    apply ar_rt_I_in_I; auto.
    exists y. unfolder; splits; auto.
    apply dom_rf_covered; auto.
    eexists. apply seq_eqv_r. by split; [apply AA|].
  Qed.

  Lemma ar_rt_CI_in_I  :
    dom_rel (⦗W⦘ ⨾ ar＊ ⨾ ⦗covered T ∪₁ issued T⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH.
    rewrite id_union, !seq_union_r, dom_union; unionL.
    { by apply ar_rt_C_in_I. }
      by apply ar_rt_I_in_I.
  Qed.

  Lemma sbCsbI_CsbI   :
    sb ⨾ ⦗covered T ∪₁ dom_rel (sb^? ⨾ ⦗issued T⦘)⦘ ⊆
    ⦗covered T ∪₁ dom_rel (sb^? ⨾ ⦗issued T⦘)⦘ ⨾ sb.
  Proof using TCCOH.
    rewrite id_union, !seq_union_r, !seq_union_l.
    apply union_mori.
    { rewrite sb_covered; eauto. basic_solver. }
    generalize (@sb_trans G). basic_solver 10.
  Qed.

  Lemma issuable_next_w :
    W ∩₁ next (covered T) ⊆₁ issuable T.
  Proof using WF IMMCON TCCOH.
    unfold issuable, next.
    rewrite fwbob_in_bob, bob_in_sb.
    apply set_subset_inter_r; split.
    { basic_solver 10. }
    rewrite !set_interA.
    arewrite (dom_cond sb (covered T) ∩₁ set_compl (covered T) ⊆₁ dom_cond sb (covered T)).
    { basic_solver 10. }
    intros e [WW [HH DD]]. red in DD. red.
    arewrite (⦗eq e⦘ ⊆ ⦗W⦘ ⨾ ⦗eq e⦘) by basic_solver.
    rewrite ct_end, !seqA.
    arewrite (ar ∪ rf ⨾ ppo ∩ same_loc ⊆ (ar ∪ sb)^? ⨾ ar) at 2.
    { apply inclusion_union_l; [basic_solver|].
      rewrite rfi_union_rfe. rewrite rfe_in_ar, ppo_in_ar.
      arewrite (rfi ⊆ sb). basic_solver 10. }
    arewrite (ar ⨾ ⦗W⦘ ⊆ sb).
    { unfold imm_s.ar.
      rewrite !seq_union_l. rewrite (ar_int_in_sb WF).
      rewrite wf_scD with (sc:=sc); [|by apply IMMCON].
      rewrite (wf_rfeD WF). type_solver. }
    apply dom_rel_helper_in in DD.
    rewrite DD.
    arewrite ((ar ∪ sb)^? ⨾ ⦗covered T⦘ ⊆ ⦗covered T ∪₁ issued T⦘ ⨾ (ar ∪ sb)^? ⨾ ⦗covered T⦘).
    2: { etransitivity.
         2: by apply ar_rf_ppo_loc_rt_CI_in_I.
         basic_solver 20. }
    apply dom_rel_helper_in.
    rewrite crE, !seq_union_l, !dom_union, seq_id_l.
    unionL; [basic_solver| |].
    2: rewrite dom_sb_covered; basic_solver.
    apply ar_C_in_CI.
  Qed.

  Lemma dom_rfe_ppo_issued :
    dom_rel (rfe ⨾ ppo ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite (dom_l (wf_rfeD WF)).
    arewrite (rfe ⊆ ar).
    rewrite ppo_in_ar.
    sin_rewrite ar_ar_in_ar_ct.
      by apply ar_ct_I_in_I.
  Qed.

  Lemma dom_ar_ct_issuable : dom_rel (⦗W⦘ ⨾ ar⁺ ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using.
    arewrite (ar ⊆ ar ∪ rf ⨾ ppo ∩ same_loc).
    unfold issuable.
    basic_solver 20.
  Qed.

  Lemma dom_detour_rfe_ppo_issuable :
    dom_rel ((detour ∪ rfe) ⨾ ppo ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using WF.
    rewrite (dom_l (wf_rfeD WF)).
    rewrite (dom_l (wf_detourD WF)).
    arewrite (rfe ⊆ ar).
    arewrite (detour ⊆ ar).
    relsf.
    rewrite ppo_in_ar, !seqA.
    sin_rewrite ar_ar_in_ar_ct.
    apply dom_ar_ct_issuable.
  Qed.

  Lemma dom_detour_rfe_ppo_issued :
    dom_rel ((detour ∪ rfe) ⨾ ppo ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite issued_in_issuable at 1.
    apply dom_detour_rfe_ppo_issuable.
  Qed.

  Lemma dom_detour_rfe_acq_sb_issuable :
    dom_rel ((detour ∪ rfe) ⨾ ⦗R ∩₁ Acq⦘ ⨾ sb ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using WF.
    rewrite (dom_l (wf_detourD WF)).
    rewrite (dom_l (wf_rfeD WF)).
    arewrite (rfe ⊆ ar).
    arewrite (detour ⊆ ar).
    relsf.
    arewrite (⦗R ∩₁ Acq⦘ ⨾ sb ⊆ ar).
    { arewrite (⦗R ∩₁ Acq⦘ ⨾ sb ⊆ bob). unfold imm_s.ar, ar_int. eauto with hahn. }
    sin_rewrite ar_ar_in_ar_ct.
    apply dom_ar_ct_issuable.
  Qed.

  Lemma dom_detour_rfe_acq_sb_issued :
    dom_rel ((detour ∪ rfe) ⨾ ⦗R ∩₁ Acq⦘ ⨾ sb ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite issued_in_issuable at 1.
    apply dom_detour_rfe_acq_sb_issuable.
  Qed.

  Lemma dom_detour_rmwrfi_rfe_acq_sb_issuable :
    dom_rel ((detour ∪ rfe) ⨾ (rmw ⨾ rfi)＊ ⨾ ⦗R ∩₁ Acq⦘ ⨾ sb ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using WF.
    arewrite (⦗R ∩₁ Acq⦘ ⊆ ⦗Acq⦘ ⨾ ⦗R ∩₁ Acq⦘) by basic_solver.
    arewrite (rfi ⊆ rf).
    sin_rewrite (@rmwrf_rt_Acq_in_ar_rfrmw_rt G WF sc); auto.
    rewrite (dom_l (wf_detourD WF)).
    rewrite (dom_l (wf_rfeD WF)).
    arewrite (rfe ⊆ ar).
    arewrite (detour ⊆ ar).
    relsf.
    arewrite (⦗R ∩₁ Acq⦘ ⨾ sb ⊆ ar).
    { arewrite (⦗R ∩₁ Acq⦘ ⨾ sb ⊆ bob). unfold imm_s.ar, ar_int. eauto with hahn. }
    arewrite (ar ⊆ ar ∪ rf ⨾ rmw) at 3.
    arewrite (ar ⊆ ar ∪ rf ⨾ rmw) at 1.
    seq_rewrite <- ct_end.
    arewrite ((ar ∪ rf ⨾ rmw) ⨾ (ar ∪ rf ⨾ rmw)⁺ ⊆ (ar ∪ rf ⨾ rmw)⁺).
    { rewrite ct_step with (r:= ar ∪ rf ⨾ rmw) at 1. apply ct_ct. }
    apply ar_rfrmw_ct_issuable_in_I.
  Qed.

  Lemma dom_detour_rmwrfi_rfe_acq_sb_issued :
    dom_rel ((detour ∪ rfe) ⨾ (rmw ⨾ rfi)＊ ⨾ ⦗R ∩₁ Acq⦘ ⨾ sb ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite issued_in_issuable at 1.
    apply dom_detour_rmwrfi_rfe_acq_sb_issuable.
  Qed.

  Lemma dom_rfe_acq_sb_issuable :
    dom_rel (rfe ⨾ ⦗R ∩₁ Acq⦘ ⨾ sb ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using WF.
    arewrite (rfe ⊆ detour ∪ rfe).
    apply dom_detour_rfe_acq_sb_issuable.
  Qed.

  Lemma dom_rfe_acq_sb_issued :
    dom_rel (rfe ⨾ ⦗R ∩₁ Acq⦘ ⨾ sb ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite issued_in_issuable at 1.
    apply dom_rfe_acq_sb_issuable.
  Qed.

  Lemma dom_wex_sb_issuable :
    dom_rel (⦗W_ex_acq⦘ ⨾ sb ⨾ ⦗issuable T⦘) ⊆₁ issued T.
  Proof using WF.
    arewrite (⦗W_ex_acq⦘ ⊆ ⦗W⦘ ⨾ ⦗W_ex_acq⦘).
    { rewrite <- seq_eqvK at 1.
      rewrite (W_ex_in_W WF) at 1. basic_solver. }
    arewrite (⦗issuable T⦘ ⊆ ⦗W⦘ ⨾ ⦗issuable T⦘).
    { unfold issuable. basic_solver 10. }
    arewrite (⦗W_ex_acq⦘ ⨾ sb ⨾ ⦗W⦘ ⊆ ar).
    apply ar_issuable_is_issued.
  Qed.

  Lemma dom_wex_sb_issued :
    dom_rel (⦗W_ex_acq⦘ ⨾ sb ⨾ ⦗issued T⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite issued_in_issuable at 1.
    apply dom_wex_sb_issuable.
  Qed.

  Lemma rf_rmw_issued_rfi_rmw_issued :
    (rf ⨾ rmw)＊ ⨾ ⦗issued T⦘ ⊆ (rfi ⨾ rmw)＊ ⨾ ⦗issued T⦘ ⨾ (rf ⨾ rmw)＊.
  Proof using WF TCCOH IMMCON.
    assert (transitive sb) as SBT by apply sb_trans.
    eapply rt_ind_left with (P:= fun r => r ⨾ ⦗issued T⦘).
    { by eauto with hahn. }
    { basic_solver 12. }
    intros k H; rewrite !seqA.
    sin_rewrite H.
    rewrite rfi_union_rfe at 1; relsf; unionL.
    rewrite <- seqA; seq_rewrite <- ct_begin; basic_solver 12.
    rewrite rtE at 2.
    relsf; unionR left.
    arewrite (rfe ⨾ rmw ⨾ (rfi ⨾ rmw)＊ ⨾ ⦗issued T⦘ ⊆
                  ⦗issued T⦘ ⨾ rfe ⨾ rmw ⨾ (rfi ⨾ rmw)＊ ⨾ ⦗issued T⦘).
    { apply dom_rel_helper.
      arewrite (rmw ⨾ (rfi ⨾ rmw)＊ ⊆ ar＊).
      { arewrite (rfi ⊆ rf).
        rewrite (rmw_in_ppo WF) at 1. rewrite ppo_in_ar.
        rewrite rtE at 1. rewrite seq_union_r, seq_id_r.
        apply inclusion_union_l.
        { rewrite ct_step at 1. apply inclusion_t_rt. }
        rewrite rmw_in_ppo_loc; auto.
        rewrite ar_rf_ppo_loc_ct_in_ar_ct; auto. apply inclusion_t_rt. }
      rewrite (dom_l (wf_rfeD WF)), !seqA.
      arewrite (rfe ⊆ ar) at 1.
      seq_rewrite <- ct_begin. by apply ar_ct_I_in_I. }
    arewrite (rfe ⨾ rmw ⊆ rf ⨾ rmw).
    arewrite (rfi ⊆ rf).
    arewrite (rf ⨾ rmw ⨾ (rf ⨾ rmw)＊ ⊆ (rf ⨾ rmw)⁺).
    { rewrite <- seqA. apply ct_begin. }
    arewrite_id ⦗issued T⦘ at 2. rewrite seq_id_l.
    rewrite ct_rt. by rewrite inclusion_t_rt.
  Qed.

  Lemma wex_rfi_rfe_rmw_issuable_is_issued :
    dom_rel ((⦗ W_ex_acq ⦘ ⨾ rfi ∪ rfe) ⨾ rmw ⨾ ⦗ issuable T ⦘) ⊆₁ issued T.
  Proof using WF.
    rewrite seq_union_l. rewrite dom_union.
    apply set_subset_union_l; split.
    { rewrite seqA. rewrite (rfi_in_sbloc' WF). rewrite (rmw_in_sb WF).
      arewrite (sb ∩ same_loc ⨾ sb ⊆ sb).
      { generalize (@sb_trans G). basic_solver. }
      arewrite (⦗issuable T⦘ ⊆ ⦗W⦘ ⨾ ⦗issuable T⦘).
      { unfold issuable. basic_solver 10. }
      arewrite (⦗W_ex_acq⦘ ⊆ ⦗W⦘ ⨾ ⦗W_ex_acq⦘).
      { rewrite <- seq_eqvK at 1.
        rewrite (W_ex_in_W WF) at 1. basic_solver. }
      arewrite (⦗W_ex_acq⦘ ⨾ sb ⨾ ⦗W⦘ ⊆ ar).
      rewrite ct_step with (r:=ar).
      unfold issuable.
      arewrite (ar ⊆ ar ∪ rf ⨾ ppo ∩ same_loc) at 1.
      basic_solver 10. }
    rewrite (rmw_in_ppo WF).
    rewrite ppo_in_ar.
    rewrite (dom_l (wf_rfeD WF)), !seqA.
    arewrite (rfe ⊆ ar).
    sin_rewrite ar_ar_in_ar_ct.
    unfold issuable.
    arewrite (ar ⊆ ar ∪ rf ⨾ ppo ∩ same_loc) at 1.
    basic_solver 10.
  Qed.

  Lemma wex_rfi_rfe_rmw_issued_is_issued :
    dom_rel ((⦗ W_ex_acq ⦘ ⨾ rfi ∪ rfe) ⨾ rmw ⨾ ⦗ issued T ⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    rewrite issued_in_issuable at 1; auto.
      by apply wex_rfi_rfe_rmw_issuable_is_issued.
  Qed.

  Lemma wex_rf_rmw_issued_is_issued :
    dom_rel (⦗ W_ex_acq ⦘ ⨾ rf ⨾ rmw ⨾ ⦗ issued T ⦘) ⊆₁ issued T.
  Proof using WF TCCOH.
    arewrite (⦗W_ex_acq⦘ ⨾ rf ⊆ (⦗ W_ex_acq ⦘ ⨾ rfi ∪ rfe)).
    { rewrite rfi_union_rfe. basic_solver. }
      by apply wex_rfi_rfe_rmw_issued_is_issued.
  Qed.

  Lemma rf_rmw_issued :
    (rf ⨾ rmw)＊ ⨾ ⦗issued T⦘ ⊆ (rf ⨾ rmw ⨾ ⦗issued T⦘)＊.
  Proof using WF TCCOH.
    intros x y HH. destruct_seq_r HH as II.
    apply clos_rt_rtn1 in HH.
    induction HH as [|y z TT].
    { apply rt_refl. }
    apply rt_end. right. exists y.
    split.
    2: apply seqA; basic_solver.
    apply IHHH.
    apply ar_rfrmw_I_in_I. exists z.
    apply seq_eqv_lr. splits; auto.
    2: by right.
    red in TT. desf. apply (wf_rfD WF) in TT. unfolder in TT. desf.
  Qed.

  Lemma dom_W_Rel_sb_loc_I_in_C :
    dom_rel (⦗W ∩₁ Rel⦘ ⨾ sb ∩ same_loc ⨾ ⦗W⦘ ⨾ ⦗issued T⦘) ⊆₁ covered T.
  Proof using TCCOH.
    rewrite issued_in_issuable.
    arewrite (⦗issuable T⦘ ⊆ ⦗dom_cond fwbob (covered T)⦘).
    { unfold issuable. basic_solver 10. }
    rewrite <- !seqA.
    rewrite dom_cond_elim1; [basic_solver 21|].
    unfold imm_bob.fwbob.
    basic_solver 12.
  Qed.

  Lemma I_eq_EW_I : issued T ≡₁ E ∩₁ W ∩₁ issued T.
  Proof using TCCOH.
    split; [|clear; basic_solver].
    generalize issuedW, issuedE.
    basic_solver.
  Qed.

  Lemma W_rel_sb_loc_W_CI :
    (⦗W ∩₁ Rel⦘ ⨾ sb ∩ same_loc ⨾ ⦗W⦘) ⨾ ⦗covered T ∪₁ issued T⦘ ⊆
    ⦗covered T ∪₁ issued T⦘ ⨾ (⦗W ∩₁ Rel⦘ ⨾ sb ∩ same_loc ⨾ ⦗W⦘).
  Proof using TCCOH.
    (* case_refl _; [basic_solver|]. *)
    rewrite !seqA.
    arewrite (⦗W⦘ ⨾ ⦗covered T ∪₁ issued T⦘ ⊆ ⦗W⦘ ⨾ ⦗issued T⦘).
    { generalize w_covered_issued. basic_solver. }
    generalize dom_W_Rel_sb_loc_I_in_C. basic_solver 12.
  Qed.

  Lemma sb_W_rel_CI (RELCOV : W ∩₁ Rel ∩₁ issued T ⊆₁ covered T) :
    (sb ⨾ ⦗W ∩₁ Rel⦘) ⨾ ⦗covered T ∪₁ issued T⦘ ⊆ ⦗covered T ∪₁ issued T⦘ ⨾ (sb ⨾ ⦗W ∩₁ Rel⦘).
  Proof using TCCOH.
    generalize RELCOV, dom_sb_covered.
    basic_solver 12.
  Qed.

  Lemma W_Rel_sb_loc_I : dom_rel (⦗W ∩₁ Rel⦘ ⨾  (sb ∩ same_loc) ⨾ ⦗W ∩₁ issued T⦘) ⊆₁ issued T.
  Proof using TCCOH.
    generalize dom_W_Rel_sb_loc_I_in_C, w_covered_issued. basic_solver 21.
  Qed.

  Lemma sb_loc_issued  :
    ⦗W ∩₁ Rel⦘ ⨾ sb ∩ same_loc ⨾ ⦗W⦘ ⨾ ⦗issued T⦘ ⊆
               ⦗covered T⦘ ⨾ ⦗W ∩₁ Rel⦘ ⨾ sb ∩ same_loc ⨾ ⦗W⦘.
  Proof using TCCOH.
    seq_rewrite (dom_rel_helper dom_W_Rel_sb_loc_I_in_C).
    basic_solver.
  Qed.

  Lemma dom_F_sb_I_in_C :
    dom_rel (⦗F ∩₁ Acq/Rel⦘ ⨾ sb ⨾ ⦗issued T⦘) ⊆₁ covered T.
  Proof using TCCOH.
    rewrite issued_in_issuable.
    arewrite (⦗issuable T⦘ ⊆ ⦗dom_cond fwbob (covered T)⦘).
    { unfold issuable. basic_solver 10. }
    rewrite <- !seqA.
    rewrite dom_cond_elim1; [basic_solver 21|].
    unfold imm_bob.fwbob.
    basic_solver 12.
  Qed.

  Lemma F_sb_I_in_C  :
    ⦗F ∩₁ Acq/Rel⦘ ⨾ sb ⨾ ⦗issued T⦘ ⊆ ⦗covered T⦘ ⨾ ⦗F ∩₁ Acq/Rel⦘ ⨾ sb.
  Proof using TCCOH.
    seq_rewrite (dom_rel_helper dom_F_sb_I_in_C).
    basic_solver.
  Qed.

  Lemma dom_F_Rel_sb_I_in_C :  dom_rel (⦗F ∩₁ Rel⦘ ⨾  sb ⨾ ⦗issued T⦘) ⊆₁ covered T.
  Proof using TCCOH. etransitivity; [|apply dom_F_sb_I_in_C]; mode_solver 21. Qed.

  Lemma dom_F_Acq_sb_I_in_C :  dom_rel (⦗F ∩₁ Acq⦘ ⨾  sb ⨾ ⦗issued T⦘) ⊆₁ covered T.
  Proof using TCCOH. etransitivity; [|apply dom_F_sb_I_in_C]; mode_solver 12. Qed.

  Lemma coverable_add_eq_iff e:
    coverable T e <-> coverable (mkTC (covered T ∪₁ eq e) (issued T)) e.
  Proof using IMMCON.
    split.
    { eapply traversal_mon; simpls. eauto with hahn. }
    unfold coverable; simpls.
    intros [[EE COVE] HH].
    split.
    { clear HH. split; auto.
      unfolder in *. ins. desf.
      edestruct COVE.
      { eexists; eauto. }
      { done. }
      exfalso. desf. eapply sb_irr; eauto. }
    destruct HH as [[HH|HH]|[AA HH]]; [do 2 left| left;right|right]; auto.
    split; auto.
    unfolder in *. ins. desf. edestruct HH.
    { eexists; eauto. }
    { done. }
    exfalso. desf. eapply sc_irr; eauto.
    apply IMMCON.
  Qed.

  Lemma issuable_add_eq_iff e :
    issuable T e <-> issuable (mkTC (covered T) (issued T ∪₁ eq e)) e.
  Proof using WF IMMCON.
    cdes IMMCON.
    split.
    { eapply traversal_mon; simpls. eauto with hahn. }
    unfold issuable; simpls.
    intros [[EE ISSE] HH].
    unfold dom_cond in *.
    split; [split|]; auto.
    all: intros x BB; set (CC:=BB).
    apply HH in CC.
    destruct CC; desf.
    exfalso; clear -BB WF IMMCON.
    unfolder in *; desf.
    eapply ar_rf_ppo_loc_acyclic; eauto.
    apply IMMCON.
  Qed.

  Variable RELCOV : W ∩₁ Rel ∩₁ issued T ⊆₁ covered T.

  Lemma dom_release_issued :
    dom_rel (release ⨾ ⦗ issued T ⦘) ⊆₁ covered T.
  Proof using WF TCCOH RELCOV IMMCON.
    unfold imm_s_hb.release, imm_s_hb.rs.
    rewrite !seqA.
    sin_rewrite rf_rmw_issued_rfi_rmw_issued.
    rewrite (dom_r (wf_rmwD WF)) at 1.
    arewrite (⦗W⦘ ⨾ (rfi ⨾ rmw ⨾ ⦗W⦘)＊ ⊆ (rfi ⨾ rmw)＊ ⨾ ⦗W⦘).
    { rewrite rtE; relsf; unionL; [basic_solver|].
      rewrite <- seqA; rewrite inclusion_ct_seq_eqv_r; basic_solver. }
    rewrite (rmw_in_sb_loc WF) at 1; rewrite (rfi_in_sbloc' WF).
    generalize (@sb_same_loc_trans G); ins; relsf.
    rewrite !crE; relsf; unionL; splits.
    { revert RELCOV; basic_solver 21. }
    { generalize dom_W_Rel_sb_loc_I_in_C. basic_solver 21. }
    2: generalize (@sb_trans G).
    all: generalize dom_F_Rel_sb_I_in_C; basic_solver 40.
  Qed.

  Lemma release_issued :
    release ⨾ ⦗ issued T ⦘ ⊆ ⦗covered T⦘ ⨾ release.
  Proof using WF TCCOH RELCOV IMMCON.
    seq_rewrite (dom_rel_helper dom_release_issued).
    basic_solver.
  Qed.

  Lemma dom_release_rf_coverable :
    dom_rel (release ⨾ rf ⨾ ⦗ coverable T ⦘) ⊆₁ covered T.
  Proof using WF TCCOH RELCOV IMMCON.
    generalize dom_release_issued.
    generalize dom_rf_coverable.
    basic_solver 21.
  Qed.

  Lemma release_rf_coverable :
    release ⨾ rf ⨾ ⦗ coverable T ⦘ ⊆ ⦗ covered T ⦘ ⨾ release ⨾ rf.
  Proof using WF TCCOH RELCOV IMMCON.
    seq_rewrite (dom_rel_helper dom_release_rf_coverable).
    basic_solver.
  Qed.

  Lemma release_rf_covered :
    release ⨾ rf ⨾ ⦗ covered T ⦘ ⊆ ⦗ covered T ⦘ ⨾ release ⨾ rf.
  Proof using WF TCCOH RELCOV IMMCON.
    rewrite covered_in_coverable at 1.
      by apply release_rf_coverable.
  Qed.

  Lemma dom_sb_W_rel_issued  :
    dom_rel (sb ⨾ ⦗W ∩₁ Rel⦘ ⨾ ⦗issued T⦘) ⊆₁ covered T.
  Proof using TCCOH.
    rewrite issued_in_issuable.
    arewrite (⦗issuable T⦘ ⊆ ⦗dom_cond fwbob (covered T)⦘).
    { unfold issuable. basic_solver 10. }
    rewrite <- !seqA.
    rewrite dom_cond_elim1; [basic_solver 21|].
    unfold imm_bob.fwbob.
    basic_solver 12.
  Qed.

  Lemma sb_W_rel_issued  :
    sb ⨾ ⦗W ∩₁ Rel⦘ ⨾ ⦗issued T⦘ ⊆ ⦗covered T⦘ ⨾ sb ⨾ ⦗W ∩₁ Rel⦘.
  Proof using TCCOH.
    seq_rewrite (dom_rel_helper dom_sb_W_rel_issued).
    basic_solver.
  Qed.

  Lemma dom_sw_coverable :
    dom_rel (sw ⨾ ⦗ coverable T ⦘) ⊆₁ covered T.
  Proof using WF TCCOH RELCOV IMMCON.
    unfold imm_s_hb.sw.
    generalize dom_sb_coverable.
    generalize dom_release_rf_coverable.
    generalize covered_in_coverable.
    basic_solver 21.
  Qed.

  Lemma sw_coverable : sw ⨾ ⦗ coverable T ⦘ ⊆ ⦗covered T⦘ ⨾ sw.
  Proof using WF TCCOH RELCOV IMMCON.
    seq_rewrite (dom_rel_helper dom_sw_coverable).
    basic_solver.
  Qed.

  Lemma sw_covered : sw ⨾ ⦗ covered T ⦘ ⊆ ⦗covered T⦘ ⨾ sw.
  Proof using WF TCCOH RELCOV IMMCON.
    rewrite covered_in_coverable at 1.
      by apply sw_coverable.
  Qed.

  Lemma hb_coverable : hb ⨾ ⦗ coverable T ⦘ ⊆ ⦗covered T⦘ ⨾ hb.
  Proof using WF TCCOH RELCOV IMMCON.
    unfold imm_s_hb.hb.
    assert (A: (sb ∪ sw) ⨾ ⦗coverable T⦘ ⊆ ⦗covered T⦘ ⨾ (sb ∪ sw)⁺).
    { relsf.
      rewrite sb_coverable, sw_coverable.
      rewrite <- ct_step; basic_solver. }
    unfold imm_s_hb.hb.
    eapply ct_ind_left with (P:= fun r => r ⨾ ⦗coverable T⦘); eauto with hahn.
    intros k H; rewrite !seqA, H.
    rewrite covered_in_coverable at 1.
    sin_rewrite A.
    arewrite ((sb ∪ sw)⁺ ⊆ (sb ∪ sw)＊) at 1.
    relsf.
  Qed.

Lemma sc_sb_I_dom_C  :
  dom_rel (sc ⨾ sb ⨾ ⦗issued T⦘) ⊆₁ covered T.
Proof using WF IMMCON TCCOH RELCOV.
  cdes IMMCON.
  rewrite (dom_r (wf_scD Wf_sc)).
  unfolder. ins. desf.
  cdes TCCOH.
  assert (covered T z) as AA.
  2: { apply CC in AA. red in AA.
       unfolder in AA. desf.
       1,2: type_solver.
       eapply AA2. eexists.
       apply seq_eqv_r. split; eauto. }
  eapply II; eauto.
  eexists. apply seq_eqv_r. split; eauto.
  apply sb_from_f_in_fwbob.
  apply seq_eqv_l. split; [split|]; auto.
  mode_solver.
Qed.

  Lemma dom_hb_coverable :
    dom_rel (hb ⨾ ⦗ coverable T ⦘) ⊆₁ covered T.
  Proof using WF TCCOH RELCOV IMMCON.
    rewrite hb_coverable; basic_solver 10.
  Qed.

  Lemma hb_covered :
    hb ⨾ ⦗ covered T ⦘ ⊆ ⦗covered T⦘ ⨾ hb.
  Proof using WF TCCOH RELCOV IMMCON.
    rewrite covered_in_coverable at 1.
      by apply hb_coverable.
  Qed.

  Lemma dom_urr_coverable l:
    dom_rel (urr l ⨾ ⦗ coverable T ⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH RELCOV.
    unfold CombRelations.urr.
    generalize dom_hb_coverable.
    generalize dom_sc_coverable.
    generalize dom_rf_coverable.
    generalize covered_in_coverable.
    generalize w_coverable_issued.
    basic_solver 21.
  Qed.

  Lemma urr_coverable l:
    urr l ⨾ ⦗ coverable T ⦘ ⊆ ⦗issued T⦘ ⨾ urr l.
  Proof using WF IMMCON TCCOH RELCOV.
    rewrite (dom_rel_helper (@dom_urr_coverable l)).
    basic_solver.
  Qed.

  Lemma urr_covered l:
    urr l ⨾ ⦗ covered T ⦘ ⊆ ⦗issued T⦘ ⨾ urr l.
  Proof using WF IMMCON TCCOH RELCOV.
    rewrite covered_in_coverable at 1.
      by apply urr_coverable.
  Qed.

  Lemma dom_c_acq_coverable i l A:
    dom_rel (c_acq i l A ⨾ ⦗ coverable T ⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH RELCOV.
    unfold CombRelations.c_acq.
    generalize (@dom_urr_coverable l).
    generalize covered_in_coverable.
    generalize dom_release_issued.
    generalize dom_rf_coverable.
    basic_solver 21.
  Qed.

  Lemma c_acq_coverable i l A:
    c_acq i l A ⨾ ⦗ coverable T ⦘ ⊆ ⦗issued T⦘ ⨾ c_acq i l A.
  Proof using WF IMMCON TCCOH RELCOV.
    rewrite (dom_rel_helper (@dom_c_acq_coverable i l A)).
    basic_solver.
  Qed.

  Lemma c_acq_covered i l A:
    c_acq i l A ⨾ ⦗ covered T ⦘ ⊆ ⦗issued T⦘ ⨾ c_acq i l A.
  Proof using WF IMMCON TCCOH RELCOV.
    rewrite covered_in_coverable  at 1.
      by apply c_acq_coverable.
  Qed.

  Lemma dom_c_cur_coverable i l A:
    dom_rel (c_cur i l A ⨾ ⦗ coverable T ⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH RELCOV.
    unfold CombRelations.c_cur.
    generalize (@dom_urr_coverable l).
    basic_solver 21.
  Qed.

  Lemma c_cur_coverable i l A:
    c_cur i l A ⨾ ⦗ coverable T ⦘ ⊆ ⦗issued T⦘ ⨾ c_cur i l A.
  Proof using WF IMMCON TCCOH RELCOV.
    seq_rewrite (dom_rel_helper (@dom_c_cur_coverable i l A)).
    basic_solver.
  Qed.

  Lemma c_cur_covered i l A:
    c_cur i l A ⨾ ⦗ covered T ⦘ ⊆ ⦗issued T⦘ ⨾ c_cur i l A.
  Proof using WF IMMCON TCCOH RELCOV.
    rewrite covered_in_coverable at 1.
      by apply c_cur_coverable.
  Qed.

  Lemma dom_c_rel_coverable i l l' A:
    dom_rel (c_rel i l l' A ⨾ ⦗ coverable T ⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH RELCOV.
    unfold CombRelations.c_rel.
    generalize (@dom_urr_coverable l).
    basic_solver 21.
  Qed.

  Lemma c_rel_coverable i l l' A:
    c_rel i l l' A ⨾ ⦗ coverable T ⦘ ⊆ ⦗issued T⦘ ⨾ c_rel i l l' A.
  Proof using WF IMMCON TCCOH RELCOV.
    seq_rewrite (dom_rel_helper (@dom_c_rel_coverable i l l' A)).
    basic_solver.
  Qed.

  Lemma c_rel_covered i l l' A:
    c_rel i l l' A ⨾ ⦗ covered T ⦘ ⊆ ⦗issued T⦘ ⨾ c_rel i l l' A.
  Proof using WF IMMCON TCCOH RELCOV.
    rewrite covered_in_coverable at 1.
      by apply c_rel_coverable.
  Qed.

  Lemma t_acq_coverable l thread:
    t_acq thread l (coverable T) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH RELCOV.
    unfold CombRelations.t_acq.
    rewrite (dom_r (wf_c_acqD G sc thread l (coverable T))).
    arewrite (⦗(Tid_ thread ∪₁ Init) ∩₁ coverable T⦘ ⊆ ⦗coverable T⦘) by basic_solver.
    rewrite c_acq_coverable.
    basic_solver.
  Qed.

  Lemma t_acq_covered l thread:
    t_acq thread l (covered T) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH RELCOV.
    rewrite covered_in_coverable at 1.
      by apply t_acq_coverable.
  Qed.

  Lemma t_cur_coverable l thread:
    t_cur thread l (coverable T) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH RELCOV.
    etransitivity; [by apply t_cur_in_t_acq|].
      by apply t_acq_coverable.
  Qed.

  Lemma t_cur_covered l thread:
    t_cur thread l (covered T) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH RELCOV.
    rewrite covered_in_coverable at 1.
      by apply t_cur_coverable.
  Qed.

  Lemma t_rel_coverable l l' thread:
    t_rel thread l l' (coverable T) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH RELCOV.
    etransitivity; [by apply t_rel_in_t_cur|].
      by apply t_cur_coverable.
  Qed.

  Lemma t_rel_covered l l' thread:
    t_rel thread l l' (covered T) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH RELCOV.
    rewrite covered_in_coverable at 1.
      by apply t_rel_coverable.
  Qed.

  Lemma S_tm_coverable l :
    S_tm l (coverable T) ⊆₁ issued T.
  Proof using WF TCCOH RELCOV IMMCON.
    unfold CombRelations.S_tm, CombRelations.S_tmr.
    generalize dom_hb_coverable.
    generalize w_coverable_issued.
    generalize covered_in_coverable.
    generalize dom_release_issued.
    generalize dom_rf_coverable.
    basic_solver 21.
  Qed.

  Lemma S_tm_covered l:
    S_tm l (covered T) ⊆₁ issued T.
  Proof using WF TCCOH RELCOV IMMCON.
    rewrite covered_in_coverable at 1.
      by apply S_tm_coverable.
  Qed.

  Lemma msg_rel_issued l:
    dom_rel (msg_rel l ⨾ ⦗ issued T ⦘) ⊆₁ issued T.
  Proof using WF IMMCON TCCOH RELCOV.
    unfold CombRelations.msg_rel.
    generalize dom_release_issued.
    generalize (@dom_urr_coverable l).
    generalize covered_in_coverable.
    basic_solver 21.
  Qed.

Lemma exists_ncov thread (FINDOM : set_finite E) :
  exists n, ~ covered T (ThreadEvent thread n).
Proof using TCCOH.
  destruct (exists_nE G FINDOM thread) as [n HH].
  exists n. intros CC. apply HH.
  eapply coveredE; eauto.
Qed.

Section HbProps.

Notation "'C'" := (covered T).
Notation "'I'" := (issued  T).

Lemma sw_in_Csw_sb :
  sw ⨾ ⦗C ∪₁ dom_rel (sb^? ⨾ ⦗ I ⦘)⦘ ⊆ ⦗ C ⦘ ⨾ sw ∪ sb.
Proof using WF TCCOH RELCOV IMMCON.
  rewrite !id_union. rewrite seq_union_r.
  unionL.
  { rewrite sw_covered; eauto. basic_solver. }
  assert (forall (s : actid -> Prop), s ∪₁ set_compl s ≡₁ fun _ => True) as AA.
  { split; [basic_solver|].
    unfolder. ins. apply classic. }
  arewrite (sw ⊆ ⦗ C ∪₁ set_compl C ⦘ ⨾ sw) at 1.
  { rewrite AA. by rewrite seq_id_l. }
  rewrite id_union, !seq_union_l.
  apply union_mori; [basic_solver|].
  rewrite (dom_r (wf_swD WF)).
  rewrite sw_in_ar0; auto.
  remember (⦗Rel⦘ ⨾ (⦗F⦘ ⨾ sb)^? ⨾ ⦗W⦘ ⨾ (sb ∩ same_loc)^? ⨾ ⦗W⦘ ⨾ (rfe ∪ ar_int G)⁺) as ax.
  rewrite !seq_union_l, !seq_union_r.
  unionL; [|basic_solver].
  subst ax. rewrite !seqA.
  arewrite ((sb ∩ same_loc)^? ⨾ ⦗W⦘ ⊆ (sb ∩ same_loc)^? ⨾ ⦗W⦘ ⨾ ⦗W⦘) by basic_solver.
  arewrite (⦗Rel⦘ ⨾ (⦗F⦘ ⨾ sb)^? ⨾ ⦗W⦘ ⨾ (sb ∩ same_loc)^? ⨾ ⦗W⦘ ⊆ release).
  { unfold imm_s_hb.release, imm_s_hb.rs. by rewrite <- inclusion_id_rt, seq_id_r. }
  enough (dom_rel (⦗W⦘ ⨾ (rfe ∪ ar_int G)⁺ ⨾ ⦗FR ∩₁ Acq⦘ ⨾ ⦗dom_rel (sb^? ⨾ ⦗I⦘)⦘) ⊆₁ I) as BB.
  { rewrite (dom_rel_helper BB).
    seq_rewrite (dom_rel_helper dom_release_issued).
    basic_solver. }
  rewrite <- !seqA. rewrite dom_rel_eqv_dom_rel. rewrite !seqA.
  arewrite (⦗FR ∩₁ Acq⦘ ⨾ sb^? ⊆ (rfe ∪ ar_int G)^?).
  { rewrite !crE, !seq_union_r. apply union_mori; [basic_solver|].
    unionR right. rewrite set_inter_union_l, id_union, seq_union_l.
    rewrite sb_from_r_acq_in_bob.
    arewrite (Acq ⊆₁ Acq/Rel) by mode_solver.
    rewrite sb_from_f_in_bob. rewrite bob_in_ar_int. eauto with hahn. }
  seq_rewrite ct_cr.
  arewrite (rfe ∪ ar_int G ⊆ ar). by apply ar_ct_I_in_I.
Qed.

Lemma hb_in_Chb_sb :
  hb ⨾ ⦗C ∪₁ dom_rel (sb^? ⨾ ⦗ I ⦘)⦘ ⊆ ⦗ C ⦘ ⨾ hb ∪ sb.
Proof using WF TCCOH RELCOV IMMCON.
  unfold imm_s_hb.hb.
  intros x y HH.
  destruct_seq_r HH as DOM.
  apply clos_trans_tn1 in HH.
  induction HH as [y [HH|HH]|y z AA].
  { by right. }
  { assert ((⦗C⦘ ⨾ sw ∪ sb) x y) as [ZZ|ZZ].
    3: by right.
    2: { destruct_seq_l ZZ as CX.
         left. apply seq_eqv_l. split; auto.
         apply ct_step. by right. }
    apply sw_in_Csw_sb; auto. apply seq_eqv_r. splits; auto. }
  assert (sb y z -> (C ∪₁ dom_rel (sb^? ⨾ ⦗I⦘)) y) as DOMY.
  { intros SB.
    destruct DOM as [DOM|DOM].
    2: { right. generalize (@sb_trans G) SB DOM. basic_solver 10. }
    left.
    eapply dom_sb_covered; eauto. eexists.
    apply seq_eqv_r. split; eauto. }

  assert ((C ∪₁ dom_rel (sb^? ⨾ ⦗I⦘)) y) as BB.
  2: { set (CC:=BB). apply IHHH in CC.
       destruct CC as [CC|CC].
       { left.
         destruct_seq_l CC as XX.
         apply seq_eqv_l. split; auto.
         (* TODO: is the last tactic needed? *)
         apply ct_ct. exists y. split; eauto; try by apply ct_step. }
       destruct AA as [AA|AA].
       { right. eapply (@sb_trans G); eauto. }
       assert ((sw ⨾ ⦗C ∪₁ dom_rel (sb^? ⨾ ⦗I⦘)⦘) y z) as DD.
       { apply seq_eqv_r. by split. }
       eapply sw_in_Csw_sb in DD; auto.
       destruct DD as [DD|DD].
       2: { right. eapply (@sb_trans G); eauto. }
       left.
       apply seq_eqv_l. split.
       2: { apply ct_ct. eexists.
            split; apply ct_step; [left|right]; eauto. }
       assert (C y) as CY.
       { by destruct_seq_l DD as XX. }
       eapply dom_sb_covered; eauto. eexists.
       apply seq_eqv_r. split; eauto. }
  destruct AA as [|AA]; [by intuition|].
  assert ((sw ⨾ ⦗C ∪₁ dom_rel (sb^? ⨾ ⦗I⦘)⦘) y z) as DD.
  { apply seq_eqv_r. by split. }
  eapply sw_in_Csw_sb in DD; auto.
  destruct DD as [DD|]; [|by intuition].
  left. by destruct_seq_l DD as CY.
Qed.
End HbProps.
End Properties.

End TraversalConfig.


Require Import Utf8.
Require Events.
Import String.
Import Coqlib.
Import AST Events.
Import Integers Values.

Unset Elimination Schemes.

Definition slot : Type := (ident * int)%type.

Definition slot_dec (x y: slot) : { x = y } + { x ≠ y } :=
  EquivDec.prod_eqdec Pos.eq_dec Int.eq_dec x y.

Definition fence_ident : string := "__circgen_fence"%string.

Definition fence_sig : signature :=
  {| sig_args := nil ; sig_res := None ; sig_cc := cc_default |}.

(* This axiom states that calling the “void fence(void)” external function
preserves the memory and does not emit any visible event.

This function is used to delimit the circuit from the input and output sequences. *)
Axiom fence_sem :
  ∀ ge m tr v m',
    external_functions_sem fence_ident fence_sig ge nil m tr v m' →
    tr = E0 ∧ m' = m.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University
  Copyright 2018 Luxembourg University

  This file is part of Velisarios.

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

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

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

  Authors: Vincent Rahli
           Ivana Vukotic

 *)

Require Export PBFTlearns_or_knows_pl.

Section PBFTlearns_or_knows_pl_nv.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { pbft_context : PBFTcontext      }.
  Context { pbft_auth    : PBFTauth         }.
  Context { pbft_keys    : PBFTinitial_keys }.
  Context { pbft_hash    : PBFThash         }.

  Definition pbft_pl_nv_knows (d : pbft_pl_data) (s : PBFTstate) : Prop :=
    exists nv pi,
      new_view_in_log nv (view_change_state s)
      /\ In pi (mergeP (new_view2cert nv))
      /\ prepare_like_in_prepared_info d pi.

  Definition pbft_pl_nv_knows_i (i : pbft_pl_info) (s : PBFTstate) : Prop :=
    exists (d : pbft_pl_data), pbft_pl_nv_knows d s /\ i = prepare_like2request_data d.

  Lemma pbft_pl_nv_knows_i_if :
    forall d m, pbft_pl_nv_knows d m -> pbft_pl_nv_knows_i (prepare_like2request_data d) m.
  Proof.
    introv kn.
    exists d; tcsp.
  Qed.

  Lemma pbft_pl_nv_no_initial_memory_i :
    forall n d, ~ pbft_pl_nv_knows_i d (Process.sm_state (PBFTreplicaSM n)).
  Proof.
    introv h; simpl in h.
    unfold pbft_pl_nv_knows_i, pbft_pl_nv_knows in h; exrepnd; simpl in *; auto.
  Qed.

  Definition pbft_pl_nv_output2data (m : DirectedMsg) : list pbft_pl_data := [].

  Global Instance PBFT_I_SysOutput : SysOutput.
  Proof.
    exact (MkSysOutput DirectedMsg).
  Defined.

  Instance PBFT_I_LearnAndKnow_pl_nv : LearnAndKnow 1.
  Proof.
    exact (MkLearnAndKnow
             1
             pbft_pl_data
             pbft_pl_info
             prepare_like2request_data
             PBFTstate
             pbft_pl_nv_knows
             pbft_pl_nv_knows_i
             pbft_pl_nv_knows_i_if
             pbft_pl_data2loc
             pbft_pl_data2main_auth_data
             pbft_pl_data2main_auth_data_list
             pbft_pl_verify
             _ pbft_pl_nv_no_initial_memory_i).
  Defined.

  Definition knows_certificate1
             {eo : EventOrdering}
             (e : Event)
             (n : nat)
             (i : @lak_info PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv)
             (P : list (@lak_data PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv) -> Prop):=
    @knows_certificate PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv eo e n i P.

  Definition pbft_knows_rd1 {eo : EventOrdering} (e : Event) (rd : RequestData) :=
    knows_certificate1 e (2 * F + 1) rd one_pre_prepare.

  Definition knows1
             {eo : EventOrdering}
             (e : Event)
             (d : @lak_data PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv) :=
    @knows PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv eo e d.

  Definition knew1
             {eo : EventOrdering}
             (e : Event)
             (d : @lak_data PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv) :=
    @knew PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv eo e d.

  Definition learns1
             {eo : EventOrdering}
             (e : Event)
             (d : @lak_data PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv) :=
    @learns PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok PBFT_I_ContainedAuthData DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv eo e d.

  Definition learned1
             {eo : EventOrdering}
             (e : Event)
             (d : @lak_data PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv) :=
    @learned PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok PBFT_I_ContainedAuthData DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv eo e d.

  Lemma prepared_as_pbft_knows_rd :
    forall (eo : EventOrdering) (e : Event) pi i s nv,
      loc e = PBFTreplica i
      -> state_sm_on_event (PBFTreplicaSM i) e = Some s
      -> well_formed_log (log s)
      -> info_is_prepared pi = true
      -> new_view_in_log nv (view_change_state s)
      -> In pi (mergeP (new_view2cert nv))
      -> pbft_knows_rd1 e (prepared_info2request_data pi).
  Proof.
    introv eqloc eqst wf prep nvinlog piin.
    unfold info_is_prepared in *; smash_pbft.

    allrw @norepeatsb_as_no_repeats.
    allrw forallb_forall.

    exists ((prepare_like_pre_prepare (prepared_info_pre_prepare pi))
              :: map prepare_like_prepare (prepared_info_prepares pi)).

    simpl; autorewrite with pbft list; dands; auto;
      try (complete (rewrite <- length_prepared_info2senders_eq_length_prepared_info_prepares; omega)).

    - constructor; auto.
      introv xx.
      apply prep1 in xx.
      smash_pbft.

    - unfold one_pre_prepare; simpl.
      f_equal.
      apply length_zero_iff_nil.
      match goal with
      | [ |- ?x = _ ] => remember x as l; destruct l; auto
      end.
      assert False; tcsp.
      pose proof (filter_In is_pre_prepare_like p (map prepare_like_prepare (prepared_info_prepares pi))) as q.
      destruct q as [q q']; clear q'.
      rewrite <- Heql in q; simpl in q; autodimp q hyp.
      repnd.
      apply in_map_iff in q0; exrepnd; subst.
      destruct x; simpl in *; ginv.

    - introv h; repndors; subst; tcsp; dands.

      + exists s i; dands; auto; exists nv pi; dands; auto.
        destruct pi; simpl; auto.

      + destruct pi, prepared_info_pre_prepare, b; simpl.
        unfold prepared_info2request_data, pre_prepare2digest; simpl.
        f_equal.
        unfold prepared_info_has_correct_digest, prepared_info2requests in *; simpl in *; smash_pbft.

      + allrw in_map_iff; exrepnd; subst; auto.
        exists s i; dands; auto; exists nv pi; dands; auto.

      + allrw in_map_iff; exrepnd; subst; auto.
        destruct pi, prepared_info_pre_prepare, b; simpl.
        unfold PBFTheader.prepared_info_prepares in *.
        unfold prepared_info2request_data, pre_prepare2digest in *; simpl.
        apply prep0 in h0.
        simpl in h0; smash_pbft.
  Qed.

  Definition knows_in_intersection1
             {eo : EventOrdering}
             (e1 e2 : Event)
             (n : nat)
             (i1 i2 : @lak_info PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv)
             P E N :=
    @knows_in_intersection PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok PBFT_I_ContainedAuthData DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv eo e1 e2 n i1 i2 P E N.

  Definition local_knows_in_intersection1
             {eo : EventOrdering}
             (e : Event)
             (n : nat)
             (i1 i2 : @lak_info PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv)
             P E N :=
    @local_knows_in_intersection PBFT_I_Data PBFT_I_Node PBFT_I_Key PBFT_I_Msg PBFT_I_Quorum PBFT_I_AuthTok DTimeContextQ PBFT_I_IOTrustedFun PBFT_I_SysOutput 1 PBFT_I_LearnAndKnow_pl_nv eo e n i1 i2 P E N.

End PBFTlearns_or_knows_pl_nv.


From App Require Export
     Solver.

Notation swap_stE :=
  (stE (swap_request id) (swap_response id) (swap_state exp)).

CoFixpoint match_event {q r s T} (e0 : observeE q r s T) (v : T)
           (m : itree (stE q r s) void) : itree (stE q r s) void :=
  match observe m with
  | RetF vd => match vd in void with end
  | TauF m' => Tau (match_event e0 v m')
  | VisF e k =>
    match e with
    | (||oe) =>
      match oe in observeE _ _ _ Y, e0 in observeE _ _ _ Z
            return (Y -> _) -> Z -> _ with
      | Observe__FromServer, Observe__FromServer
      | Observe__ToServer _, Observe__ToServer _ => id
      | _, _ => fun _ _ => throw "Unexpected event"
      end k v
    | _ => vis e (match_event e0 v ∘ k)
    end
  end.

Definition match_observe {q r s T} (e : observeE q r s T) (v : T)
  : list (itree (stE q r s) void) -> list (itree (stE q r s) void) :=
  map (match_event e v).

CoFixpoint tester' (others : list (itree swap_stE void))
           (m : itree swap_stE void) : itree tE void :=
  match observe m with
  | RetF vd => match vd in void with end
  | TauF m' => Tau (tester' others m')
  | VisF e k =>
    let catch (err : string) : itree tE void :=
        embed Log err;;
        if others is other::others'
        then Tau (tester' others' other)
        else throw err in
    match e with
    | (Throw err|) => catch err
    | (|de|) =>
      match de in decideE Y return (Y -> _) -> _ with
      | Decide => fun k => b <- trigger Or;;
                       Tau (tester' (k (negb b)::others) (k b))
      end k
    | (||oe) =>
      match oe in observeE _ _ _ Y return (Y -> _) -> _ with
      | Observe__ToServer st =>
        fun k =>
          op1 <- trigger Client__Recv;;
          if op1 is Some p1
          then if match_observe Observe__FromServer p1 others is other::others'
               then Tau (tester' others' other)
               else catch "Unexpected receive from server"
          else op <- embed Client__Send st;;
               if op is Some p
               then Tau (tester' (match_observe (Observe__ToServer st) p others)
                                 (k p))
               else if others is other::others'
                    then Tau (tester' (others' ++ [m]) other)
                    else Tau (tester' [] m)
      | Observe__FromServer =>
        fun k =>
          op <- trigger Client__Recv;;
          if op is Some p
          then Tau (tester' (match_observe Observe__FromServer p others) (k p))
          else if others is other::others'
               then Tau (tester' (others' ++ [m]) other)
               else Tau (tester' [] m)
      end k
    end
  end.

Definition tester : itree swap_stE void -> itree tE void := tester' [].

Definition swap_tester : swap_state exp -> itree tE void := tester ∘ solve_swap.


Require Import RelationClasses.
Require Import Coq.Logic.PropExtensionality.

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

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

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

Require Import PFConsistent.
Require Import Certify.

Require Import FutureCertify.
Require Import SrcToIRThread.

Set Implicit Arguments.

Module SrcToIR.
  Variant sim_thread_sl (gl_src gl_ir: Global.t):
    forall (sl_src sl_ir: {lang: language & Language.state lang} * Local.t), Prop :=
    | sim_thread_sl_intro
        lang
        st_src lc_src
        st_ir lc_ir
        (THREAD: SrcToIRThread.sim_thread (Thread.mk _ st_src lc_src gl_src) (Thread.mk _ st_ir lc_ir gl_ir))
        (CONS: exists gl_past,
            (<<FUTURE: Global.future gl_past gl_ir>>) /\
            (<<LC_WF: Local.wf lc_ir gl_past>>) /\
            (<<GL_WF: Global.wf gl_past>>) /\
            (<<CONS: PFConsistent.spf_consistent (Thread.mk _ st_ir lc_ir gl_past)>>))
      :
      sim_thread_sl gl_src gl_ir (existT _ lang st_src, lc_src) (existT _ lang st_ir, lc_ir)
  .

  Lemma sim_thread_sl_future
        gl_src gl_ir lang_src st_src lc_src lang_ir st_ir lc_ir
        gl_future_src gl_future_ir
        (GL_FUTURE_IR: Global.future gl_ir gl_future_ir)
        (SC: Global.sc gl_future_src = Global.sc gl_future_ir)
        (GPROMISES: Global.promises gl_future_src = BoolMap.bot)
        (MEMORY: SrcToIRThread.sim_memory (Global.memory gl_future_src) (Global.memory gl_future_ir))
        (SIM: sim_thread_sl gl_src gl_ir
                            (existT _ lang_src st_src, lc_src)
                            (existT _ lang_ir st_ir, lc_ir)):
    sim_thread_sl gl_future_src gl_future_ir
                  (existT _ lang_src st_src, lc_src)
                  (existT _ lang_ir st_ir, lc_ir).
  Proof.
    inv SIM. Configuration.simplify. econs.
    - inv THREAD. ss.
    - des. exists gl_past.
      splits; ss; try by (etrans; eauto).
  Qed.

  Variant sim_conf: forall (c_src c_ir: Configuration.t), Prop :=
    | sim_conf_intro
        ths_src gl_src
        ths_ir gl_ir
        (THS: forall tid,
            option_rel
              (sim_thread_sl gl_src gl_ir)
              (IdentMap.find tid ths_src)
              (IdentMap.find tid ths_ir)):
      sim_conf (Configuration.mk ths_src gl_src) (Configuration.mk ths_ir gl_ir)
  .

  Lemma init_sim_conf prog: sim_conf (Configuration.init prog) (Configuration.init prog).
  Proof.
    econs. i.
    unfold Threads.init. rewrite IdentMap.Facts.map_o.
    destruct (@UsualFMapPositive.UsualPositiveMap'.find
                (@sigT _ (@Language.syntax ProgramEvent.t)) tid prog); ss.
    econs; ss.
    - econs; ss. apply SrcToIRThread.init_sim_memory.
    - exists Global.init. splits.
      + refl.
      + apply Local.init_wf.
      + apply Global.init_wf.
      + econs 2; s; try refl.
  Qed.

  Lemma sim_conf_terminal
        c1_src c1_ir
        (SIM: sim_conf c1_src c1_ir)
        (TERMINAL: Configuration.is_terminal c1_ir):
    Configuration.is_terminal c1_src.
  Proof.
    inv SIM. ii. ss.
    specialize (THS tid). rewrite FIND in THS.
    destruct (IdentMap.find tid ths_ir) as [[[lang_ir st_ir] lc_ir]|] eqn:FIND_IR; ss.
    inv THS. Configuration.simplify.
    inv THREAD. ss. subst. splits; ss.
    exploit TERMINAL; eauto. i. des. ss.
  Qed.

  Lemma is_racy_promise_is_racy
        lang e (th1 th2: Thread.t lang)
        (STEP: Thread.step e th1 th2)
        (EVENT: ThreadEvent.is_racy_promise e):
    exists loc,
      (<<LOC: ThreadEvent.is_accessing_loc loc e>>) /\
      (<<GET: Global.promises (Thread.global th1) loc = true>>) /\
      (<<GETP: Local.promises (Thread.local th1) loc = false>>).
  Proof.
    inv STEP; inv LOCAL; ss.
    - inv LOCAL0. inv RACE; ss. eauto.
    - inv LOCAL0. inv RACE; ss. eauto.
    - inv LOCAL0; des.
      + destruct ordr; ss.
      + destruct ordw; ss.
      + inv RACE; ss. eauto.
  Qed.

  Lemma disjoint_minus_le_r
        bm1 bm2 gbm
        (LE1: BoolMap.le bm1 gbm)
        (LE2: BoolMap.le bm2 gbm)
        (DISJOINT: BoolMap.disjoint bm1 bm2):
    BoolMap.le bm2 (BoolMap.minus gbm bm1).
  Proof.
    ii. exploit LE2; eauto. i.
    unfold BoolMap.minus. rewrite x0. s.
    destruct (bm1 loc) eqn:GET1; ss.
    exploit DISJOINT; eauto.
  Qed.

  Lemma sim_conf_step
        c1_src c1_ir
        e tid c2_ir
        (SIM: sim_conf c1_src c1_ir)
        (WF1_SRC: Configuration.wf c1_src)
        (WF1_IR: Configuration.wf c1_ir)
        (STEP: Configuration.step e tid c1_ir c2_ir):
    (exists c_src tid' c2_src,
        (<<STEPS_SRC: rtc (PFConfiguration.tau_step ThreadEvent.get_machine_event_pf)
                         c1_src c_src>>) /\
        (<<STEP_SRC: PFConfiguration.step ThreadEvent.get_machine_event_pf
                                         MachineEvent.failure tid' c_src c2_src>>)) \/
    (exists c_src c2_src,
        (<<STEPS_SRC: rtc (PFConfiguration.tau_step ThreadEvent.get_machine_event_pf)
                         c1_src c_src>>) /\
        (<<STEP_SRC: PFConfiguration.opt_step ThreadEvent.get_machine_event_pf
                                             e tid c_src c2_src>>) /\
        ((<<SIM2: sim_conf c2_src c2_ir>>) \/
         exists c3_src tid' c4_src,
           (<<STEPS2_SRC: rtc (PFConfiguration.tau_step ThreadEvent.get_machine_event_pf)
                             c2_src c3_src>>) /\
           (<<STEP2_SRC: PFConfiguration.step ThreadEvent.get_machine_event_pf
                                             MachineEvent.failure tid' c3_src c4_src>>))).
  Proof.
    destruct c1_src as [ths1_src gl1_src], c1_ir as [ths1_ir gl1_ir].
    inv STEP. dup SIM. inv SIM0. ss.
    rename st1 into st1_ir, lc1 into lc1_ir.
    specialize (THS tid). rewrite TID in *.
    destruct (IdentMap.find tid ths1_src) as [[[lang_src st1_src] lc1_src]|] eqn:FIND_SRC; ss.
    inv THS. Configuration.simplify. clear CONS.

    exploit SrcToIRThread.plus_step_cases; try exact STEPS; eauto. i. des; cycle 1.
    { (* race with a promise *)
      left. clear e0 th2 st3 lc3 gl3 STEPS STEP0 CONSISTENT.
      exploit SrcToIRThread.sim_thread_rtc_step; try exact STEPS0; eauto. i. des.
      exploit is_racy_promise_is_racy; try exact STEP_RACE; ss. i. des.
      exploit Thread.rtc_tau_step_promises_minus;
        try eapply rtc_implies; try exact STEPS0; s.
      { i. inv H. des. econs; eauto. }
      unfold BoolMap.minus. i.
      eapply equal_f in x0.
      rewrite GET, GETP in x0. ss.
      destruct (Global.promises gl1_ir loc) eqn:GPROMISED; ss.
      destruct (Local.promises lc1_ir loc) eqn:PROMISED; ss.
      dup WF1_IR. inv WF1_IR0. inv WF. ss.
      exploit (PROMISES loc); ss.
      clear DISJOINT THREADS PROMISES. i. des.
      destruct (classic (tid = tid0)).
      { subst. rewrite TID in *. Configuration.simplify. congr. }
      dup SIM. inv SIM0. specialize (THS tid0). rewrite TH in *.
      destruct (IdentMap.find tid0 ths1_src) as [[[lang0_src st0_src] lc0_src]|] eqn:FIND0_SRC; ss.
      inv THS. Configuration.simplify. des.
      exploit spf_consistent_certify; try exact CONS; eauto. s. intro CERTIFY.

      dup WF1_IR. inv WF1_IR0. inv WF. ss.
      exploit DISJOINT; try exact H; eauto. i.
      exploit THREADS; try exact TID. i.
      exploit THREADS; try exact TH. i.
      clear DISJOINT THREADS PROMISES.
      dup WF1_SRC. inv WF1_SRC0. inv WF. ss.
      exploit DISJOINT; try exact H; eauto. i.
      exploit THREADS; try exact FIND_SRC. i.
      exploit THREADS; try exact FIND0_SRC. i.
      clear DISJOINT THREADS PROMISES.
      exploit Thread.rtc_tau_step_future; try eapply rtc_implies; try exact STEPS0; ss.
      { i. inv H0. des. econs; eauto. }
      i. des.
      exploit Thread.rtc_tau_step_future; try eapply rtc_implies; try exact STEPS_SRC; ss.
      { i. inv H0. des. econs; eauto. }
      i. des.
      exploit Thread.rtc_tau_step_disjoint; try eapply rtc_implies; try exact STEPS0; eauto.
      { i. inv H0. des. econs; eauto. }
      i. des.
      exploit Thread.rtc_tau_step_disjoint; try eapply rtc_implies; try exact STEPS_SRC; eauto.
      { i. inv H0. des. econs; eauto. }
      i. des.
      exploit (@FutureCertify.future_certify lang0 (Thread.mk _ st0_src lc0_src (Thread.global th2_src)));
        try exact CERTIFY; ss; (try by inv THREAD0; ss); (try by inv SIM2; ss); try apply SIM2.
      { eapply Memory.future_messages_le. etrans; try apply FUTURE. apply GL_FUTURE. }
      { apply LC_WF1. }
      intro CERTIFY_SRC.
      exploit (@PFConfiguration.rtc_program_step_rtc_step (Configuration.mk ths1_src gl1_src));
        try eapply STEPS_SRC; eauto. s. i. des; eauto.

      inv CERTIFY_SRC.
      - exploit (@PFConfiguration.plus_program_step_plus_step
                   (Configuration.mk
                      (IdentMap.add tid (existT _ lang (Thread.state th2_src), Thread.local th2_src) ths1_src)
                      (Thread.global th2_src))); s.
        { erewrite IdentMap.gso; try eapply FIND0_SRC. auto. }
        { eapply rtc_implies; try exact STEPS1.
          i. inv H0. des. econs; eauto.
          inv EVENT. inv EVENT0. destruct e1; ss.
        }
        { eassumption. }
        { destruct e0; ss. }
        i. des; try by destruct e0; ss.
        esplits; try exact STEP. etrans; eauto.
      - destruct th2_src as [st2_src lc2_src gl2_src]. ss.
        assert (RACE: exists e th3_src,
                     Thread.step e
                                 (Thread.mk _ st2_src lc2_src (Thread.global th2)) th3_src /\
                     ThreadEvent.is_racy e /\
                     ~ ThreadEvent.is_racy_promise e).
        { exploit Thread.rtc_all_step_future; try eapply rtc_implies; try exact STEPS1; ss.
          { i. inv H0. econs; eauto. }
          i. des.
          inv STEP_FULFILL; inv LOCAL. inv LOCAL0. ss.
          exploit Memory.add_get0; try exact WRITE. i. des.
          inv SIM2. ss. subst.
          inv STEP_RACE; inv LOCAL; ss; subst.
          - esplits.
            + econs 2; cycle 1.
              * econs 8. econs. econs 2; try apply GET2; ss.
                eapply TimeFacts.le_lt_lt; try exact TO.
                inv LC_WF0. inv TVIEW_CLOSED. inv CUR.
                exploit Memory.future_closed_timemap; try exact PLN; try apply GL_FUTURE1. i. des.
                eapply Memory.max_ts_spec. eauto.
              * ss. eauto.
            + ss.
            + ss.
          - esplits.
            + econs 2; cycle 1.
              * econs 9. econs. econs 2; try apply GET2; ss.
                eapply TimeFacts.le_lt_lt; try exact TO.
                inv LC_WF0. inv TVIEW_CLOSED. inv CUR.
                exploit Memory.future_closed_timemap; try exact PLN; try apply GL_FUTURE1. i. des.
                eapply Memory.max_ts_spec. eauto.
              * ss. eauto.
            + ss.
            + ss.
          - esplits.
            + econs 2; cycle 1.
              * econs 10. econs 3. econs 2; try apply GET2; ss.
                eapply TimeFacts.le_lt_lt; try exact TO.
                inv LC_WF0. inv TVIEW_CLOSED. inv CUR.
                exploit Memory.future_closed_timemap; try exact PLN; try apply GL_FUTURE1. i. des.
                eapply Memory.max_ts_spec. eauto.
              * ss. eauto.
            + ss.
            + ss.
        }
        des. destruct th3_src.
        exploit (@PFConfiguration.plus_program_step_plus_step
                   (Configuration.mk
                      (IdentMap.add tid (existT _ lang st2_src, lc2_src) ths1_src) gl2_src)); s.
        { erewrite IdentMap.gso; try eapply FIND0_SRC. auto. }
        { eapply rtc_implies; try exact STEPS1.
          i. inv H0. des. econs; eauto.
          inv EVENT. inv EVENT0. destruct e1; ss.
        }
        { eassumption. }
        { ss. }
        s. i. des; cycle 1.
        { esplits; try exact STEP. etrans; eauto. }
        esplits.
        + etrans; [eauto|]. eapply rtc_n1; [eauto|]. econs. exact STEP.
        + replace MachineEvent.failure with (ThreadEvent.get_machine_event_pf e0); cycle 1.
          { destruct e0; ss. }
          econs. econs; s.
          * rewrite IdentMap.gso; try by apply IdentMap.gss. ss.
          * eassumption.
          * destruct e0; ss.
    }

    exploit SrcToIRThread.sim_thread_rtc_step; try exact STEPS0; eauto. i. des.
    exploit SrcToIRThread.sim_thread_step; try exact STEP0; eauto. i. des.
    exploit (@PFConfiguration.opt_plus_program_step_opt_plus_step (Configuration.mk ths1_src gl1_src));
      try exact STEPS_SRC; eauto. s. i. des; try by left; eauto.
    right.
    assert (ThreadEvent.get_machine_event e0 = ThreadEvent.get_machine_event_pf e_src).
    { unguard. des; subst; ss; destruct e0; ss. }
    rewrite H.
    esplits; try exact STEPS1; eauto.
    exploit CONSISTENT; try by (destruct e0; ss; congr). i.
    dup WF1_IR. inv WF1_IR0. inv WF. ss.
    exploit THREADS; try exact TID. intro LC_WF.
    clear DISJOINT THREADS PROMISES.
    exploit Thread.rtc_tau_step_future; try exact STEPS; eauto. s. i. des.
    exploit Thread.step_future; try exact STEP0; eauto. s. i. des.
    exploit PFConsistent.consistent_pf_consistent; try exact x0; eauto. i.
    exploit PFConsistent.pf_consistent_spf_consistent; try exact x1. i. des.
    { (* certification with no race *)
      left. clear x0 x1.
      destruct th2_src, th2_src0. ss.
      econs. i.
      destruct (classic (tid = tid0)).
      - subst. repeat rewrite IdentMap.gss. s. econs; ss.
        esplits; try exact SPF_CONS; ss; try refl.
      - repeat (rewrite IdentMap.gso; auto).
        dup SIM. inv SIM1. specialize (THS tid0).
        destruct (IdentMap.find tid0 ths1_src) as [[[lang0_src st0_src] lc0_src]|] eqn:FIND0_SRC;
          destruct (IdentMap.find tid0 ths1_ir) as [[[lang0_ir st0_ir] lc0_ir]|] eqn:FIND0_IR; ss.
        eapply sim_thread_sl_future; try exact THS; try apply SIM0; try by (etrans; eauto).
    }

    (* race with a promise during certification *)
    right. clear H c2 STEPS1 STEP EVENT0 x0 x1.
    inv SPF_RACE. ss.
    exploit SrcToIRThread.sim_thread_cap; try exact SIM0. i.
    exploit SrcToIRThread.sim_thread_rtc_step; try eapply rtc_implies; try exact STEPS1; eauto.
    { i. inv H. des. inv EVENT0. inv EVENT2. econs; eauto. }
    i. des.
    exploit is_racy_promise_is_racy; try exact STEP_RACE; ss. i. des.
    exploit Thread.rtc_all_step_promises_minus; try eapply rtc_implies; try exact STEPS1.
    { i. inv H. des. econs; eauto. }
    exploit Thread.rtc_all_step_promises_minus.
    { eapply rtc_n1.
      - eapply rtc_implies; try exact STEPS. i. inv H. econs; eauto.
      - econs. exact STEP0.
    }
    unfold BoolMap.minus. s. i.
    rewrite x2 in x1. clear x2.
    eapply equal_f in x1.
    rewrite GET, GETP in x1. ss.
    destruct (Global.promises gl1_ir loc) eqn:GPROMISED; ss.
    destruct (Local.promises lc1_ir loc) eqn:PROMISED; ss.
    clear x1.
    dup WF1_IR. inv WF1_IR0. inv WF. ss.
    exploit (PROMISES loc); ss.
    clear GL_WF DISJOINT THREADS PROMISES. i. des.
    destruct (classic (tid = tid0)).
    { subst. rewrite TID in *. Configuration.simplify. congr. }
    dup SIM. inv SIM3. specialize (THS tid0). rewrite TH in *.
    destruct (IdentMap.find tid0 ths1_src) as [[[lang0_src st0_src] lc0_src]|] eqn:FIND0_SRC; ss.
    inv THS. Configuration.simplify. des.
    exploit spf_consistent_certify; try exact CONS; eauto. intro CERTIFY.

    dup WF1_IR. inv WF1_IR0. inv WF. ss.
    exploit DISJOINT; try exact H; eauto. i.
    exploit THREADS; try exact TID. i.
    exploit THREADS; try exact TH. i.
    clear DISJOINT THREADS PROMISES.
    dup WF1_SRC. inv WF1_SRC0. inv WF. ss.
    exploit DISJOINT; try exact H; eauto. i.
    exploit THREADS; try exact FIND_SRC. i.
    exploit THREADS; try exact FIND0_SRC. i.
    clear DISJOINT THREADS PROMISES.
    exploit rtc_implies; [eauto|..].
    { etrans.
      - eapply Thread.tau_opt_all; try exact STEP_SRC.
        eapply rtc_implies; try exact STEPS_SRC. i. inv H0. des. econs; eauto.
      - eapply rtc_implies; try exact STEPS_SRC0. i. inv H0. des. econs; eauto.
    }
    intro STEP_SRC_ALL.
    exploit Thread.rtc_all_step_future; try exact STEP_SRC_ALL; eauto. s. i. des.
    exploit Thread.rtc_all_step_disjoint; try exact STEP_SRC_ALL; eauto. s. i. des.
    exploit (@FutureCertify.future_certify lang0 (Thread.mk _ st0_src lc0_src (Thread.global th2_src1)));
      try exact CERTIFY; ss; (try by inv THREAD0; ss); (try by inv SIM1; ss); try apply SIM1.
    { etrans.
      - eapply Memory.future_messages_le.
        etrans; [apply FUTURE|].
        etrans; [apply GL_FUTURE|].
        apply GL_FUTURE0.
      - exploit Thread.rtc_all_step_future; try eapply rtc_implies; try exact STEPS1; eauto.
        { i. inv H0. econs; eauto. }
        { apply Local.cap_wf; ss. }
        { apply Global.cap_wf; ss. }
        s. i. des.
        etrans; [|eapply Memory.future_messages_le; apply GL_FUTURE2].
        apply Memory.cap_messages_le.
        apply Memory.cap_of_cap.
    }
    { exploit Thread.rtc_all_step_disjoint.
      { etrans; [eapply rtc_implies; try exact STEPS|].
        { i. inv H0. econs. eauto. }
        econs 2; try refl. econs. eauto.
      }
      { eauto. }
      { ss. }
      s. i. des.
      exploit Local.cap_wf; try exact LC_WF5. i.
      exploit Thread.rtc_all_step_disjoint; try eapply rtc_implies; try exact STEPS1.
      { i. inv H0. econs; eauto. }
      { eauto. }
      { ss. }
      i. des. apply LC_WF6.
    }
    intro CERTIFY_SRC.
    destruct th2_src0. ss.
    exploit (@PFConfiguration.rtc_program_step_rtc_step
               (Configuration.mk (IdentMap.add tid (existT _ lang state, local) ths1_src) global));
      try exact STEPS_SRC0; s; try apply IdentMap.gss.
    i. des; eauto.

    inv CERTIFY_SRC.
    - exploit (@PFConfiguration.plus_program_step_plus_step
                 (Configuration.mk
                    (IdentMap.add tid (existT _ lang (Thread.state th2_src1), Thread.local th2_src1) ths1_src)
                    (Thread.global th2_src1))); s.
      { erewrite IdentMap.gso; try eapply FIND0_SRC. auto. }
      { eapply rtc_implies; try exact STEPS3.
        i. inv H0. des. econs; eauto.
        inv EVENT0. inv EVENT2. destruct e2; ss.
      }
      { eassumption. }
      { destruct e1; ss. }
      i. des; try by destruct e1; ss.
      esplits; try exact STEP. etrans; [eauto|].
      rewrite IdentMap.add_add_eq. ss.
    - destruct th2_src1 as [st2_src lc2_src gl2_src]. ss.
      assert (RACE: exists e th3_src,
                 Thread.step e
                             (Thread.mk _ st2_src lc2_src (Thread.global th4)) th3_src /\
                 ThreadEvent.is_racy e /\
                 ~ ThreadEvent.is_racy_promise e).
      { exploit Thread.rtc_all_step_future; try eapply rtc_implies; try exact STEPS3; ss.
        { i. inv H0. econs; eauto. }
        i. des.
        inv STEP_FULFILL; inv LOCAL. inv LOCAL0. ss.
        exploit Memory.add_get0; try exact WRITE. i. des.
        inv SIM1. ss. subst.
        inv STEP_RACE; inv LOCAL; ss; subst.
        - esplits.
          + econs 2; cycle 1.
            * econs 8. econs.
              econs 2; try apply GET2; ss.
              eapply TimeFacts.le_lt_lt; try exact TO.
              inv LC_WF3. inv TVIEW_CLOSED. inv CUR.
              exploit Memory.future_closed_timemap; try exact PLN; try apply GL_FUTURE2. i. des.
              eapply Memory.max_ts_spec. eauto.
           * ss. eauto.
          + ss.
          + ss.
        - esplits.
          + econs 2; cycle 1.
            * econs 9. econs. econs 2; try apply GET2; ss.
              eapply TimeFacts.le_lt_lt; try exact TO.
              inv LC_WF3. inv TVIEW_CLOSED. inv CUR.
              exploit Memory.future_closed_timemap; try exact PLN; try apply GL_FUTURE2. i. des.
              eapply Memory.max_ts_spec. eauto.
            * ss. eauto.
          + ss.
          + ss.
        - esplits.
          + econs 2; cycle 1.
            * econs 10. econs 3. econs 2; try apply GET2; ss.
              eapply TimeFacts.le_lt_lt; try exact TO.
              inv LC_WF3. inv TVIEW_CLOSED. inv CUR.
              exploit Memory.future_closed_timemap; try exact PLN; try apply GL_FUTURE2. i. des.
              eapply Memory.max_ts_spec. eauto.
            * ss. eauto.
          + ss.
          + ss.
      }
      des. destruct th3_src.
      exploit (@PFConfiguration.plus_program_step_plus_step
                 (Configuration.mk
                    (IdentMap.add tid (existT _ lang st2_src, lc2_src) ths1_src) gl2_src)); s.
      { erewrite IdentMap.gso; try eapply FIND0_SRC. auto. }
      { eapply rtc_implies; try exact STEPS3.
        i. inv H0. des. econs; eauto.
        inv EVENT0. inv EVENT2. destruct e1; ss.
      }
      { eassumption. }
      { ss. }
      s. i. des; cycle 1.
      { esplits; try exact STEP. etrans; [eauto|].
        rewrite IdentMap.add_add_eq. ss.
      }
      esplits.
      + etrans; [eauto|].
        rewrite IdentMap.add_add_eq.
        eapply rtc_n1; [eauto|]. econs. exact STEP.
      + replace MachineEvent.failure with (ThreadEvent.get_machine_event_pf e1); cycle 1.
        { destruct e1; ss. }
        econs. econs; s.
        * rewrite IdentMap.gso; try by apply IdentMap.gss. ss.
        * eassumption.
        * destruct e1; ss.
  Qed.

  Theorem src_to_ir prog:
    behaviors Configuration.step (Configuration.init prog) <2=
    behaviors (PFConfiguration.step ThreadEvent.get_machine_event_pf) (Configuration.init prog).
  Proof.
    i. remember (Configuration.init prog) as c_ir in PR.
    specialize (init_sim_conf prog). intro SIM.
    specialize (Configuration.init_wf prog). intro WF_IR.
    rewrite <- Heqc_ir in WF_IR.
    rewrite <- Heqc_ir in SIM at 2.
    clear Heqc_ir.
    specialize (Configuration.init_wf prog). intro WF_SRC.
    remember (Configuration.init prog) as c_src.
    clear Heqc_src.
    revert c_src WF_SRC SIM.
    induction PR; i.
    - econs. eauto using sim_conf_terminal.
    - exploit sim_conf_step; try exact SIM; eauto. i. des.
      + eapply rtc_tau_step_behavior; try exact STEPS_SRC.
        econs 3; eauto.
      + exploit Configuration.step_future; try exact STEP; ss. i. des.
        exploit PFConfiguration.rtc_tau_step_future; try exact STEPS_SRC; ss. i. des.
        exploit PFConfiguration.opt_step_future; try exact STEP_SRC; ss. i. des.
        eapply rtc_tau_step_behavior; try exact STEPS_SRC.
        inv STEP_SRC. econs 2; eauto.
      + eapply rtc_tau_step_behavior; try exact STEPS_SRC.
        inv STEP_SRC. econs 2; eauto.
        eapply rtc_tau_step_behavior; try exact STEPS2_SRC.
        econs 3; eauto.
    - exploit sim_conf_step; try exact SIM; eauto. i. des.
      + eapply rtc_tau_step_behavior; try exact STEPS_SRC.
        econs 3; eauto.
      + eapply rtc_tau_step_behavior; try exact STEPS_SRC.
        inv STEP_SRC. econs 3; eauto.
      + eapply rtc_tau_step_behavior; try exact STEPS_SRC.
        inv STEP_SRC. econs 3; eauto.
    - exploit sim_conf_step; try exact SIM; eauto. i. des.
      + eapply rtc_tau_step_behavior; try exact STEPS_SRC.
        econs 3; eauto.
      + exploit Configuration.step_future; try exact STEP; ss. i. des.
        exploit PFConfiguration.rtc_tau_step_future; try exact STEPS_SRC; ss. i. des.
        exploit PFConfiguration.opt_step_future; try exact STEP_SRC; ss. i. des.
        eapply rtc_tau_step_behavior; try exact STEPS_SRC.
        inv STEP_SRC; auto. econs 4; eauto.
      + eapply rtc_tau_step_behavior.
        { etrans; try exact STEPS_SRC.
          inv STEP_SRC; [refl|]. econs 2; eauto.
        }
        eapply rtc_tau_step_behavior; try exact STEPS2_SRC.
        econs 3; eauto.
    - econs 5.
  Qed.
End SrcToIR.