Require Import CompCert.Behaviors.
Require Import CompCert.Smallstep.
Require Import Common.Definitions.
Require Import Common.Linking.
Require Import Common.CompCertExtensions.
Require Import Common.TracesInform.
Require Import Common.RenamingOption.

Require Import Source.Definability.
Require Import Source.DefinabilityEnd.
Require Import Source.Language.
Require Import Source.GlobalEnv.
Require Import Source.CS.
Require Import Intermediate.Machine.
Require Import Intermediate.CS.
Require Import Intermediate.RecompositionRel.
Require Import S2I.Compiler.
Require Import S2I.Definitions.

From mathcomp Require Import ssreflect ssrfun ssrbool.

Set Implicit Arguments.
Unset Strict Implicit.

Set Bullet Behavior "Strict Subproofs".

Section RSC_Section.
  Variable p: Source.program.
  Variable psz: {fmap Component.id -> nat}.
  Variable p_compiled: Intermediate.program.
  Variable Ct: Intermediate.program.

  (* Some reasonable assumptions about our programs *)

  Hypothesis domm_psz_intf: domm psz = domm (Source.prog_interface p).
  Hypothesis well_formed_p : Source.well_formed_program p.
  Hypothesis disciplined_p: Compiler.disciplined_program p.
  Hypothesis good_Elocal_p: NoLeak.good_Elocal_usage_program p.
  Hypothesis successful_compilation : Compiler.compile_program p psz = Some p_compiled.
  Hypothesis well_formed_Ct : Intermediate.well_formed_program Ct.
  Hypothesis linkability : linkable (Source.prog_interface p) (Intermediate.prog_interface Ct).
  Hypothesis closedness :
    Intermediate.closed_program (Intermediate.program_link p_compiled Ct).
  Hypothesis mains : Intermediate.linkable_mains p_compiled Ct.

  (* Main Theorem *)

  (* [DynShare]

     - Maybe we can get rid of the disjunction "... \/ behavior_improves_blame beh".
     - And also we should (instead of program_behaves) directly use
       does_prefix (Source.CS.sem (Source.program_link p Cs)) m'
       Notice that does_prefix is the "finite version" of "program_behaves", i.e., it still
       contains the cases of FTerminates and FGoesWrong.

     * Because our current S2I compiler does not seem to refine any undef behavior,
       we should be able to get rid of the blame disjunct.

   *)

  Theorem RSC:
    forall t s,
      Star (Intermediate.CS.CS.sem_non_inform (Intermediate.program_link p_compiled Ct))
           (Intermediate.CS.CS.initial_machine_state
              (Intermediate.program_link p_compiled Ct)
           )
           t
           s
      ->
      exists Cs t' s' size_meta size_meta',
      Source.prog_interface Cs = Intermediate.prog_interface Ct /\
      Source.well_formed_program Cs /\
      linkable (Source.prog_interface p) (Source.prog_interface Cs) /\
      Source.closed_program (Source.program_link p Cs) /\
      Star (Source.CS.CS.sem (Source.program_link p Cs))
           (Source.CS.CS.initial_machine_state
              (Source.program_link p Cs)
           )
           t'
           s'
      /\
      traces_shift_each_other_option size_meta size_meta' t t'.
  Proof.
    intros t s Hstar.

    (* Some auxiliary results. *)
    pose proof
      Compiler.compilation_preserves_well_formedness well_formed_p successful_compilation
      as well_formed_p_compiled.

    assert (linkability_pcomp_Ct :
              linkable (Intermediate.prog_interface p_compiled)
                       (Intermediate.prog_interface Ct)).
    {
      assert (sound_interface_p_Ct : sound_interface (unionm (Source.prog_interface p)
                                                             (Intermediate.prog_interface Ct)))
        by apply linkability.
      assert (fdisjoint_p_Ct : fdisjoint (domm (Source.prog_interface p))
                                         (domm (Intermediate.prog_interface Ct)))
        by apply linkability.
      constructor;
        apply Compiler.compilation_preserves_interface in successful_compilation;
        now rewrite successful_compilation.
    }

    assert (exists t_inform,
               Star
                 (Intermediate.CS.CS.sem_inform
                    (Intermediate.program_link p_compiled Ct))
                 (Intermediate.CS.CS.initial_machine_state
                    (Intermediate.program_link p_compiled Ct)
                 )
                 t_inform
                 s
               /\ project_non_inform t_inform = t) as [t_inform [Hstarinform Hproj]].
    {
      by eapply Intermediate.CS.CS.star_sem_non_inform_star_sem_inform.
    }

    (* definability *)
    destruct (definability_with_linking
                well_formed_p_compiled
                well_formed_Ct
                linkability_pcomp_Ct
                closedness
                Hstarinform)
      as [P' [Cs [t' [s' [metadata_size
         [Hsame_iface1 [Hsame_iface2
         [Hmatching_mains_P'_p_compiled [Hmatching_mains_Cs_Ct
                                           [well_formed_P' [well_formed_Cs [HP'Cs_closed [Hstar' [Ht_rel_t' [Hconst_map [good_P'_Cs [P'_Cs_disciplined P'_CS_good_Elocal]]]]]]]]]]]]]]]]].

    assert (Source.linkable_mains P' Cs) as HP'Cs_mains.
    { apply Source.linkable_disjoint_mains; trivial; congruence. }

    (* FCC *)

    (* the definability output can be split in two programs *)
    (* probably need partialize to obtain them *)

    (* At this point, we compile P' and Cs and establish their basic properties. *)

    have well_formed_P'Cs : Source.well_formed_program (Source.program_link P' Cs).
      rewrite -Hsame_iface1 -Hsame_iface2 in linkability_pcomp_Ct.
      exact: Source.linking_well_formedness well_formed_P' well_formed_Cs linkability_pcomp_Ct.

      assert (P'Cs_disciplined: disciplined_program (Source.program_link P' Cs)).
      {
        intros ? ? ? Hfind.
        eapply P'_Cs_disciplined; eauto.
      }

      assert (exists s' t'compiled P'Cs_sz P'_Cs_compiled,
                 domm P'Cs_sz = domm (Source.prog_interface (Source.program_link P' Cs))
                 /\
                 Compiler.compile_program (Source.program_link P' Cs) P'Cs_sz =
                 Some P'_Cs_compiled
                 /\
                 Star (Intermediate.CS.CS.sem_non_inform P'_Cs_compiled)
                      (I.CS.initial_machine_state P'_Cs_compiled)
                      t'compiled s'
                 /\
                 traces_shift_each_other_option
                   (uniform_shift 1)
                   (uniform_shift 1)
                   t'
                   t'compiled
             )
        as [s'_compiled [t'compiled [P'Cs_sz [P'_Cs_compiled
                                       [Hdomm_P'Cs_sz
                                          [HP'_Cs_compiles
                                             [HP'_Cs_compiled_star
                                                Ht'_rel_t'compiled

           ]]]]]]].
      {
        eapply Compiler.forward_simulation_star with (metasize := uniform_shift 1).
        - assumption.
        - assumption.
        - exact P'Cs_disciplined.
        - exact P'_CS_good_Elocal.
        - exact Hstar'.
      }

    assert (P'_Cs_linkable:
              linkable (Source.prog_interface P') (Source.prog_interface Cs)).
    {
      by rewrite Hsame_iface1 Hsame_iface2.
    }

    assert (exists P'sz Cssz,
               unionm P'sz Cssz = P'Cs_sz
           ) as [P'sz [Cssz Hunion]].
    {
      exists (filterm (fun k => fun=> k \in domm (Source.prog_interface P')) P'Cs_sz).
      exists (filterm (fun k => fun=> k \in domm (Source.prog_interface Cs)) P'Cs_sz).
      assert (G': unionm
                    (filterm (T:=nat_ordType)
                             (fun k : nat_ordType =>
                                fun=> k \in domm
                                              (T:=nat_ordType)
                                              (S:=Component.interface)
                                              (Source.prog_interface P'))
                             P'Cs_sz)
                    (filterm (T:=nat_ordType)
                             (fun k : nat_ordType =>
                                fun=> k \in domm
                                              (T:=nat_ordType)
                                              (S:=Component.interface)
                                              (Source.prog_interface Cs))
                             P'Cs_sz) = P'Cs_sz).
      {
        apply eq_fmap. intros x. rewrite unionmE !filtermE.

        destruct (P'Cs_sz x) eqn:e.
        + simpl.
          assert (G1: exists n, P'Cs_sz x = Some n) by eauto.
          move : G1 => /dommP => G1.
          rewrite Hdomm_P'Cs_sz domm_union in G1.
          destruct (x \in domm (Source.prog_interface P')) eqn:edomm; rewrite edomm;
            simpl; auto.
          assert (x \in domm (Source.prog_interface Cs)).
          {
            rewrite in_fsetU in G1.
            move : G1 => /orP => G1.
            destruct G1 as [contra|G1]; [by rewrite edomm in contra | assumption].
          }
            by rewrite H.
        + by simpl.
      }
      exact G'.
    }

    specialize (Compiler.well_formed_compilable _ P'sz well_formed_P') as
        [P'_compiled HP'_compiles].

    specialize (Compiler.well_formed_compilable _ Cssz well_formed_Cs) as
        [Cs_compiled HCs_compiles].
    rewrite -Hunion in HP'_Cs_compiles.

    assert (Hrewr: compile_program (Source.program_link P' Cs) (unionm P'sz Cssz) =
                   Some (Intermediate.program_link P'_compiled Cs_compiled)).
    { by eapply Compiler.separate_compilation; eauto. }

    rewrite HP'_Cs_compiles in Hrewr.
    inversion Hrewr. subst.

    pose proof Compiler.compilation_preserves_well_formedness well_formed_P' HP'_compiles
      as well_formed_P'_compiled.

    pose proof Compiler.compilation_preserves_well_formedness well_formed_Cs HCs_compiles
      as well_formed_Cs_compiled.

    assert
      (linkable
         (Intermediate.prog_interface Cs_compiled)
         (Intermediate.prog_interface P'_compiled))
      as linkability'. {
      eapply @Compiler.compilation_preserves_linkability with (p:=Cs) (c:=P'); eauto.
      apply linkable_sym.
      rewrite <- Hsame_iface1 in linkability_pcomp_Ct.
      rewrite <- Hsame_iface2 in linkability_pcomp_Ct.
      apply linkability_pcomp_Ct.
    }

    rewrite Intermediate.program_linkC in HP'_Cs_compiled_star;
       [| assumption |assumption | apply linkable_sym in linkability'; assumption].

    (* intermediate composition *)
    assert (Intermediate.prog_interface Ct = Intermediate.prog_interface Cs_compiled)
      as Hctx_same_iface. {
      symmetry. erewrite Compiler.compilation_preserves_interface.
      - rewrite <- Hsame_iface2. reflexivity.
      - eassumption.
    }
    (* rewrite Hctx_same_iface in HP_decomp. *)
    assert (Intermediate.prog_interface p_compiled = Intermediate.prog_interface P'_compiled) as Hprog_same_iface. {
      symmetry. erewrite Compiler.compilation_preserves_interface.
      - apply Hsame_iface1.
      - eassumption.
    }
    (* rewrite <- Hprog_same_iface in HCs_decomp. *)

    assert (linkable (Intermediate.prog_interface p_compiled) (Intermediate.prog_interface Cs_compiled))
      as linkability''.
    {
      unfold linkable. split; try
        rewrite Hprog_same_iface;
        apply linkable_sym in linkability';
        now inversion linkability'.
    }
    assert (Intermediate.closed_program (Intermediate.program_link p_compiled Cs_compiled))
      as HpCs_compiled_closed.
    pose proof S2I.Definitions.matching_mains_equiv
         _ _ _
         Hmatching_mains_Cs_Ct
         (Compiler.compilation_has_matching_mains well_formed_Cs HCs_compiles)
         as Hctx_match_mains.
    now apply (Intermediate.interface_preserves_closedness_r
                 well_formed_p_compiled well_formed_Cs_compiled
                 Hctx_same_iface linkability_pcomp_Ct closedness mains Hctx_match_mains); auto.
    assert (Intermediate.well_formed_program (Intermediate.program_link p_compiled Cs_compiled))
      as HpCs_compiled_well_formed
        by (apply Intermediate.linking_well_formedness; assumption).

    assert (Intermediate.linkable_mains p_compiled Cs_compiled) as linkable_mains.
    {
      eapply (@Compiler.compilation_preserves_linkable_mains p _ _ Cs);
        try eassumption.
      - rewrite <- Hsame_iface2 in linkability.
        eapply Source.linkable_disjoint_mains; assumption.
    }

    assert (mergeable_interfaces (Intermediate.prog_interface p_compiled)
                                 (Intermediate.prog_interface Cs_compiled))
      as Hmergeable_ifaces.
      by apply Intermediate.compose_mergeable_interfaces.

    assert (Source.closed_program (Source.program_link p Cs)) as Hclosed_p_Cs. {
      apply (Source.interface_preserves_closedness_l HP'Cs_closed); trivial.
      apply Compiler.compilation_preserves_interface in HP'_compiles.
      apply Compiler.compilation_preserves_interface in successful_compilation.
      congruence.
    }
    assert (linkable (Source.prog_interface p) (Source.prog_interface Cs))
      as Hlinkable_p_Cs. {
      inversion linkability'' as [sound_interface_p_Cs fdisjoint_p_Cs].
      constructor;
        (apply Compiler.compilation_preserves_interface in HCs_compiles;
        apply Compiler.compilation_preserves_interface in successful_compilation;
        rewrite <- HCs_compiles; rewrite <- successful_compilation;
        assumption).
    }
    assert (Source.well_formed_program (Source.program_link p Cs)) as Hwf_p_Cs
      by (apply Source.linking_well_formedness; assumption).

    assert (HP'Cs_compiled_closed :
              Intermediate.closed_program (Intermediate.program_link P'_compiled Cs_compiled)).
    {
      rewrite Intermediate.program_linkC; try easy; try now apply linkable_sym.
      apply Intermediate.interface_preserves_closedness_r with (p2 := p_compiled); eauto.
      apply linkable_sym; eauto.
      rewrite Intermediate.program_linkC; eauto.
      apply linkable_sym; eauto.
      apply Intermediate.linkable_mains_sym; eauto.
      eapply S2I.Definitions.matching_mains_equiv; eauto.
      eapply Compiler.compilation_has_matching_mains; eauto.
    }

    rewrite Intermediate.program_linkC in HP'_Cs_compiled_star; try assumption.
    rewrite <- Hctx_same_iface in Hmergeable_ifaces.

    assert (H_p_Ct_good: forall (ss : CS.state) (tt : Events.trace Events.event),
               CSInvariants.CSInvariants.is_prefix
                 ss (Intermediate.program_link p_compiled Ct) tt ->
               good_trace_extensional (left_addr_good_for_shifting all_zeros_shift) tt
               /\
               (forall (mem : eqtype.Equality.sort Memory.Memory.t) (ptr : Pointer.t)
                       (addr : Component.id * Block.id) (v : value),
                   CS.state_mem ss = mem ->
                   Memory.Memory.load mem ptr = Some v ->
                   addr = (Pointer.component ptr, Pointer.block ptr) ->
                   left_addr_good_for_shifting all_zeros_shift addr ->
                   left_value_good_for_shifting all_zeros_shift v)).
    {
      intros ? ? ?. split.
      - constructor. intros ? ?. destruct a as [? ?].
        unfold all_zeros_shift, uniform_shift. easy.
      - intros ? ? ? ? ? ? ? ?.
        destruct v as [| [[[[|] ?] ?] ?] |]; unfold all_zeros_shift, uniform_shift;
          simpl; easy.
    }

    (** Need an axiom about the Compiler. The axiom will transfer goodness of *)
    (** a source program to goodness of the compiled version, where goodness  *)
    (** is described as conformance of the sharing behavior with the static   *)
    (** address renaming convention (i.e., shared addresses are renamed into  *)
    (** shared addresses). Viewed dually, the axiom about the compiler says   *)
    (** that the compiler preserves the privacy of private (non-shared)       *)
    (** addresses.                                                            *)

    (** With such an axiom in hand, we can assert the following from its      *)
    (** corresponding source version.                                         *)

    assert (HP'_compiled_Cs_compiled_good: forall (ss'' : CS.state) tt'',
               CSInvariants.CSInvariants.is_prefix
                 ss''
                 (Intermediate.program_link P'_compiled Cs_compiled) tt'' ->
               good_trace_extensional
                 (left_addr_good_for_shifting
                    (uniform_shift 1)) tt''
               /\
               (forall (mem : eqtype.Equality.sort Memory.Memory.t) (ptr : Pointer.t)
                       (addr : Component.id * Block.id) (v : value),
                   CS.state_mem ss'' = mem ->
                   Memory.Memory.load mem ptr = Some v ->
                   addr = (Pointer.component ptr, Pointer.block ptr) ->
                   left_addr_good_for_shifting
                     (uniform_shift 1) addr ->
                   left_value_good_for_shifting
                     (uniform_shift 1) v)).
    {
      assert (P'_Cs_closed: Source.closed_program (Source.program_link P' Cs)).
      {
        eapply Source.interface_preserves_closedness_l; eauto.
        rewrite Hsame_iface1.
        erewrite compilation_preserves_interface; eauto.
      }

      assert (P'_Cs_wf: Source.well_formed_program (Source.program_link P' Cs)).
      {
        eapply Source.linking_well_formedness; eauto.
      }

      specialize (Compiler.compiler_preserves_non_leakage_of_private_pointers
                    _ _ _ _ P'_Cs_closed P'_Cs_wf HP'_Cs_compiles good_P'_Cs
                 ) as G.
      unfold CSInvariants.CSInvariants.is_prefix.
      intros ? ? Hpref.
      unfold private_pointers_never_leak_I, shared_locations_have_only_shared_values in *.
      specialize (G ss'' tt'' Hpref) as [G1 G2].
      split; first exact G1.
      intros ? ? ? ? ? ? ? ?.
      eapply G2; eauto.
    }

    assert (t_rel_t'compiled: traces_shift_each_other_option
                        all_zeros_shift
                        (uniform_shift 1)
                        (project_non_inform t_inform) t'compiled).
    {
        eapply traces_shift_each_other_option_transitive.
        - apply traces_shift_each_other_option_symmetric; exact Ht_rel_t'.
        - exact Ht'_rel_t'compiled.
    }

    pose proof Intermediate.RecompositionRel.recombination_trace_rel
    well_formed_p_compiled
    well_formed_Ct
    well_formed_P'_compiled
    well_formed_Cs_compiled
    Hmergeable_ifaces
    Hprog_same_iface
    Hctx_same_iface
    closedness
    HP'Cs_compiled_closed
    H_p_Ct_good
    HP'_compiled_Cs_compiled_good
    Hstar
    HP'_Cs_compiled_star
    t_rel_t'compiled
      as [s_recomb [t_recomb [Hstar_recomb [_ trel_recomb]]]].

    (* BCC *)
    assert (exists pCs_compiled,
               Compiler.compile_program (Source.program_link p Cs)
                                        (unionm psz Cssz)
               = Some pCs_compiled)
      as [pCs_compiled HpCs_compiles].
      by now apply Compiler.well_formed_compilable.

      eapply Compiler.backward_simulation_star
        in Hstar_recomb
      ;
        eauto;
        last by
        (erewrite HpCs_compiles;
         erewrite Compiler.separate_compilation in HpCs_compiles; eauto
        ).

      destruct Hstar_recomb as [s'_pCs HpCs_star].
      destruct HpCs_star as [tQed [HstarQed HshiftQed]].
      do 5 eexists; split; last split; last split; last split; last split;
        eauto.
      {
        eapply traces_shift_each_other_option_transitive.
        - exact trel_recomb.
        - eassumption.
      }

      apply disciplined_program_link; auto.

      eapply disciplined_program_unlink with (c := P'); eauto.
      - eapply linkable_sym. eauto.
      - rewrite Source.link_sym; auto.
        by apply linkable_sym.
      - eapply NoLeak.good_Elocal_usage_program_link; auto.
        eapply NoLeak.good_Elocal_usage_program_unlink with (c := P'); eauto.
        eapply linkable_sym; eauto.
        rewrite Source.link_sym; auto.
        by apply linkable_sym.
Qed.

Print Assumptions RSC.

End RSC_Section.

(* To evaluate the assumptions and statements of the main results,
   uncomment and execute the following statements. To show the
   statement of a theorem, replace [Print Assumptions] -> [Check]. *)

(* Check RSC. *)
(* Print Assumptions S2I.Compiler.forward_simulation_star. *)
(* Print Assumptions Intermediate.RecompositionRel.recombination_trace_rel. *)
(* Print Assumptions S2I.Compiler.backward_simulation_star. *)
(* Print CompCert.Events.event. *)
(* Print Common.TracesInform.event_inform. *)
(* Print Assumptions Intermediate.CS.CS.star_sem_non_inform_star_sem_inform. *)
(* Print Assumptions Source.Definability.definability. *)
(* Print Intermediate.RecompositionRelCommon.mergeable_internal_states. *)
(* Print Common.RenamingOption.traces_shift_each_other_option. *)
(* Check Intermediate.CS.CS.Jump. *)
(* Check Intermediate.CS.CS.Store. *)
(* Print Assumptions RSC. *)
(* Print Assumptions Source.Definability.definability_gen_rel_right. *)
(* Print Intermediate.RecompositionRelCommon.mergeable_border_states. *)
(* Print Assumptions Intermediate.RecompositionRelStrengthening.threeway_multisem_event_lockstep_program_step. *)
(* Print Assumptions Intermediate.RecompositionRelOptionSim.merge_states_silent_star. *)
(* Print Assumptions Intermediate.RecompositionRelLockstepSim.threeway_multisem_star_E0. *)
(* Print Assumptions Intermediate.RecompositionRelCommon.mergeable_internal_states_sym. *)


(** This file implements symbolic evaluation for the
 ** language defined in IL.v
 **)
Require Import List.
Require Import ExtLib.Tactics.Consider.
Require Import MirrorShard.SepExpr.
Require Import MirrorShard.Expr.
Require Import MirrorShard.Prover.
Require Import MirrorShard.Quantifier.
Require Import MirrorShard.Env TypedPackage.
Require Import IL SepIL.
Require Import Word Memory.
Require Import PropX.
Require Structured SymEval.
Require Import ILEnv SymIL.

Set Implicit Arguments.
Set Strict Implicit.

(** The Symolic Evaluation Interfaces *)
Module MEVAL := SymIL.MEVAL.

Module SymIL_Correct.
  Section typed.
    Variable ts : list type.
    Let types := repr bedrock_types_r ts.

    Notation pcT := (tvType 0).
    Notation tvWord := (tvType 0).
    Notation stT := (tvType 1).
    Notation tvState := (tvType 2).
    Notation tvTest := (tvType 3).
    Notation tvReg := (tvType 4).

    Variable fs : functions types.
    Let funcs := repr (bedrock_funcs_r ts) fs.
    Variable preds : SEP.predicates types.

    Variable Prover : ProverT types.
    Variable PC : ProverT_correct Prover funcs.

    Variable meval : MEVAL.MemEvaluator types.
    Variable meval_correct : MEVAL.MemEvaluator_correct pcT stT meval funcs preds tvWord tvWord
      (@IL_mem_satisfies ts) (@IL_ReadWord ts) (@IL_WriteWord ts) (@IL_ReadByte ts) (@IL_WriteByte ts).

    Variable facts : Facts Prover.
    Variable meta_env : env types.
    Variable vars_env : env types.

    Lemma stateD_interp : forall cs stn_st ss sh,
      stateD funcs preds meta_env vars_env cs stn_st ss ->
      SymMem ss = Some sh ->
      interp cs (![ SEP.sexprD funcs preds meta_env vars_env (SH.sheapD sh)] stn_st).
    Proof.
      clear. destruct stn_st; destruct ss; destruct SymRegs; destruct p; simpl; intros.
      rewrite H0 in *. intuition.
    Qed.

    Hint Resolve stateD_interp : sym_eval_hints.

    Ltac t_correct :=
      simpl; intros;
        unfold IL_stn_st, IL_mem_satisfies, IL_ReadWord, IL_WriteWord in *;
          repeat (simpl in *;
            match goal with
              | [ H : Some _ = Some _ |- _ ] => inversion H; clear H; subst
              | [ H : prod _ _ |- _ ] => destruct H
              | [ H : match ?X with
                        | Some _ => _
                        | None => _
                      end |- _ ] =>
                revert H; case_eq X; intros; try contradiction
              | [ H : match ?X with
                        | Some _ => _
                        | None => _
                      end = _ |- _ ] =>
                revert H; case_eq X; intros; try congruence
              | [ H : _ = _ |- _ ] => rewrite H
              | [ H : @existsEach _ _ _ |- _ ] => apply existsEach_sem in H
              | [ H : exists x, _ |- _ ] => destruct H
              | [ H : _ /\ _ |- _ ] => destruct H
              | [ |- exists x, Some _ = Some _ /\ _ ] =>
                eexists; split; [ reflexivity | ]
            end); subst; eauto with sym_eval_hints.

    Lemma sym_evalLoc_correct : forall loc ss res res' stn_st locD cs,
      stateD funcs preds meta_env vars_env cs stn_st ss ->
      sym_locD fs meta_env vars_env loc = Some locD ->
      evalLoc (snd stn_st) locD = res' ->
      sym_evalLoc loc ss = res ->
      exprD funcs meta_env vars_env res tvWord = Some res'.
    Proof.
      destruct loc; unfold stateD; destruct ss; destruct SymRegs; destruct p; intros; destruct stn_st; simpl in *;
        t_correct; try solve [ eauto
                             | destruct r; simpl in *;
                               repeat match goal with
                                        | [ H : _ = _ |- _ ] => rewrite H
                                        | [ |- _ ] => subst funcs
                                      end; eauto ].
    Qed.

    Hypothesis Valid_facts : Valid PC meta_env vars_env facts.

    Lemma sym_evalRval_correct : forall rv ss res stn_st rvD cs,
      stateD funcs preds meta_env vars_env cs stn_st ss ->
      sym_rvalueD funcs meta_env vars_env rv = Some rvD ->
      sym_evalRval Prover meval facts rv ss = Some res ->
      exists val,
        evalRvalue (fst stn_st) (snd stn_st) rvD = Some val /\
        exprD funcs meta_env vars_env res tvWord = Some val.
    Proof.
      Opaque stateD sym_locD.
      destruct rv; t_correct.
      { destruct s; t_correct.
        { erewrite <- (@sym_evalLoc_correct (SymReg _ r)). f_equal. eauto. simpl.
          Transparent sym_locD. simpl. reflexivity. Opaque sym_locD. reflexivity. reflexivity. }
        { eapply (MEVAL.ReadCorrect meval_correct) with (cs := cs) in H2; eauto with sym_eval_hints.
          2: eapply sym_evalLoc_correct; (instantiate; eauto with sym_eval_hints). 2: eauto.
          t_correct. }
        { eapply (MEVAL.ReadByteCorrect meval_correct) with (cs := cs) in H2; eauto with sym_eval_hints.
          2: eapply sym_evalLoc_correct; (instantiate; eauto with sym_eval_hints). 2: eauto.
          t_correct. } }
      { congruence. }
    Qed.

    Lemma sym_evalLval_correct : forall lv stn_st lvD cs val ss ss' valD,
      stateD funcs preds meta_env vars_env cs stn_st ss ->
      sym_lvalueD funcs meta_env vars_env lv = Some lvD ->
      sym_evalLval Prover meval facts lv val ss = Some ss' ->
      exprD funcs meta_env vars_env val tvWord = Some valD ->
      exists st',
        evalLvalue (fst stn_st) (snd stn_st) lvD valD = Some st' /\
        stateD funcs preds meta_env vars_env cs (fst stn_st, st') ss'.
    Proof.
      destruct lv; t_correct.
      { Transparent stateD. unfold stateD in *. t_correct. Opaque stateD.
        case_eq (sym_setReg r val (SymRegs ss)); intros.
        destruct ss; destruct SymRegs; destruct p. t_correct.
        unfold sym_setReg in H0. destruct r; inversion H0; subst; t_correct; unfold rupd; simpl; intuition;
        try solve [ repeat rewrite sepFormula_eq in *; unfold sepFormula_def in *; simpl in *; auto ].
        destruct r; inversion H0; subst; t_correct; unfold rupd; simpl; intuition. }
      { eapply (@sym_evalLoc_correct s) in H0; eauto.
        simpl.
        match goal with
          | [ H : MEVAL.swrite_word _ _ _ _ _ _ = _ |- _ ] =>
            eapply (MEVAL.WriteCorrect meval_correct) with (cs := cs) (stn_m := (s0,s1)) in H; eauto with sym_eval_hints
        end.
        simpl in *.
        destruct (WriteWord s0 (Mem s1) (evalLoc s1 l) valD); try contradiction. t_correct.
        Transparent stateD. destruct ss; destruct SymRegs; destruct p. simpl in *. Opaque stateD. intuition. subst.
        eapply sheapD_pures_SF in H3.
        apply AllProvable_app' in H6. apply AllProvable_app; intuition auto. }
      { eapply (@sym_evalLoc_correct s) in H0; eauto.
        simpl.
        match goal with
          | [ H : MEVAL.swrite_byte _ _ _ _ _ _ = _ |- _ ] =>
            eapply (MEVAL.WriteByteCorrect meval_correct) with (cs := cs) (stn_m := (s0,s1)) in H; eauto with sym_eval_hints
        end.
        simpl in *.
        destruct (WriteByte (Mem s1) (evalLoc s1 l) (WtoB valD)); try contradiction. t_correct.
        Transparent stateD. destruct ss; destruct SymRegs; destruct p. simpl in *. Opaque stateD. intuition. subst.
        eapply sheapD_pures_SF in H3.
        apply AllProvable_app' in H6. apply AllProvable_app; intuition auto. }
    Qed.

    Ltac think := instantiate; simpl;
      repeat match goal with
               | [ H : _ = _ |- _ ] => rewrite H
             end; eauto.

    Lemma sym_evalInstr_correct' : forall instr stn_st instrD cs ss ss',
      stateD funcs preds meta_env vars_env cs stn_st ss ->
      sym_instrD funcs meta_env vars_env instr = Some instrD ->
      sym_evalInstr Prover meval facts instr ss = Some ss' ->
      exists st',
        evalInstr (fst stn_st) (snd stn_st) instrD = Some st' /\
        stateD funcs preds meta_env vars_env cs (fst stn_st, st') ss'.
    Proof.
      destruct instr; t_correct; simpl;
        repeat match goal with
                 | [ H : exists x, _ |- _ ] => destruct H
                 | [ H : _ /\ _ |- _ ] => destruct H
                 | [ H : sym_rvalueD _ _ _ _ = _ |- _ ] =>
                   (eapply sym_evalRval_correct in H; think); [ simpl in * ]
                 | [ H : sym_lvalueD _ _ _ _ = _ |- _ ] =>
                   (eapply sym_evalLval_correct in H; think); [ simpl in * ]
                 | [ H : _ = _ |- _ ] => rewrite H
                 | [ |- _ ] => progress (simpl in * )
                 | [ b : binop |- _ ] =>
                   destruct b; unfold fPlus, fMinus, fMult in *; simpl in *
               end; t_correct.
    Qed.

    Lemma sym_assertTest_correct' : forall cs r rD t l lD ss stn_st,
      stateD funcs preds meta_env vars_env cs stn_st ss ->
      sym_rvalueD funcs meta_env vars_env r = Some rD ->
      sym_rvalueD funcs meta_env vars_env l = Some lD ->
      match Structured.evalCond rD t lD (fst stn_st) (snd stn_st) with
        | None =>
          forall res,
            match sym_assertTest Prover meval facts r t l ss res with
              | Some _ => False
              | None => True
            end
        | Some res' =>
          match sym_assertTest Prover meval facts r t l ss res' with
            | Some b =>
              Provable funcs meta_env vars_env b
            | None => True
          end
      end.
    Proof.
      unfold sym_assertTest, Structured.evalCond; destruct stn_st; simpl in *;
        repeat match goal with
                 | [ H : exists x, _ |- _ ] => destruct H
                 | [ H : _ /\ _ |- _ ] => destruct H
                 | [ H : sym_rvalueD _ _ _ _ = _ |- _ ] =>
                   (eapply sym_evalRval_correct in H; think); [ simpl in * ]
                 | [ H : sym_lvalueD _ _ _ _ = _ |- _ ] =>
                   (eapply sym_evalLval_correct in H; think); [ simpl in * ]
                 | [ H : _ = _ |- _ ] => rewrite H
                 | [ |- _ ] => progress (simpl in * )
                 | [ |- context [ evalRvalue ?A ?B ?C ] ] =>
                   case_eq (evalRvalue A B C); intros
                 | [ |- context [ evalTest ?A ?B ?C ] ] =>
                   case_eq (evalTest A B C); intros
                 | [ b : binop |- _ ] =>
                   destruct b; unfold fPlus, fMinus, fMult in *; simpl in *
               end; t_correct; simpl in *;
      try destruct res;
       repeat match goal with
        | [ |- context [ sym_evalRval ?A ?B ?C ?D ?E ] ] =>
          case_eq (sym_evalRval A B C D E); intros
               end; auto;
        unfold Provable; destruct t;
        repeat match goal with
                 | [ |- match match ?X with
                                | Some _ => match ?Y with _ => _ end
                                | _ => _
                              end with _ => _ end ] =>
                   (case_eq X; trivial; case_eq Y; trivial); []

                 | [ H : exists x, _ |- _ ] => destruct H
                 | [ H : _ /\ _ |- _ ] => destruct H
                 | [ H : sym_rvalueD _ _ _ _ = _ |- _ ] =>
                   (eapply sym_evalRval_correct in H; think); [ simpl in * ]
                 | [ H : sym_lvalueD _ _ _ _ = _ |- _ ] =>
                   (eapply sym_evalLval_correct in H; think); [ simpl in * ]
                 | [ H : _ = _ |- _ ] => rewrite H
                 | [ |- _ ] => progress (simpl in * )
                 | [ |- context [ evalRvalue ?A ?B ?C ] ] =>
                   case_eq (evalRvalue A B C); intros
                 | [ |- context [ evalTest ?A ?B ?C ] ] =>
                   consider (evalTest A B C); intros
                 | [ b : binop |- _ ] =>
                   destruct b; unfold fPlus, fMinus, fMult in *; simpl in *
                 | [ |- _ ] => progress t_correct
               end; unfold IL.weqb, IL.wneb, wltb, wleb in *; simpl in *;
        repeat match goal with
                 | [ H : (if ?X then _ else _) = _ |- _ ] =>
                   revert H; consider X; try congruence
                 | [ H : Some _ = Some _ |- _ ] => inversion H; clear H; subst
                 | [ H : ?X = _ , H' : ?X = _ |- _ ] => rewrite H in H'
                 | [ |- context [ wlt_dec ?X ?Y ] ] =>
                   destruct (wlt_dec X Y); try congruence
               end; try congruence; eauto 10 using eq_le, lt_le, le_neq_lt.
      eapply weqb_true_iff; auto.
      intro. apply weqb_true_iff in H1. congruence.
    Qed.

  End typed.

  Section typed2.
    Variable ts : list type.
    Let types := repr bedrock_types_r ts.

    Notation pcT := (tvType 0).
    Notation tvWord := (tvType 0).
    Notation stT := (tvType 1).
    Notation tvState := (tvType 2).
    Notation tvTest := (tvType 3).
    Notation tvReg := (tvType 4).

    Variable fs : functions types.
    Let funcs := repr (bedrock_funcs_r ts) fs.
    Variable preds : SEP.predicates types.

    Variable Prover : ProverT types.
    Variable PC : ProverT_correct Prover funcs.

    Variable meval : MEVAL.MemEvaluator types.
    Variable meval_correct : MEVAL.MemEvaluator_correct pcT stT meval funcs preds tvWord tvWord
      (@IL_mem_satisfies ts) (@IL_ReadWord ts) (@IL_WriteWord ts) (@IL_ReadByte ts) (@IL_WriteByte ts).

    Ltac t_correct :=
      simpl; intros;
        unfold IL_stn_st, IL_mem_satisfies, IL_ReadWord, IL_WriteWord in *;
          repeat (simpl in *;
            match goal with
              | [ H : Some _ = Some _ |- _ ] => inversion H; clear H; subst
              | [ H : prod _ _ |- _ ] => destruct H
              | [ H : match ?X with
                        | Some _ => _
                        | None => _
                      end |- _ ] =>
              revert H; case_eq X; intros; try contradiction
              | [ H : match ?X with
                        | Some _ => _
                        | None => _
                      end = _ |- _ ] =>
              revert H; case_eq X; intros; try congruence
              | [ H : _ = _ |- _ ] => rewrite H
              | [ H : reg |- _ ] => destruct H
            end; intuition); subst.

    Lemma sym_evalInstrs_correct : forall (facts : Facts Prover) (meta_env var_env : env types),
      Valid PC meta_env var_env facts  ->
      forall is stn_st isD cs ss,
        stateD funcs preds meta_env var_env cs stn_st ss ->
        sym_instrsD funcs meta_env var_env is = Some isD ->
        match evalInstrs (fst stn_st) (snd stn_st) isD with
          | Some st' =>
            match sym_evalInstrs Prover meval facts is ss with
              | inl ss' => stateD funcs preds meta_env var_env cs (fst stn_st, st') ss'
              | inr (ss', is') =>
                match sym_instrsD funcs meta_env var_env is' with
                  | None => False
                  | Some is'D =>
                    exists st'', stateD funcs preds meta_env var_env cs (fst stn_st, st'') ss' /\
                      evalInstrs (fst stn_st) st'' is'D = Some st'
                end
            end
          | None =>
            match sym_evalInstrs Prover meval facts is ss with
              | inl ss' => False
              | inr (ss', is') =>
                match sym_instrsD funcs meta_env var_env is' with
                  | None => False
                  | Some is'D =>
                    exists st'', stateD funcs preds meta_env var_env cs (fst stn_st, st'') ss' /\
                      evalInstrs (fst stn_st) st'' is'D = None
                end
            end
        end.
    Proof.
      Opaque stateD.
      induction is; simpl; intros;
        repeat match goal with
                 | [ H : Some _ = Some _ |- _ ] => inversion H; clear H; subst
               end; simpl; destruct stn_st; simpl in *; eauto.
      t_correct. simpl in *.
      case_eq (evalInstr s s0 i); intros.
      case_eq (sym_evalInstr Prover meval facts a ss); intros.

      destruct (@sym_evalInstr_correct' ts fs preds Prover PC meval meval_correct facts meta_env var_env
        H a (s,s0) i cs ss s2 H0 H1 H4). simpl in *. intuition.
      rewrite H6 in H3. inversion H3; clear H3; subst.
      specialize (IHis (s, s1)). simpl in *. eapply IHis; eauto.

      simpl. rewrite H1. rewrite H2. simpl.
      case_eq (evalInstrs s s1 l); intros; exists s0; simpl; rewrite H3; eauto.

      case_eq (sym_evalInstr Prover meval facts a ss); intros.
      Focus 2. simpl. rewrite H1. rewrite H2. exists s0; simpl; rewrite H3; intuition.

      edestruct (@sym_evalInstr_correct' ts fs preds Prover PC meval meval_correct facts meta_env var_env
        H a (s,s0) i cs ss); eauto.
      simpl in *. destruct H5. rewrite H3 in H5. congruence.
      Transparent stateD.
    Qed.

    Variable learnHook : MEVAL.LearnHook types (SymState types).
    Variable learn_correct : @MEVAL.LearnHook_correct _ _ pcT stT learnHook (@stateD _ funcs preds) funcs preds.

    Ltac shatter_state ss :=
      destruct ss as [ ? [ [ ? ? ] ? ] ].

    Lemma skip_to_nil : forall T U (F : T -> U) vars env X,
      map F env = skipn (length vars) X ->
      map F nil = skipn (length (vars ++ env)) X.
    Proof.
      clear. induction vars; simpl; intros; subst.
      induction env; eauto.
      destruct X; auto.
    Qed.
    Lemma AllProvable_cons : forall U G P Ps,
      Provable funcs U G P ->
      AllProvable funcs U G Ps ->
      AllProvable funcs U G (P :: Ps).
    Proof. simpl; intuition. Qed.
    Lemma AllProvable_nil : forall U G,
      AllProvable funcs U G nil.
    Proof. simpl; intuition. Qed.
    Hint Resolve AllProvable_cons AllProvable_nil : env_resolution.
    Hint Resolve Learn_correct : env_resolution.
    Hint Resolve skip_to_nil : env_resolution.

    Lemma skip_prove_nil : forall T U (F : T -> U) vars env X Y,
      map F env = skipn (length vars) X ->
      map F Y = skipn (length (vars ++ env)) X ->
      Y = nil.
    Proof.
      clear. intros. destruct Y; auto.
      eapply skip_to_nil in H. rewrite <- H in H0. simpl in *; congruence.
    Qed.
    Hint Resolve skip_prove_nil : env_resolution.
    Lemma stateD_addToPures : forall U G cs ss stn_st P,
      stateD funcs preds U G cs stn_st ss ->
      Provable funcs U G P ->
      stateD funcs preds U G cs stn_st
      {| SymMem := SymMem ss
        ; SymRegs := SymRegs ss
        ; SymPures := P :: SymPures ss |}.
    Proof.
      Transparent stateD.
      clear. intros; shatter_state ss; destruct stn_st; simpl in *. intuition.
      destruct SymMem; intuition.
      Opaque stateD.
    Qed.
    Hint Resolve stateD_addToPures : stateD_solver.

    Ltac qstateD_solver :=
      eapply existsEach_sem; intros; eexists; split; [ solve [ eauto with env_resolution ] | ];
      let e := fresh in
      eapply forallEach_sem; intro e; intro;
      eauto with stateD_solver.

    Opaque repr stateD.
    Ltac split_congruence :=
      repeat match goal with
               | [ H : prod _ _ |- _ ] => destruct H
             end; congruence.

    Lemma stateD_weaken_vars : forall uvars vars cs stn_st ss' env,
      stateD funcs preds uvars vars cs stn_st ss' ->
      stateD funcs preds uvars (vars ++ env) cs stn_st ss'.
    Proof.
      Transparent stateD.
      clear. intros. destruct stn_st; shatter_state ss'; simpl in *.
      repeat match goal with
               | [ H : _ /\ _ |- _ ] => destruct H
               | [ H : context [ match exprD ?A ?B ?C ?D ?E with _ => _ end ] |- _ ] =>
                 revert H; case_eq (exprD A B C D E); intros; try contradiction
             end; subst.
      rewrite <- app_nil_r with (l := uvars). repeat erewrite exprD_weaken by eassumption.
      intuition. destruct SymMem; auto. erewrite SH.SE_FACTS.sexprD_weaken in H0. eassumption.
      eapply AllProvable_weaken; eauto.
    Qed.
    Lemma stateD_weaken_uvars : forall uvars vars cs stn_st ss' env,
      stateD funcs preds uvars vars cs stn_st ss' ->
      stateD funcs preds (uvars ++ env) vars cs stn_st ss'.
    Proof.
      Transparent stateD.
      clear. intros. destruct stn_st; shatter_state ss'; simpl in *.
      repeat match goal with
               | [ H : _ /\ _ |- _ ] => destruct H
               | [ H : context [ match exprD ?A ?B ?C ?D ?E with _ => _ end ] |- _ ] =>
                 revert H; case_eq (exprD A B C D E); intros; try contradiction
             end; subst.
      rewrite <- app_nil_r with (l := vars). repeat erewrite exprD_weaken by eassumption.
      intuition. destruct SymMem; auto. erewrite SH.SE_FACTS.sexprD_weaken in H0. eassumption.
      eapply AllProvable_weaken; eauto.
    Qed.
    Hint Resolve stateD_weaken_vars stateD_weaken_uvars : stateD_solver.
    Require ListFacts.
    Require Import MirrorShard.Tactics.
    Hint Resolve ListFacts.not_sure ListFacts.map_skipn_all_map_is_nil ListFacts.map_skipn_all_map : env_resolution.

    Lemma sym_locD_weaken : forall ts X A C Y Z,
      sym_locD (types' := ts) X A C Y = Some Z ->
      forall B D,
        sym_locD X (A ++ B) (C ++ D) Y = Some Z.
    Proof.
      clear. destruct Y; simpl; intros; think; auto;
      erewrite exprD_weaken; eauto.
    Qed.

    Lemma sym_lvalueD_weaken : forall ts X A C Y Z,
      sym_lvalueD (types' := ts) X A C Y = Some Z ->
      forall B D,
        sym_lvalueD X (A ++ B) (C ++ D) Y = Some Z.
    Proof.
      clear. destruct Y; simpl; intros; think; auto.
      erewrite sym_locD_weaken; eauto.
      erewrite sym_locD_weaken; eauto.
    Qed.
    Lemma sym_rvalueD_weaken : forall ts X A C Y Z,
      sym_rvalueD (types' := ts) X A C Y = Some Z ->
      forall B D,
        sym_rvalueD X (A ++ B) (C ++ D) Y = Some Z.
    Proof.
      clear. destruct Y; simpl; intros; think; auto.
      erewrite sym_lvalueD_weaken; eauto.
      erewrite exprD_weaken; eauto.
    Qed.

    Lemma sym_instrD_weaken : forall ts X A C Y Z,
      sym_instrD (types' := ts) X A C Y = Some Z ->
      forall B D,
      sym_instrD X (A ++ B) (C ++ D) Y = Some Z.
    Proof.
      clear; destruct Y; simpl; intros; think; auto;
        repeat ((erewrite sym_lvalueD_weaken by eauto) ||
                (erewrite sym_rvalueD_weaken by eauto)); auto.
    Qed.

    Lemma sym_instrsD_weaken : forall ts X A C Y Z,
      sym_instrsD (types' := ts) X A C Y = Some Z ->
      forall B D,
      sym_instrsD X (A ++ B) (C ++ D) Y = Some Z.
    Proof.
      clear. induction Y; simpl; intros; think; auto.
      erewrite sym_instrD_weaken; eauto.
    Qed.

    Lemma istreamD_weaken : forall ts X A C Y Z P L,
      istreamD (types' := ts) X A C Y Z P L ->
      forall B D,
      istreamD X (A ++ B) (C ++ D) Y Z P L.
    Proof.
      clear. induction Y; simpl; intros; think; auto.
      repeat match goal with
               | [ H : match ?X with _ => _ end |- _ ] =>
                 consider X; intros
               | [ H : _ /\ _ |- _ ] => destruct H
               | [ |- _ ] =>
                 (erewrite sym_instrsD_weaken by eauto) ||
                 (erewrite sym_rvalueD_weaken by eauto) ||
                 (erewrite sym_lvalueD_weaken by eauto)
             end; intuition.
    Qed.

    Lemma env_nil_by_length_eq : forall ts L X Y,
      typeof_env (types := ts) L = X ->
      length Y = length X ->
      typeof_env (types := ts) nil = skipn (length L) Y.
    Proof.
      clear. intros. subst.
      erewrite ListFacts.skipn_length_gt; auto. unfold typeof_env in *. rewrite map_length in H0. omega.
    Qed.
    Hint Resolve env_nil_by_length_eq : env_resolution.

    Lemma all2_tvar_seq_dec_true : forall a b,
      Folds.all2 Expr.tvar_seqb a b = true -> a = b.
    Proof.
      clear; induction a; destruct b; simpl; intros; try congruence.
      consider (tvar_seqb a t); intros; subst. erewrite IHa; auto.
    Qed.

    Lemma sym_evalStream_quant_append : forall path facts qs uvars vars ss res,
      sym_evalStream Prover meval learnHook facts path qs uvars vars ss = res ->
      match res with
        | Safe qs' _
        | SafeUntil qs' _ _ => exists qs'', qs' = appendQ qs'' qs
(*        | Unsafe qs'  *)
      end.
    Proof.
      clear.
      induction path; simpl; intros.
      { inversion H. subst. exists QBase.
        clear. simpl; auto. }
      { destruct a. destruct p. consider (sym_evalInstrs Prover meval facts l ss); intros; try congruence.
        eapply IHpath; eauto. destruct p. subst. exists QBase. auto.
        destruct s. destruct o. consider (sym_assertTest Prover meval facts s t s0 ss b); intros.
        repeat match goal with
                 | [ H : match ?X with (_,_) => _ end = _ |- _ ] => destruct X; try congruence
               end.
        eapply IHpath in H0. destruct res; auto; destruct H0; rewrite <- appendQ_assoc in H0; eauto.
        subst; auto. exists QBase; auto.
        repeat match goal with
                 | [ H : match ?X with _ => _ end = _ |- _ ] => destruct X; try congruence
               end; subst;
        try eapply IHpath; eauto.
        exists QBase; auto.
        exists QBase; auto. }
    Qed.

    Hint Extern 1 (@eq (list tvar) _ _) =>
      simpl; repeat (rewrite app_nil_r in * || rewrite typeof_env_app in * || rewrite app_ass ||
        (f_equal; []) || (f_equal; [ solve [ reflexivity | assumption ] | ] || reflexivity || assumption)) : env_resolution.

    Definition NO_MORE_COND : Prop := True.

    Ltac sym_eval_prover IHpath :=
      repeat match goal with
               | [ H : Valid _ (?A ++ ?b) (?C ++ ?d) _
                 , H' : sym_instrsD ?X ?A ?C ?Y = ?Z |- _ ] =>
                 apply sym_instrsD_weaken with (B := b) (D := d) in H'
               | [ H : Valid _ (?A ++ ?b) (?C ++ ?d) _
                 , H' : istreamD ?X ?A ?C ?Y ?Z ?P ?L |- _ ] =>
                 apply istreamD_weaken with (B := b) (D := d) in H'
               | [ H : (_,_) = (_,_) |- _ ] => inversion H; clear H; subst
               | [ H : Some _ = Some _ |- _ ] => inversion H; clear H; subst
               | [ H : Safe _ _ = Safe _ _ |- _ ] => inversion H; clear H; subst
               | [ H : SafeUntil _ _ _ = SafeUntil _ _ _ |- _ ] => inversion H; clear H; subst
               | [ H : inl _ = inl _ |- _ ] => inversion H; clear H; subst
               | [ H : inr _ = inr _ |- _ ] => inversion H; clear H; subst
               | [ H : SymAssertCond _ _ _ _ = SymAssertCond _ _ _ _ |- _ ] => inversion H; clear H; subst
               | [ H : sum (prod _ _) _ |- _ ] => destruct H as [ [ ? ? ] | ? ]
               | [ H : ?X = _ , H' : ?X = _ |- _ ] => rewrite H in H'
               | [ H : option state |- _ ] => destruct H
               | [ H : _ /\ _ |- _ ] => destruct H
               | [ H : ?X = _ , H' : context [ match ?X with _ => _ end ] |- _ ] =>
                 rewrite H in H'
               | [ H : match ?X with _ => _ end |- _ ] =>
                 (revert H; case_eq X; intros; try contradiction); []
               | [ |- _ ] => progress (repeat rewrite app_nil_r in * )
               | [ |- _ ] => solve [ congruence | eauto with stateD_solver ]
               | [ H : ?X -> _ , H' : ?X |- _ ] =>
                 match type of X with
                   | Prop =>
                     specialize (H H')
                 end
               | [ H   : sym_evalInstrs _ _ ?F ?is ?S = _
                 , H'  : evalInstrs ?stn ?st _ = _
                 , H'' : sym_instrsD _ ?U ?G _ = Some ?isD
                 , Hst : stateD _ _ _ _ _ _ _
                 |- _ ] =>
               ( eapply sym_evalInstrs_correct with (stn_st := (stn,st)) (facts := F) (ss := S) in H'' ; eauto ;
                 simpl in H'' ) ; [ clear Hst ]
               | [ H : Structured.evalCond ?l ?A ?r ?B ?C = _
                 , Hst : stateD _ _ ?U ?G ?cs _ _
                 , H' : sym_rvalueD _ _ _ _ = Some ?l
                 , H'' : sym_rvalueD _ _ _ _ = Some ?r |- _ ] =>
               match goal with
                 | [ H : NO_MORE_COND |- _ ] => fail 1
                 | _ =>
                   (generalize Hst; eapply sym_assertTest_correct' with (meta_env := U) (vars_env := G) (t := A) (rD := l) (lD := r) (stn_st := (B,C)) in Hst; eauto using sym_rvalueD_weaken) ; [ intro; simpl in Hst ; assert NO_MORE_COND by (exact I) ]
               end
               | [ H : learnHook _ ?U' ?G' ?SS ?f ?F = (?A, ?B)
                 , H' : stateD _ _ ?U ?G _ _ _
                 , LC : MEVAL.LearnHook_correct _ _ _ _ _ _
                 , PC : ProverT_correct _ _ |- _ ] =>
                 (cutrewrite (U' = typeof_env U) in H; [ | rewrite typeof_env_app; f_equal; auto ] ;
                  cutrewrite (G' = typeof_env G) in H; [ | rewrite typeof_env_app; f_equal; auto ] ;
                  eapply (@MEVAL.hook_sound _ _ _ _ _ _ _ _ LC _ PC U G) with
                    (new_facts := F) (ss := SS) (ss' := A) (quant := B) in H ;
                  eauto using Learn_correct, AllProvable_cons, AllProvable_nil with stateD_solver) ; [ clear H' ]
               | [ H : quantD _ _ _ _ |- quantD _ _ _ _ ] =>
                 eapply quantD_impl; [ eapply H | clear H ; simpl; intros ]
               | [ |- quantD _ _ (appendQ _ ?X) _ ] =>
                 apply quantD_app
               | [ H : appendQ _ _ = appendQ _ _ |- _ ] => apply appendQ_proper in H; subst

               | [ H : appendQ ?A ?B = appendQ _ (appendQ _ ?B) |- _ ] =>
                 rewrite <- appendQ_assoc in H; apply appendQ_proper in H; subst
               | [ H : context [ Safe (appendQ (appendQ ?A ?B) ?C) _ ] |- _ ] =>
                 rewrite appendQ_assoc with (a := A) (b := B) (c := C) in H
               | [ H : context [ SafeUntil (appendQ (appendQ ?A ?B) ?C) _ _ ] |- _ ] =>
                 rewrite appendQ_assoc with (a := A) (b := B) (c := C) in H

               | [ H : sym_evalStream _ _ _ _ _ (appendQ _ ?X) _ _ _ = Safe (appendQ ?Y ?X) _ |- _ ] =>
                 match Y with
                   | appendQ _ _ => fail 1
                   | _ => destruct (sym_evalStream_quant_append _ _ _ _ _ _ H); subst
                 end
               | [ H : sym_evalStream _ _ _ _ _ (appendQ _ (appendQ _ ?X)) _ _ _ = Safe (appendQ ?Y ?X) _ |- _ ] =>
                 match Y with
                   | appendQ _ _ => fail 1
                   | _ => rewrite <- appendQ_assoc in H; destruct (sym_evalStream_quant_append _ _ _ _ _ _ H); subst
                 end
               | [ H : sym_evalStream _ _ _ _ _ (appendQ _ ?X) _ _ _ = SafeUntil (appendQ ?Y ?X) _ _ |- _ ] =>
                 match Y with
                   | appendQ _ _ => fail 1
                   | _ => destruct (sym_evalStream_quant_append _ _ _ _ _ _ H); subst
                 end
               | [ H : sym_evalStream _ _ _ _ _ (appendQ _ (appendQ _ ?X)) _ _ _ = SafeUntil (appendQ ?Y ?X) _ _ |- _ ] =>
                 match Y with
                   | appendQ _ _ => fail 1
                   | _ => rewrite <- appendQ_assoc in H; destruct (sym_evalStream_quant_append _ _ _ _ _ _ H); subst
                 end
               | [ H : EqNat.beq_nat ?X ?Y = true |- _ ] =>
                 symmetry in H; apply EqNat.beq_nat_eq in H
               | [ H : Folds.all2 _ _ _ = true |- _ ] =>
                 eapply all2_tvar_seq_dec_true in H
               | [ H : sym_evalStream _ _ _ _ _ ?QS _ _ _ = _
                 , H' : stateD _ _ ?Uall ?Gall _ (_, ?st) _
                 , H'' : istreamD _ _ _ _ _ ?st _
                 |- _ ] =>
               let t := change (QS) with (appendQ QBase QS) in H at 1 ;
                 eapply IHpath with (env_q := QS) (qs := QBase) (meta_env := Uall) (vars_env := Gall) in H;
                   simpl; subst; intuition (eauto using istreamD_weaken, Valid_weaken with env_resolution) in
               solve [ t ] || (t; [])
               | [ H : forall res : bool, match sym_assertTest _ _ _ _ _ _ _ res with _ => _ end |- _ ] =>
                 specialize (H true); unfold sym_assertTest in H
               | [ H : match ?X with | IL.Eq => _ | _ => _ end = None |- _ ] =>
                 destruct X; congruence
               | [ H : exists x : state, _ |- exists y : state, _ ] =>
                 let s := fresh "st" in
                 solve [ destruct H as [ s ? ] ; exists s ; intuition ]
               | [ H : match ?X with _ => _ end |- _ ] =>
                 (revert H; case_eq X; intros; try contradiction)
               | [ H : match ?X with _ => _ end = _ |- _ ] =>
                 (revert H; case_eq X; intros; try split_congruence)
               | [ H : sym_rvalueD _ _ _ _ = _ |- context [ sym_rvalueD _ _ _ _ ] ] =>
                   erewrite sym_rvalueD_weaken by eauto
               | [ H : option bool |- _ ] => destruct H
             end.

    Lemma evalStream_correct_Safe : forall sound_or_safe cs stn path facts ss qs qs' ss' uvars vars env_q,
      sym_evalStream Prover meval learnHook facts path (appendQ qs env_q) uvars vars ss = Safe (appendQ qs' env_q) ss' ->
      forall meta_env vars_env,
        typeof_env meta_env ++ gatherAll qs = uvars ->
        typeof_env vars_env ++ gatherEx qs = vars ->
        forall st,
          istreamD funcs meta_env vars_env path stn st sound_or_safe ->
        quantD vars_env meta_env qs (fun vars_env meta_env =>
          stateD funcs preds meta_env vars_env cs (stn,st) ss /\
          Valid PC meta_env vars_env facts) ->
        quantD vars_env meta_env qs' (fun vars_env meta_env =>
          match sound_or_safe with
            | None => False
            | Some (st') =>
              stateD funcs preds meta_env vars_env cs (stn, st') ss'
          end).
    Proof.
      Opaque stateD.
      induction path; simpl; intros; sym_eval_prover IHpath; try contradiction.
    Qed.

    Lemma evalStream_correct_SafeUntil : forall sound_or_safe cs stn path facts ss qs qs' ss' is' uvars vars env_q,
      sym_evalStream Prover meval learnHook facts path (appendQ qs env_q) uvars vars ss = SafeUntil (appendQ qs' env_q) ss' is' ->
      forall meta_env vars_env,
        typeof_env meta_env ++ gatherAll qs = uvars ->
        typeof_env vars_env ++ gatherEx qs = vars ->
        forall st,
          istreamD funcs meta_env vars_env path stn st sound_or_safe ->
        quantD vars_env meta_env qs (fun vars_env meta_env =>
          stateD funcs preds meta_env vars_env cs (stn,st) ss /\
          Valid PC meta_env vars_env facts) ->
        quantD vars_env meta_env qs' (fun vars_env meta_env =>
          exists st' : state,
          stateD funcs preds meta_env vars_env cs (stn, st') ss' /\
          istreamD funcs meta_env vars_env is' stn st' sound_or_safe).
    Proof.
      induction path; simpl; intros; sym_eval_prover IHpath; try contradiction.
    Qed.

(*
    Theorem evalStream_correct : forall sound_or_safe cs stn path facts ss qs env_q uvars vars res,
      sym_evalStream Prover meval learnHook facts path (appendQ qs env_q) uvars vars ss = res ->
      forall meta_env vars_env,
        typeof_env meta_env ++ gatherAll qs = uvars ->
        typeof_env vars_env ++ gatherEx qs = vars ->
        forall st,
          istreamD funcs meta_env vars_env path stn st sound_or_safe ->
        quantD vars_env meta_env qs (fun vars_env meta_env =>
          stateD funcs preds meta_env vars_env cs (stn,st) ss /\
          Valid PC meta_env vars_env facts) ->
        match res with
          | Safe qs' ss' =>
            quantD vars_env meta_env qs' (fun vars_env meta_env =>
              match sound_or_safe with
                | None => False
                | Some (st') => stateD funcs preds meta_env vars_env cs (stn, st') ss'
              end)
          | SafeUntil qs' ss' is' =>
            quantD vars_env meta_env qs' (fun vars_env meta_env =>
              exists st' : state,
                stateD funcs preds meta_env vars_env cs (stn, st') ss' /\
                istreamD funcs meta_env vars_env is' stn st' sound_or_safe)
        end.
    Proof.
      destruct res; intros.
      { destruct (sym_evalStream_quant_append _ _ _ _ _ _ H).
        generalize (@evalStream_correct_Safe sound_or_safe cs stn path facts ss qs (appendQ x qs) s uvars vars env_q). subst.
        rewrite appendQ_assoc.
        intro. eapply H0 in H; eauto. }
      { destruct (sym_evalStream_quant_append _ _ _ _ _ _ H).
        generalize (@evalStream_correct_SafeUntil sound_or_safe cs stn path facts ss qs (appendQ x qs) s i uvars vars QBase);
          subst.
        repeat rewrite appendQ_QBase_r. intro. eapply H0 in H; eauto. }
    Qed.
*)
  End typed2.

End SymIL_Correct.


Require Import Program.Basics Lia.
From PromisingLib Require Import Language.
From hahn Require Import Hahn.
From imm Require Import
     AuxDef
     Events Execution TraversalConfig Traversal
     Prog ProgToExecution ProgToExecutionProperties imm_s imm_s_hb
     SimState
     CertExecution2
     CombRelations SimTraversal SimTraversalProperties.
Require Import AuxRel.
Require Import AuxDef.
Require Import EventStructure.
Require Import Consistency.
Require Import Execution.
Require Import EventToAction.
Require Import LblStep.
Require Import ImmProperties.
Require Import CertGraph.
Require Import CertRf.
Require Import SimRelCont.
Require Import SimRelEventToAction.
Require Import SimRel.
Require Import ProgES.

Set Implicit Arguments.
Local Open Scope program_scope.

Section SimRelCert.
  Variable prog : stable_prog_type.
  Variable S : ES.t.
  Variable G : execution.
  Variable sc : relation actid.
  Variable TC : trav_config.
  Variable TC': trav_config.
  Variable X : eventid -> Prop.
  Variable T : thread_id -> Prop.
  Variable k : cont_label.

  (* A state in a continuation related to k in S. *)
  Variable st : ProgToExecution.state.

  (* A state, which is reachable from 'state' and which represents a graph certification. *)
  Variable st' : ProgToExecution.state.

  Notation "'SE'" := S.(ES.acts_set).
  Notation "'SEinit'" := S.(ES.acts_init_set).
  Notation "'SEninit'" := S.(ES.acts_ninit_set).
  Notation "'Stid'" := (S.(ES.tid)).
  Notation "'Slab'" := (S.(ES.lab)).
  Notation "'Sloc'" := (loc S.(ES.lab)).
  Notation "'K'" := S.(ES.cont_set).

  Notation "'STid' t" := (fun x => Stid x = t) (at level 1).
  Notation "'SNTid' t" := (fun x => Stid x <> t) (at level 1).

  Notation "'SR'" := (fun a => is_true (is_r Slab a)).
  Notation "'SW'" := (fun a => is_true (is_w Slab a)).
  Notation "'SF'" := (fun a => is_true (is_f Slab a)).
  Notation "'SRel'" := (fun a => is_true (is_rel Slab a)).
  Notation "'SAcq'" := (fun a => is_true (is_acq Slab a)).

  Notation "'Ssb'" := (S.(ES.sb)).
  Notation "'Scf'" := (S.(ES.cf)).
  Notation "'Sicf'" := (S.(ES.icf)).
  Notation "'Srmw'" := (S.(ES.rmw)).
  Notation "'Sjf'" := (S.(ES.jf)).
  Notation "'Sjfi'" := (S.(ES.jfi)).
  Notation "'Sjfe'" := (S.(ES.jfe)).
  Notation "'Srf'" := (S.(ES.rf)).
  Notation "'Srfi'" := (S.(ES.rfi)).
  Notation "'Srfe'" := (S.(ES.rfe)).
  Notation "'Sco'" := (S.(ES.co)).
  Notation "'Sew'" := (S.(ES.ew)).

  Notation "'Srs'" := (S.(Consistency.rs)).
  Notation "'Srelease'" := (S.(Consistency.release)).
  Notation "'Ssw'" := (S.(Consistency.sw)).
  Notation "'Shb'" := (S.(Consistency.hb)).
  Notation "'Secf'" := (S.(Consistency.ecf)).

  Notation "'e2a'" := (e2a S).

  Notation "'thread_syntax' t"  :=
    (Language.syntax (thread_lts t)) (at level 10, only parsing).

  Notation "'thread_st' t" :=
    (Language.state (thread_lts t)) (at level 10, only parsing).

  Notation "'thread_init_st' t" :=
    (Language.init (thread_lts t)) (at level 10, only parsing).

  Notation "'thread_cont_st' t" :=
    (fun st => existT _ (thread_lts t) st) (at level 10, only parsing).

  Notation "'GE'" := G.(acts_set).
  Notation "'GEinit'" := (is_init ∩₁ GE).
  Notation "'GEninit'" := ((set_compl is_init) ∩₁ GE).

  Notation "'Glab'" := (Execution.lab G).
  Notation "'Gloc'" := (Events.loc (lab G)).
  Notation "'Gtid'" := (Events.tid).

  Notation "'GTid' t" := (fun x => Gtid x = t) (at level 1).
  Notation "'GNTid' t" := (fun x => Gtid x <> t) (at level 1).

  Notation "'GR'" := (fun a => is_true (is_r Glab a)).
  Notation "'GW'" := (fun a => is_true (is_w Glab a)).
  Notation "'GF'" := (fun a => is_true (is_f Glab a)).

  Notation "'GRel'" := (fun a => is_true (is_rel Glab a)).
  Notation "'GAcq'" := (fun a => is_true (is_acq Glab a)).

  Notation "'Gsb'" := (Execution.sb G).
  Notation "'Grmw'" := (Execution.rmw G).
  Notation "'Grf'" := (Execution.rf G).
  Notation "'Gco'" := (Execution.co G).

  Notation "'Grs'" := (imm_s_hb.rs G).
  Notation "'Grelease'" := (imm_s_hb.release G).
  Notation "'Gsw'" := (imm_s_hb.sw G).
  Notation "'Ghb'" := (imm_s_hb.hb G).

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

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

  Notation "'Gvf'" := (furr G sc).

  Notation "'kE'" := (ES.cont_sb_dom S k) (only parsing).
  Notation "'ktid'" := (ES.cont_thread S k) (only parsing).
  Notation "'klast'" := (ES.cont_last S k) (only parsing).

  (* Notation "'E0'" := (E0 G TC' ktid). *)

  Notation "'contG'" := st.(ProgToExecution.G).
  Notation "'certG'" := st'.(ProgToExecution.G).

  Notation "'contE'" := contG.(acts_set).
  Notation "'certE'" := certG.(acts_set).

  Notation "'certLab'" := (certLab G st').

  Notation "'certX'" := ((X ∩₁ SNTid ktid) ∪₁ kE) (only parsing).

  Definition Kstate (ll : cont_label) (lstate : ProgToExecution.state) :=
    exists (st : (thread_lts (ES.cont_thread S ll)).(Language.state)),
      ⟪ SSTATE : lstate = st ⟫ /\
      ⟪ KK     : K (ll, existT _ _ st) ⟫.

  Record simrel_cstate :=
    { cstate_stable : stable_state st';
      cstate_cont : Kstate k st;
      cstate_reachable : (lbl_step ktid)＊ st st';
    }.

  Notation "'certC'" := (C' ∩₁ e2a □₁ kE).

  Record simrel_cert :=
    { sim : simrel_consistent prog S G sc TC X (T \₁ eq ktid);

      tr_step : isim_trav_step G sc ktid TC TC' ;

      cert : cert_graph G sc TC' ktid st' ;
      cstate : simrel_cstate ;

      ex_ktid_cov : X ∩₁ STid ktid ∩₁ e2a ⋄₁ C ⊆₁ kE ;
      cov_in_ex   : e2a ⋄₁ C ∩₁ kE ⊆₁ X ;

      kcond : (
        ⟪ klast_ex : klast ⊆₁ X ⟫ /\
        ⟪ kE_sb_cov_iss : e2a □₁ codom_rel (⦗kE⦘ ⨾ Ssb ⨾ ⦗STid ktid⦘) ⊆₁ CsbI G TC ⟫
      ) \/ (
        ⟪ klast_sb_max : klast ⊆₁ max_elt Ssb ⟫ /\
        ⟪ kE_sb_cov_iss : e2a □₁ codom_rel (⦗kE⦘ ⨾ Ssb ⨾ ⦗STid ktid⦘) ⊆₁ CsbI G TC' ⟫
      ) ;

      kE_lab : eq_dom (kE \₁ SEinit) Slab (certG.(lab) ∘ e2a) ;

      jf_kE_in_cert_rf : e2a □ (Sjf ⨾ ⦗kE⦘) ⊆ cert_rf G sc TC' ;

      icf_ex_ktid_in_co :
        e2a □ (Sjf ⨾ ⦗set_compl kE⦘ ⨾ Sicf ⨾ ⦗X ∩₁ STid ktid⦘ ⨾ Sjf⁻¹) ⊆ Gco ;

      icf_kE_in_co :
        e2a □ (Sjf ⨾ Sicf ⨾ ⦗kE⦘ ⨾ Sjf⁻¹) ⊆ Gco ;

      ex_cont_iss : X ∩₁ e2a ⋄₁ (contE ∩₁ I) ⊆₁ dom_rel (Sew ⨾ ⦗ kE ⦘) ;
      kE_iss : kE ∩₁ e2a ⋄₁ I ⊆₁ dom_rel (Sew ⨾ ⦗ X ⦘) ;

      (* e2a_co_kE_iss : e2a □ (Sco ⨾ ⦗kE ∩₁ e2a ⋄₁ I'⦘) ⊆ Gco ;  *)

      e2a_co_kE : e2a □ (Sco ⨾ ⦗kE⦘) ⊆ Gco ;

      e2a_co_ex_ktid : e2a □ (Sco ⨾ ⦗X ∩₁ STid ktid \₁ e2a ⋄₁ contE⦘) ⊆ Gco ;

      rmw_cov_in_kE : Grmw ⨾ ⦗C' ∩₁ e2a □₁ kE⦘ ⊆ e2a □ Srmw ⨾ ⦗ kE ⦘ ;

      contsimstate_kE :
          exists kC (state : thread_st (ES.cont_thread S kC)),
            ⟪ THK   : ES.cont_thread S kC = ktid ⟫ /\
            ⟪ INK   : K (kC, thread_cont_st (ES.cont_thread S kC) state) ⟫ /\
            ⟪ INX   : ES.cont_sb_dom S kC ≡₁ e2a ⋄₁ C' ∩₁ kE ⟫ /\
            ⟪ KINEQ : kE ⊆₁ e2a ⋄₁ C' -> kC = k ⟫ /\
            ⟪ SIMST : @sim_state G sim_normal certC (ES.cont_thread S kC) state ⟫;
    }.

  Section SimRelCertProps.

    Variable SRCC : simrel_cert.

    Lemma cov_in_cert_dom :
      C ⊆₁ cert_dom G TC ktid st.
    Proof. unfold cert_dom. basic_solver. Qed.

    Lemma GEinit_in_cert_dom (TCCOH : tc_coherent G sc TC) :
      GEinit ⊆₁ cert_dom G TC ktid st.
    Proof.
      etransitivity; [|apply cov_in_cert_dom].
      eapply init_covered; eauto.
    Qed.

    Lemma cert_dom_sb_prcl :
      dom_rel (Gsb ⨾ ⦗ cert_dom G TC ktid st ⦘) ⊆₁ cert_dom G TC ktid st.
    Proof.
      assert (tc_coherent G sc TC) as TCCOH by apply SRCC.
      intros x [y SB].
      destruct_seq_r SB as YY.
      set (ESB := SB).
      destruct_seq ESB as [XE YE].
      destruct YY as [[YY|[YY NTID]]|YY].
      { apply cov_in_cert_dom. eapply dom_sb_covered; eauto.
        eexists. apply seq_eqv_r. eauto. }
      { set (CC := SB). apply sb_tid_init in CC. desf.
        { left. right. split. 2: by rewrite CC.
          generalize (@sb_trans G) SB YY. basic_solver 10. }
        apply cov_in_cert_dom. eapply init_covered; eauto.
        split; auto. }
      destruct (classic (is_init x)) as [NN|NINIT].
      { apply cov_in_cert_dom. eapply init_covered; eauto.
        split; auto. }
      right.
      edestruct cstate_cont as [lstate]; [apply SRCC|]. desf.
      assert (wf_thread_state (ES.cont_thread S k) lstate) as WFT.
      { eapply contwf; [by apply SRCC|]. apply KK. }
      eapply acts_rep in YY; eauto.
      destruct YY as [yin [REP LE]].
      rewrite REP in *.
      destruct x; desf.
      red in ESB. desf.
      apply acts_clos; auto.
      { by subst thread. }
      etransitivity; eauto.
    Qed.

    Lemma ktid_ninit :
      ktid <> tid_init.
    Proof.
      edestruct cstate_cont; [apply SRCC|].
      desc. subst x.
      intros kTID.
      edestruct ES.init_tid_K; [apply SRCC|].
      do 2 eexists. splits; eauto.
    Qed.

    Lemma cstate_covered :
      C ∩₁ GTid ktid ⊆₁ contE.
    Proof.
      edestruct cstate_cont; [apply SRCC|].
      desc. subst x.
      intros x [Cx TIDx].
      eapply e2a_kEninit; eauto; try apply SRCC.
      assert ((e2a □₁ X) x) as Xx.
      { eapply ex_cov_iss; [apply SRCC|]. red. basic_solver. }
      destruct Xx as [x' [Xx' EQx]]. subst x.
      unfolder; eexists; splits; eauto.
      { eapply ex_ktid_cov; auto.
        unfolder; splits; auto.
        by erewrite e2a_tid. }
      intros INITx.
      apply ktid_ninit.
      rewrite <- TIDx.
      erewrite <- e2a_tid.
      apply INITx.
    Qed.

    Lemma wf_cont_state :
      wf_thread_state ktid st.
    Proof.
      edestruct cstate_cont.
      { apply SRCC. }
      eapply contwf; eauto.
      apply SRCC. desf.
    Qed.

    Lemma wf_cert_state :
      wf_thread_state ktid st'.
    Proof.
      eapply wf_thread_state_lbl_steps.
      { eapply wf_cont_state. }
      apply SRCC.
    Qed.

    Lemma thread_event_ge_ncov idx (ge : idx >= eindex st) :
      ~ C (ThreadEvent ktid idx).
    Proof.
      intros Cx.
      assert ((C ∩₁ GTid ktid) (ThreadEvent ktid idx)) as HH.
      { split; auto. }
      eapply cstate_covered in HH; eauto.
      eapply acts_rep in HH; desc.
      2 : eapply wf_cont_state; eauto.
      inversion REP. lia.
    Qed.

    Lemma e2a_ge_ncov e
          (Se : SE e)
          (TIDe : Stid e = ktid)
          (SEQNe : ES.seqn S e >= eindex st) :
      ~ C (e2a e).
    Proof.
      intros Ce.
      erewrite e2a_ninit in Ce.
      { eapply thread_event_ge_ncov; eauto.
        congruence. }
      split; auto.
      intros [_ INITe].
      eapply ktid_ninit.
      congruence.
    Qed.

    Lemma trav_step_cov_sb_iss_le :
      C ∪₁ dom_rel (Gsb^? ⨾ ⦗I⦘) ⊆₁ C' ∪₁ dom_rel (Gsb^? ⨾ ⦗I'⦘).
    Proof.
      erewrite sim_trav_step_covered_le,
               sim_trav_step_issued_le.
      2,3: eexists; apply SRCC.
      done.
    Qed.

    Lemma trav_step_cov_sb_iss_tid :
      C' ∪₁ dom_rel (Gsb^? ⨾ ⦗I'⦘) ≡₁
         (C ∪₁ dom_rel (Gsb^? ⨾ ⦗I⦘)) ∩₁ GNTid ktid ∪₁
         (C' ∪₁ dom_rel (Gsb^? ⨾ ⦗I'⦘)) ∩₁ GTid ktid.
    Proof.
      edestruct isim_trav_step_new_e_tid_alt as [HA HB].
      1-2 : apply SRCC.
      apply set_subset_union_l in HA.
      destruct HA as [HAC HAI].
      split.
      { rewrite crE at 1. relsf. splits.
        { intros x Cx.
          apply HAC in Cx.
          generalize Cx. basic_solver 10. }
        { intros x Ix.
          apply HAI in Ix.
          generalize Ix. basic_solver 10. }
        rewrite seq_eqv_r.
        intros x [y [SB Iy]].
        edestruct tid_set_dec
          with (thread := ktid)
          as [_ Htid].
        edestruct sb_tid_init as [EQtid | INITx]; eauto.
        { specialize (Htid y (Logic.I)).
          destruct Htid as [Htid | Htid].
          { do 2 right. split.
            { exists y. basic_solver. }
            congruence. }
          apply HAI in Iy.
          destruct Iy as [[[Cy | Iy] _] | [_ TIDy]].
          { do 2 left. split.
            { eapply dom_sb_covered.
              { apply SRCC. }
              basic_solver 10. }
            basic_solver. }
          { left. right. split.
            { basic_solver 10. }
            congruence. }
          exfalso. done. }
        do 2 left. split.
        { eapply init_covered.
          { apply SRCC. }
          split; auto.
          apply wf_sbE in SB.
          generalize SB. basic_solver. }
        apply is_init_tid in INITx.
        rewrite INITx.
        intros HH. by eapply ktid_ninit. }
      rewrite set_subset_union_l. splits.
      { erewrite sim_trav_step_covered_le,
                 sim_trav_step_issued_le.
        2,3 : eexists; apply SRCC.
        basic_solver 10. }
      basic_solver 5.
    Qed.

    Lemma cert_dom_cov_sb_iss :
      cert_dom G TC ktid st' ≡₁ C' ∪₁ dom_rel (Gsb^? ⨾ ⦗I'⦘).
    Proof.
      rewrite cert_dom_alt.
      { rewrite dcertE; [|apply SRCC].
        rewrite trav_step_cov_sb_iss_tid.
        unfold CsbI. basic_solver 10. }
      etransitivity.
      { apply cstate_covered; eauto. }
      eapply steps_preserve_E.
      { eapply wf_cont_state. }
      apply lbl_steps_in_steps.
      apply SRCC.
    Qed.

    Lemma tccoh' :
      tc_coherent G sc TC'.
    Proof. eapply isim_trav_step_coherence; apply SRCC. Qed.

    Lemma kE_inE :
      kE ⊆₁ SE.
    Proof.
      edestruct cstate_cont; [apply SRCC|].
      desc. subst x.
      intros x kSBx.
      eapply ES.cont_sb_domE; eauto.
      apply SRCC.
    Qed.

    Lemma SEinit_in_kE :
      SEinit ⊆₁ kE.
    Proof.
      eapply ES.cont_sb_dom_Einit; [apply SRCC|].
      edestruct cstate_cont; [apply SRCC|].
      desf. apply KK.
    Qed.

    Lemma GEinit_in_e2a_kE :
      GEinit ⊆₁ e2a □₁ kE.
    Proof.
      erewrite <- e2a_same_Einit.
      2-4: by eapply SRCC.
      apply set_collect_mori; auto.
      by apply SEinit_in_kE.
    Qed.

    Lemma cert_ex_inE :
      certX ⊆₁ SE.
    Proof.
      unionL.
      { rewrite Execution.ex_inE
          with (X := X); [|apply SRCC].
        basic_solver. }
      edestruct cstate_cont; [apply SRCC|]. desc.
      eapply ES.cont_sb_domE; eauto.
      apply SRCC.
    Qed.

    Lemma init_in_cert_ex :
      SEinit ⊆₁ certX.
    Proof.
      assert (ES.Wf S) as WFS by apply SRCC.
      assert (Execution.t S X) as EXEC by apply SRCC.
      edestruct cstate_cont as [st_ [stEQ KK]];
        [apply SRCC|].
      red in stEQ, KK. subst st_.
      rewrite ES.cont_sb_dom_Einit; eauto.
      basic_solver.
    Qed.

    Lemma ex_cov_in_certX :
      X ∩₁ e2a ⋄₁ C ⊆₁ certX.
    Proof.
      rewrite set_unionC.
      erewrite ES.set_split_Tid with
          (S := S) (X := X) (t := ktid) at 1.
      rewrite set_inter_union_l.
      apply set_union_Proper.
      { by apply ex_ktid_cov. }
      basic_solver.
    Qed.

    Lemma cert_ex_certD :
      e2a □₁ certX ≡₁ cert_dom G TC ktid st.
    Proof.
      assert (ES.Wf S) as WFS.
      { apply SRCC. }
      assert (Execution.t S X) as EXEC.
      { apply SRCC. }
      edestruct cstate_cont; [apply SRCC|].
      desc. subst x.
      rewrite cert_dom_alt.
      2 : apply cstate_covered; apply SRCC.
      rewrite set_collect_union.
      rewrite e2a_kE; eauto; try apply SRCC.
      rewrite <- set_unionA.
      erewrite set_union_absorb_r
        with (s := GEinit).
      { rewrite ex_NTid.
        apply set_union_Propere; auto.
        apply set_inter_Propere; auto.
        eapply ex_cov_iss. apply SRCC. }
      rewrite <- e2a_same_Einit; try apply SRCC.
      apply set_collect_mori; auto.
      apply set_subset_inter_r. split.
      { by apply Execution.init_in_ex. }
      intros x [_ NTIDx] TIDx.
      eapply ktid_ninit.
      congruence.
    Qed.

    Lemma ex_in_certD :
      e2a □₁ X ⊆₁ cert_dom G TC ktid st'.
    Proof.
      assert (ES.Wf S) as WFS.
      { apply SRCC. }
      assert (Execution.t S X) as EXEC.
      { apply SRCC. }
      assert (simrel prog S G sc TC X (T \₁ eq ktid)) as SR_.
      { apply SRCC. }
      rewrite ex_cov_iss; eauto.
      rewrite cert_dom_cov_sb_iss.
      apply trav_step_cov_sb_iss_le.
    Qed.

    Lemma ex_in_e2a_certD :
      X ⊆₁ e2a ⋄₁ cert_dom G TC ktid st'.
    Proof.
      rewrite set_in_map_collect
        with (s := X) (f := e2a).
      by rewrite ex_in_certD.
    Qed.

    Lemma ex_cov_iss_cert_lab :
      eq_dom (X ∩₁ e2a ⋄₁ (C ∪₁ I)) Slab (certLab ∘ e2a).
    Proof.
      intros x [Xx e2aCsbIx].
      erewrite ex_cov_iss_lab;
        [ | apply SRCC | done].
      unfold compose.
      symmetry. eapply cslab.
      { apply SRCC. }
      eapply CI_in_D.
      eapply isim_trav_step_new_e_tid.
      1,2: apply SRCC.
      basic_solver.
    Qed.

    Lemma kE_cert_lab :
      eq_dom kE Slab (certLab ∘ e2a).
    Proof.
      assert (ES.Wf S) as WFS.
      { apply SRCC. }
      assert (Execution.t S X) as EXEC.
      { apply SRCC. }
      edestruct cstate_cont; [apply SRCC|].
      desc. subst x.
      intros x kSBx.
      unfold compose.
      assert (SE x) as SEx.
      { by apply kE_inE. }
      assert ((e2a □₁ kE) (e2a x)) as e2akEx.
      { basic_solver. }
      eapply e2a_kE in e2akEx;
        eauto; try apply SRCC.
      destruct e2akEx as [INITx | CONTEx].
      { assert (C (e2a x)) as Cx.
        { eapply init_covered; eauto. apply SRCC. }
        erewrite ex_cov_iss_lab; [| apply SRCC |].
        { erewrite cslab; [auto | apply SRCC |].
          eapply C_in_D.
          eapply SimTraversalProperties.sim_trav_step_covered_le;
            eauto.
          econstructor. apply SRCC. }
        split; [|basic_solver].
        eapply Execution.init_in_ex; eauto.
        set (INITx' := INITx).
        eapply e2a_same_Einit in INITx'; try apply SRCC.
        unfolder in INITx'.
        destruct INITx' as [y [INITy e2aEQ]].
        eapply e2a_map_Einit.
        split; eauto. }
      assert (certE (e2a x)) as CERTEx.
      { eapply steps_preserve_E; eauto.
        { apply wf_cont_state. }
        apply lbl_steps_in_steps.
        apply SRCC. }
      unfold CertGraph.certLab.
      erewrite restr_fun_fst; auto.
      apply kE_lab; auto.
      split; auto.
      intros INITx.
      assert (GEinit (e2a x)) as GINITx.
      { eapply e2a_same_Einit.
        1-2: by apply SRCC.
        basic_solver. }
      edestruct acts_rep.
      { apply wf_cont_state. }
      { apply CONTEx. }
      unfolder in GINITx.
      unfold is_init in GINITx.
      desf.
    Qed.

    Lemma cert_ex_cov_iss_lab :
      eq_dom (certX ∩₁ e2a ⋄₁ (C' ∪₁ I')) Slab (Glab ∘ e2a).
    Proof.
      rewrite set_inter_union_l.
      apply eq_dom_union. split.
      { arewrite (X ∩₁ SNTid ktid ∩₁ e2a ⋄₁ (C' ∪₁ I') ⊆₁
                  X ∩₁ e2a ⋄₁ (C ∪₁ I)).
        { erewrite isim_trav_step_new_e_tid_alt.
          2,3: apply SRCC.
          rewrite set_map_union.
          rewrite set_inter_union_r.
          rewrite set_subset_union_l.
          splits.
          { basic_solver. }
          intros x [[_ nTIDx] [_ TIDx]].
          exfalso. apply nTIDx.
          by rewrite e2a_tid. }
        eapply ex_cov_iss_lab. apply SRCC. }
      intros x [KSBx e2aCsbIx].
      erewrite kE_cert_lab; auto.
      unfold compose.
      erewrite <- cslab
        with (G := G); [auto | apply SRCC|].
      apply CI_in_D.
      basic_solver.
    Qed.

    Lemma cert_ex_cov_iss_cert_lab :
      eq_dom (certX ∩₁ e2a ⋄₁ (C' ∪₁ I')) Slab (certLab ∘ e2a).
    Proof.
      intros x [KSBx e2aCsbIx].
      erewrite cert_ex_cov_iss_lab.
      2 : basic_solver.
      unfold compose.
      erewrite <- cslab;
        [eauto | apply SRCC |].
      apply CI_in_D.
      basic_solver.
    Qed.

    Lemma cert_ex_iss_inW :
      certX ∩₁ e2a ⋄₁ I' ⊆₁ SW.
    Proof.
      intros x [CertXx Ix].
      red in Ix.
      unfold is_w.
      erewrite cert_ex_cov_iss_lab; auto.
      { unfold compose.
        eapply issuedW; eauto.
        apply tccoh'. }
      split; auto.
      basic_solver.
    Qed.

    Lemma ex_ntid_sb_prcl :
      dom_rel (Ssb ⨾ ⦗ X ∩₁ SNTid ktid ⦘) ⊆₁ SEinit ∪₁ X ∩₁ SNTid ktid.
    Proof.
      assert (ES.Wf S) as WFS.
      { apply SRCC. }
      rewrite seq_eqv_r.
      intros x [y [SB [Xx NTIDy]]].
      edestruct ES.NTid_sb_prcl
        as [INITx | NTIDx]; eauto.
      { basic_solver 10. }
      { by left. }
      right. split; auto.
      eapply Execution.ex_sb_prcl; [apply SRCC|].
      basic_solver 10.
    Qed.

    Lemma kE_sb_prcl :
      dom_rel (Ssb ⨾ ⦗ kE ⦘) ⊆₁ kE.
    Proof.
      edestruct cstate_cont; [apply SRCC|].
      eapply ES.cont_sb_prcl; [apply SRCC|].
      desc. apply KK.
    Qed.

    Lemma cert_ex_sb_prcl :
      dom_rel (Ssb ⨾ ⦗ certX ⦘) ⊆₁ certX.
    Proof.
      rewrite id_union.
      relsf. split.
      { rewrite ex_ntid_sb_prcl.
        rewrite init_in_cert_ex.
        basic_solver. }
      rewrite kE_sb_prcl.
      basic_solver.
    Qed.

    Lemma ex_ntid_sb_cov_iss :
      forall t (Tt : (T \₁ eq ktid) t),
        e2a □₁ codom_rel (⦗X⦘ ⨾ Ssb ⨾ ⦗STid t⦘) ⊆₁ CsbI G TC'.
    Proof.
      ins.
      erewrite <- sim_trav_step_CsbI_mon.
      2,3: try eexists; apply SRCC.
      erewrite ex_sb_cov_iss.
      1-2: eauto; apply SRCC.
      done.
    Qed.

    Lemma kE_sb_cov_iss :
      e2a □₁ codom_rel (⦗kE⦘ ⨾ Ssb ⨾ ⦗STid ktid⦘) ⊆₁ CsbI G TC'.
    Proof.
      edestruct kcond; eauto; desc; try done.
      erewrite <- sim_trav_step_CsbI_mon.
      2,3: try eexists; apply SRCC.
      done.
    Qed.

    Lemma cert_ex_sb_cov_iss :
      forall t (Tt : T t),
        e2a □₁ codom_rel (⦗certX⦘ ⨾ Ssb ⨾ ⦗STid t⦘) ⊆₁ CsbI G TC'.
    Proof.
      assert (ES.Wf S) as WFS by apply SRCC.
      assert (Execution.t S X) as EXEC by apply SRCC.
      edestruct cstate_cont as [st_ [stEQ KK]];
        [apply SRCC|].
      red in stEQ, KK. ins.
      rewrite id_union,
              seq_union_l,
              codom_union,
              set_collect_union.
      destruct
        (classic (t = ktid))
        as [EQ|nEQ];
        relsf; split; try subst t.
      { rewrite seq_eqv_lr.
        intros y' [y [HH EQy']].
        destruct HH as [x [[Xx nTIDx] [SB TIDy]]].
        subst y'.
        eapply kE_sb_cov_iss; eauto.
        eexists; split; eauto.
        assert
          (exists e, SEinit e /\ Ssb e y)
          as [e [INITe SB']].
        { assert (SE x) as Ex.
          { eapply Execution.ex_inE; eauto. }
          eapply ES.acts_set_split in Ex.
          destruct Ex as [INITx | nINITx].
          { exists x; split; auto. }
          edestruct ES.exists_acts_init
            as [e INITe]; eauto.
          exists e.
          splits; auto.
          eapply ES.sb_trans; eauto.
          eapply ES.sb_init; eauto.
          split; auto. }
        exists e.
        apply seq_eqv_lr; split; auto.
        eapply ES.cont_sb_dom_Einit; eauto. }
      { eapply kE_sb_cov_iss; eauto. }
      { arewrite
          (SNTid (ES.cont_thread S k) ⊆₁ fun _ => True).
        relsf. eapply ex_ntid_sb_cov_iss.
        basic_solver. }
      erewrite ES.cont_sb_tid; eauto.
      rewrite id_union,
              seq_union_l,
              codom_union,
              set_collect_union.
      rewrite set_subset_union_l. split.
      { erewrite Execution.init_in_ex; eauto.
        eapply ex_ntid_sb_cov_iss; eauto.
        basic_solver. }
      rewrite seq_eqv_lr.
      intros x' [x [HH EQx']].
      destruct HH as [y [nTIDx [SB TIDy]]].
      exfalso.
      assert (Stid y = Stid x)
        as HH; [|congruence].
      eapply ES.sb_tid; eauto.
      unfold ES.acts_ninit_set.
      apply seq_eqv_l; unfolder; splits; auto.
      { apply ES.sbE in SB; auto.
        generalize SB. basic_solver. }
      intros [_ INITy].
      eapply ktid_ninit; eauto.
      congruence.
    Qed.

    Lemma certX_ncf_cont :
      certX ∩₁ ES.cont_cf_dom S k ≡₁ ∅.
    Proof.
      assert (ES.Wf S) as WFS by apply SRCC.
      edestruct cstate_cont as [st_ [stEQ KK]];
        [apply SRCC|].
      red; split; [|done].
      rewrite set_inter_union_l.
      apply set_subset_union_l; split.
      { rewrite ES.cont_cf_Tid_; eauto. basic_solver. }
      eapply ES.cont_sb_cont_cf_inter_false; eauto.
    Qed.

    Lemma cert_ex_ncf :
      ES.cf_free S certX.
    Proof.
      assert (ES.Wf S) as WFS by apply SRCC.
      assert (Execution.t S X) as EXEC by apply SRCC.
      edestruct cstate_cont as [st_ [stEQ KK]];
        [apply SRCC|].
      red in stEQ, KK. subst st_.
      red. rewrite <- restr_relE.
      intros x y [CF [CERTXx CERTXy]].
      destruct CERTXx as [[Xx NTIDx] | kSBx];
      destruct CERTXy as [[Xy NTIDy] | kSBy].
      { eapply Execution.ex_ncf; [apply SRCC|].
        apply restr_relE. red. eauto. }
      { eapply ES.cont_sb_tid in kSBy; eauto.
        destruct kSBy as [INITy | TIDy].
        { eapply Execution.ex_ncf; [apply SRCC|].
          apply restr_relE. red. splits; eauto.
          eapply Execution.init_in_ex; eauto. }
        apply NTIDx.
        erewrite ES.cf_same_tid; eauto. }
      { eapply ES.cont_sb_tid in kSBx; eauto.
        destruct kSBx as [INITx | TIDx].
        { eapply Execution.ex_ncf; [apply SRCC|].
          apply restr_relE. red. splits; eauto.
          eapply Execution.init_in_ex; eauto. }
        apply NTIDy.
        erewrite ES.cf_same_tid; eauto.
        by apply ES.cf_sym. }
      eapply ES.cont_sb_cf_free; eauto.
      apply seq_eqv_lr. eauto.
    Qed.

  Lemma jf_cert_ex_in_cert_rf :
    e2a □ (Sjf ⨾ ⦗certX⦘) ⊆ cert_rf G sc TC'.
  Proof.
    rewrite id_union.
    relsf. unionL.
    2 : apply jf_kE_in_cert_rf; auto.
    rewrite <- set_interK
      with (s := X).
    rewrite set_interA, <- seq_eqv.
    rewrite <- seqA.
    rewrite collect_rel_seqi,
    collect_rel_eqv.
    rewrite jf_ex_in_cert_rf;
      [|apply SRCC].
    erewrite ex_NTid.
    arewrite (e2a □₁ X ⊆₁ fun _ => True).
    relsf.
    eapply isim_trav_step_cert_rf_ntid;
      try apply SRCC.
    apply ktid_ninit; auto.
  Qed.

  Lemma icf_certX_in_co :
    forall t (Tt : T t),
      e2a □ (Sjf ⨾ Sicf ⨾ ⦗certX ∩₁ STid t⦘ ⨾ Sjf⁻¹) ⊆ Gco.
  Proof.
    intros t Tt.
    rewrite set_inter_union_l.
    rewrite id_union.
    relsf. unionL.
    { destruct (classic (t = ktid))
        as [EQ|nEQ].
      { basic_solver. }
      arewrite (SNTid ktid ⊆₁ fun _ => True).
      relsf.
      eapply icf_ex_in_co; [apply SRCC|].
      basic_solver. }
    arewrite (STid t ⊆₁ fun _ => True).
    relsf.
    eapply icf_kE_in_co; eauto.
  Qed.

  Lemma ew_ex_cert_dom_iss_cert_ex_iss :
    dom_rel (Sew ⨾ ⦗X ∩₁ e2a ⋄₁ (cert_dom G TC ktid st ∩₁ I)⦘) ≡₁
    dom_rel (Sew ⨾ ⦗certX ∩₁ e2a ⋄₁ I⦘).
  Proof.
    assert (ES.Wf S) as WFS.
    { apply SRCC. }
    assert (Execution.t S X) as EXEC.
    { apply SRCC. }
    assert (simrel prog S G sc TC X (T \₁ eq ktid)) as SR_.
    { apply SRCC. }
    rewrite cert_dom_alt.
    2 : apply cstate_covered.
    split.

    { rewrite !set_map_inter,
      !set_map_union,
      !set_map_inter.
      rewrite !set_inter_union_l,
      !set_inter_union_r.
      rewrite id_union. relsf.
      splits.
      { rewrite !seq_eqv_r with (r := Sew).
        intros x [y [EW [Xx [[_ nTIDx] Ix]]]].
        exists y; splits; auto.
        unfolder; left; splits; auto.
        intros TIDy. apply nTIDx.
        erewrite <- e2a_tid; eauto. }
      rewrite !seq_eqv_r with (r := Sew).
      intros x [y [EW [Xx [CONTx Ix]]]].
      edestruct ex_cont_iss
        as [z HH]; eauto.
      { unfolder; split; eauto. }
      apply seq_eqv_r in HH.
      destruct HH as [EW' kSB].
      exists z; splits; auto.
      { eapply ES.ew_trans; eauto. }
      unfolder; right; splits; auto.
      arewrite (e2a z = e2a y); auto.
      symmetry.
      eapply e2a_ew; eauto.
      { apply SRCC. }
      basic_solver 10. }

    rewrite set_inter_union_l, id_union.
    rewrite seq_union_r, dom_union.
    unionL.
    { rewrite !seq_eqv_r with (r := Sew).
      intros x [y [EW [[Xx nTIDx] Ix]]].
      exists y; splits; auto.
      split; auto.
      split; auto.
      left; split; auto.
      { eapply ex_cov_iss; eauto. basic_solver. }
      intros TIDx. apply nTIDx.
      erewrite e2a_tid; eauto. }
    rewrite !seq_eqv_r with (r := Sew).
    intros x [y [EW [kSBy Iy]]].
    edestruct kE_iss
      as [z HH]; eauto.
    { unfolder; split; eauto. }
    apply seq_eqv_r in HH.
    destruct HH as [EW' Xz].
    exists z; splits; auto.
    { eapply ES.ew_trans; eauto. }
    split; auto.
    assert (e2a z = e2a y) as EQzy.
    { symmetry. eapply e2a_ew; eauto.
      { apply SRCC. }
      basic_solver 10. }
    red; split.
    2 : red in Iy; congruence.
    assert (SE z) as Ez.
    { apply ES.ewE in EW'; auto.
      generalize EW'. basic_solver. }
    set (Ez' := Ez).
    apply ES.acts_set_split in Ez'.
    destruct Ez' as [INITz | nINITz].
    { left; split; try left.
      { eapply init_covered.
        { apply SRCC. }
        eapply e2a_same_Einit.
        1-2: apply SRCC.
        basic_solver. }
      intros TIDz.
      eapply ktid_ninit.
      destruct INITz as [_ INITz].
      rewrite <- TIDz.
      erewrite <- e2a_tid; eauto. }

    right.
    edestruct cstate_cont as [st_ [stEQ KK]];
      [apply SRCC|].
    red in stEQ, KK. subst st_.
    eapply e2a_kEninit; eauto.
    { apply SRCC. }
    exists y; splits; eauto.
    split; auto.
    intros INITy.
    apply nINITz.
    split; auto.
    erewrite <- ES.ew_tid; eauto.
    by destruct INITy as [_ TIDy].
  Qed.

  Lemma e2a_co_cert_ex_tid :
    forall t (Tt : T t),
      e2a □ (Sco ⨾ ⦗certX ∩₁ STid t⦘) ⊆ Gco.
  Proof.
    assert (ES.Wf S) as WFS.
    { apply SRCC. }
    assert (Execution.t S X) as EXEC.
    { apply SRCC. }
    assert (simrel_e2a S G sc) as SRE2A.
    { apply SRCC. }
    assert (simrel prog S G sc TC X (T \₁ eq ktid)) as SR_.
    { apply SRCC. }
    intros t Tt.
    rewrite set_inter_union_l.
    rewrite id_union.
    relsf. unionL.
    { destruct (classic (t = ktid))
        as [EQ|nEQ].
      { basic_solver. }
      arewrite (SNTid ktid ⊆₁ fun _ => True).
      relsf.
      eapply e2a_co_ex_tid; [apply SRCC|].
      basic_solver. }
    arewrite (STid t ⊆₁ fun _ => True).
    relsf.
    eapply e2a_co_kE; eauto.
  Qed.

  Lemma e2a_co_cert_ex_iss :
    e2a □ (Sco ⨾ ⦗certX ∩₁ e2a ⋄₁ I'⦘) ⊆ Gco.
  Proof.
    assert (ES.Wf S) as WFS.
    { apply SRCC. }
    assert (Execution.t S X) as EXEC.
    { apply SRCC. }
    assert (simrel_e2a S G sc) as SRE2A.
    { apply SRCC. }
    assert (simrel prog S G sc TC X (T \₁ eq ktid)) as SR_.
    { apply SRCC. }
    rewrite set_inter_union_l, id_union, seq_union_r,
            collect_rel_union.
    unionL.
    { rewrite seq_eqv_r.
      intros x' y' [x [y [HH [EQx' EQy']]]].
      destruct HH as [CO [[Xy nTIDy] Iy]].
      red in Iy.
      eapply isim_trav_step_new_issued_tid in Iy.
      2-3: apply SRCC.
      destruct Iy as [[Iy _]|[Iy TIDy]].
      { eapply e2a_co_iss; eauto. basic_solver 10. }
      exfalso. apply nTIDy.
      by erewrite e2a_tid. }
    arewrite (e2a ⋄₁ I' ⊆₁ fun _ => True).
    relsf. by eapply e2a_co_kE.
  Qed.

    (* Lemma ex_iss_cert_ex : *)
    (*   X ∩₁ e2a ⋄₁ (cert_dom G TC ktid st ∩₁ I) ⊆₁  *)
    (*     dom_rel (Sew ⨾ ⦗certX ∩₁ e2a ⋄₁ I⦘). *)
    (* Proof.  *)
    (*   assert (ES.Wf S) as WFS. *)
    (*   { apply SRCC. } *)
    (*   assert (Execution.t S X) as EXEC. *)
    (*   { apply SRCC. } *)
    (*   assert (simrel prog S G sc TC X) as SR_. *)
    (*   { apply SRCC. } *)
    (*   rewrite cert_dom_alt. *)
    (*   2 : apply cstate_covered. *)
    (*   rewrite !set_map_inter,  *)
    (*           !set_map_union, *)
    (*           !set_map_inter. *)
    (*   rewrite !set_inter_union_l,  *)
    (*           !set_inter_union_r, *)
    (*           !set_subset_union_l. *)
    (*   rewrite id_union. relsf. *)
    (*   splits. *)
    (*   { intros x [Xx [[_ nTIDx] Ix]]. *)
    (*     left. exists x. *)
    (*     apply seq_eqv_r. *)
    (*     unfold set_inter.  *)
    (*     splits; auto. *)
    (*     { apply ES.ew_refl; auto. *)
    (*       unfolder; splits; auto. *)
    (*       { eapply Execution.ex_inE; eauto. } *)
    (*       eapply ex_iss_inW; eauto. *)
    (*       red. auto. } *)
    (*     intros TIDx. apply nTIDx.  *)
    (*     by rewrite <- e2a_tid. } *)
    (*   intros x [Xx [CONTx Ix]]. *)
    (*   edestruct ex_cont_iss *)
    (*     as [z HH]; eauto. *)
    (*   { unfolder; split; eauto. } *)
    (*   apply seq_eqv_r in HH. *)
    (*   destruct HH as [EW kSB]. *)
    (*   right. exists z. *)
    (*   apply seq_eqv_r. *)
    (*   unfold set_inter. *)
    (*   splits; auto. *)
    (*   red. erewrite e2a_ew; eauto. *)
    (*   { apply SRCC. } *)
    (*   do 2 eexists. splits. *)
    (*   2,3: eauto. *)
    (*   apply ES.ew_sym; auto. *)
    (* Qed. *)

    Lemma rel_ew_cert_ex :
      dom_rel (Srelease ⨾ Sew ⨾ ⦗ certX ⦘) ⊆₁ certX.
    Proof.
      rewrite ew_in_ew_ex_iss_ew; [|apply SRCC].
      rewrite crE, !seq_union_l, !seq_union_r,
              !dom_union, !seqA.
      relsf. split.
      { rewrite rel_in_ex_cov_rel_sb; [|apply SRCC].
        relsf. rewrite !seqA. splits.
        { rewrite dom_seq, dom_eqv.
          apply ex_cov_in_certX. }
        rewrite set_unionC.
        rewrite id_union, !seq_union_r, dom_union.
        rewrite crE, !seq_union_l, !dom_union.
        unionL.
        1,3 : basic_solver.
        { erewrite kE_sb_prcl. basic_solver. }
        erewrite ex_ntid_sb_prcl.
        apply set_union_Proper; auto.
        apply SEinit_in_kE. }
      do 2 rewrite <- seqA.
      rewrite dom_seq, !seqA.
      rewrite rel_ew_ex_iss_cov; [|apply SRCC].
      apply ex_cov_in_certX.
    Qed.

    Lemma cert_ex_sw_prcl :
      dom_rel (Ssw ⨾ ⦗ certX ⦘) ⊆₁ certX.
    Proof.
      assert (ES.Wf S) as WFS.
      { apply SRCC. }
      assert (Execution.t S X) as EXEC.
      { apply SRCC. }
      assert (simrel prog S G sc TC X (T \₁ eq ktid)) as SR_.
      { apply SRCC. }
      rewrite sw_in_ex_cov_sw_sb; eauto.
      relsf. splits.
      2 : apply cert_ex_sb_prcl.
      rewrite seqA, dom_seq, dom_eqv.
      apply ex_cov_in_certX.
    Qed.

    Lemma cert_ex_hb_prcl :
      dom_rel (Shb ⨾ ⦗ certX ⦘) ⊆₁ certX.
    Proof.
      unfold hb.
      rewrite seq_eqv_r.
      intros x [y [HB yX]].
      induction HB as [x y [SSB | SSW] | ]; auto.
      { apply cert_ex_sb_prcl; auto. basic_solver 10. }
      apply cert_ex_sw_prcl; auto. basic_solver 10.
    Qed.

    Lemma hb_rel_ew_cert_ex :
      dom_rel (Shb^? ⨾ Srelease ⨾ Sew ⨾ ⦗ certX ⦘) ⊆₁ certX.
    Proof.
      rewrite crE with (r := Shb).
      relsf. split.
      { by apply rel_ew_cert_ex. }
      intros x [y [z [HB REL]]].
      eapply cert_ex_hb_prcl; auto.
      eexists. apply seq_eqv_r. split; eauto.
      apply rel_ew_cert_ex; auto. basic_solver.
    Qed.

    Lemma jf_kE_in_ew_cert_ex :
      dom_rel (Sjf ⨾ ⦗ kE ⦘) ⊆₁ dom_rel (Sew ⨾ ⦗ certX ⦘).
    Proof.
      assert (ES.Wf S) as WFS by apply SRCC.
      rewrite ES.jfi_union_jfe. relsf. splits.
      { arewrite (Sjfi ≡ ⦗ SE ∩₁ SW ⦘ ⨾ Sjfi).
        { rewrite ES.jfiE, ES.jfiD; auto. basic_solver. }
        rewrite dom_eqv1.
        arewrite (Sjfi ⊆ Ssb).
        rewrite kE_sb_prcl.
        rewrite <- ES.ew_refl; auto.
        basic_solver 10. }
      rewrite !seq_eqv_r.
      intros x [y [JFE KSB]].
      edestruct jfe_ex_iss as [z HH].
      { apply SRCC. }
      { red. eauto. }
      apply seq_eqv_r in HH.
      destruct HH as [EW [Xz Iz]].
      eexists.
      splits; eauto.
      left. split; auto.
      eapply jfe_alt in JFE; auto.
      2 : apply SRCC.
      unfolder in JFE.
      destruct JFE as [nINITx [JF nSTID]].
      intros TIDz. apply nSTID. red.
      arewrite (Stid x = Stid z) by (by apply ES.ew_tid).
      edestruct cstate_cont; [apply SRCC|]. desc.
      eapply ES.cont_sb_tid in KSB; eauto.
      destruct KSB as [INITy | TIDy].
      { exfalso. eapply ES.jf_nEinit; eauto. basic_solver. }
      congruence.
    Qed.

    Lemma kE_rf_compl :
      kE ∩₁ SR ⊆₁ codom_rel (⦗certX⦘ ⨾ Srf).
    Proof.
      assert (ES.Wf S) as WFS by apply SRCC.
      assert (Execution.t S X) as EXEC by apply SRCC.
      edestruct cstate_cont as [st_ [stEQ KK]];
        [apply SRCC|].
      red in stEQ, KK. subst st_.
      intros x [kSBx Rx].
      edestruct ES.jf_complete
        as [y JF]; eauto.
      { split; eauto.
        eapply ES.cont_sb_domE; eauto. }
      edestruct jf_kE_in_ew_cert_ex
        as [z HH].
      { basic_solver 10. }
      apply seq_eqv_r in HH.
      destruct HH as [EW CERTXz].
      exists z. apply seq_eqv_l.
      splits; auto.
      unfold ES.rf.
      unfolder. splits.
      { eexists; splits; eauto.
        by apply ES.ew_sym. }
      intros CF.
      destruct CERTXz as [[Xz nTIDz] | kSBz].
      { eapply ES.cont_sb_tid in kSBx; eauto.
        destruct kSBx as [INITx | TIDx].
        { eapply ES.ncfEinit_r. basic_solver. }
        apply nTIDz.
        apply ES.cf_same_tid in CF.
        congruence. }
      eapply ES.cont_sb_cf_free; eauto.
      basic_solver.
    Qed.

    Lemma cert_ex_necf :
      restr_rel certX Secf ⊆ ∅₂.
    Proof.
      unfold restr_rel, ecf.
      intros a b [ECF [Hx Hy]].
      destruct ECF as [c [tHB [d [CF HB]]]].
      eapply cert_ex_ncf.
      apply restr_relE. unfold restr_rel.
      splits; eauto.
      { unfolder in tHB; desf.
        eapply cert_ex_hb_prcl; auto. basic_solver 10. }
      unfolder in HB; desf.
      eapply cert_ex_hb_prcl; auto. basic_solver 10.
    Qed.

    Lemma ex_cov_ntid_vis :
      X ∩₁ e2a ⋄₁ C ∪₁ X ∩₁ SNTid ktid ⊆₁ vis S.
    Proof.
      rewrite <- set_inter_union_r.
      erewrite <- Execution.ex_vis.
      2: apply SRCC.
      basic_solver.
    Qed.

    Lemma e2a_co_jfe_kE :
      e2a □ Sco ⨾ Sjfe ⨾ ⦗kE⦘ ⊆ Gco ⨾ cert_rf G sc TC'.
    Proof.
      assert (simrel_e2a S G sc) as SRE2A.
      { apply SRCC. }
      assert (simrel prog S G sc TC X (T \₁ eq ktid)) as SR_.
      { apply SRCC. }
      rewrite seq_eqv_r.
      intros x' y' [x [y [HH [EQx' EQy']]]].
      destruct HH as [z [CO [JFE kSB]]].
      subst x' y'.
      exists (e2a z). split.
      { edestruct jfe_ex_iss
          as [z' HH]; eauto.
        { basic_solver. }
        apply seq_eqv_r in HH.
        destruct HH as [EW [Xz' Iz']].
        arewrite (e2a z = e2a z').
        { eapply e2a_ew; eauto. basic_solver 10. }
        eapply e2a_co_ew_iss; eauto.
        basic_solver 10. }
      eapply jf_kE_in_cert_rf; auto.
      exists z, y; splits; auto.
      apply seq_eqv_r.
      splits; auto.
      apply JFE.
    Qed.

  End SimRelCertProps.

End SimRelCert.