Require Import Events.
Require Import Memory.
Require Import Coqlib.
Require Import Values.
Require Import Maps.
Require Import Integers.
Require Import AST.
Require Import Globalenvs.
Require Import Axioms.

Require Import mem_lemmas. (*needed for definition of mem_forward etc*)
Require Import semantics.
Require Import semantics_lemmas.
Require Import effect_semantics.
Require Import structured_injections.
Require Import reach.
Require Import simulations.

(** * Simulations Lemmas *)

(** This file specializes [simulations] in a number of useful ways. *)

Section Eff_INJ_SIMU_DIAGRAMS.
  Context {F1 V1 C1 F2 V2 C2:Type}
          {Sem1 : @EffectSem (Genv.t F1 V1) C1}
          {Sem2 : @EffectSem (Genv.t F2 V2) C2}

          {ge1: Genv.t F1 V1}
          {ge2: Genv.t F2 V2}.

  Let core_data := C1.

  Variable match_states: core_data -> SM_Injection -> C1 -> mem -> C2 -> mem -> Prop.

   Hypothesis genvs_dom_eq: genvs_domain_eq ge1 ge2.

   Hypothesis match_sm_wd: forall d mu c1 m1 c2 m2,
          match_states d mu c1 m1 c2 m2 ->
          SM_wd mu.

    Hypothesis match_visible: forall d mu c1 m1 c2 m2,
          match_states d mu c1 m1 c2 m2 ->
          REACH_closed m1 (vis mu).

    Hypothesis match_restrict: forall d mu c1 m1 c2 m2 X,
          match_states d mu c1 m1 c2 m2 ->
          (forall b, vis mu b = true -> X b = true) ->
          REACH_closed m1 X ->
          match_states d (restrict_sm mu X) c1 m1 c2 m2.

   Hypothesis match_validblocks: forall d mu c1 m1 c2 m2,
          match_states d mu c1 m1 c2 m2 ->
          sm_valid mu m1 m2.

    Hypothesis match_genv: forall d mu c1 m1 c2 m2 (MC:match_states d mu c1 m1 c2 m2),
          meminj_preserves_globals ge1 (extern_of mu) /\
          (forall b, isGlobalBlock ge1 b = true -> frgnBlocksSrc mu b = true).

   Hypothesis inj_initial_cores: forall v vals1 c1 m1 j vals2 m2 DomS DomT,
          initial_core Sem1 ge1 v vals1 = Some c1 ->
          Mem.inject j m1 m2 ->
          Forall2 (val_inject j) vals1 vals2 ->
          meminj_preserves_globals ge1 j ->
          globalfunction_ptr_inject ge1 j ->

        (*the next two conditions are required to guarantee intialSM_wd*)
         (forall b1 b2 d, j b1 = Some (b2, d) ->
                          DomS b1 = true /\ DomT b2 = true) ->
         (forall b, REACH m2 (fun b' => isGlobalBlock ge2 b' || getBlocks vals2 b') b = true -> DomT b = true) ->

        (*the next two conditions ensure the initialSM satisfies sm_valid*)
         (forall b, DomS b = true -> Mem.valid_block m1 b) ->
         (forall b, DomT b = true -> Mem.valid_block m2 b) ->

       exists c2,
            initial_core Sem2 ge2 v vals2 = Some c2 /\
            match_states c1 (initial_SM DomS
                                       DomT
                                       (REACH m1 (fun b => isGlobalBlock ge1 b || getBlocks vals1 b))
                                       (REACH m2 (fun b => isGlobalBlock ge2 b || getBlocks vals2 b)) j)
                           c1 m1 c2 m2.

  Hypothesis inj_halted : forall cd mu c1 m1 c2 m2 v1,
      match_states cd mu c1 m1 c2 m2 ->
      halted Sem1 c1 = Some v1 ->

      exists v2,
             Mem.inject (as_inj mu) m1 m2 /\
             val_inject (restrict (as_inj mu) (vis mu)) v1 v2 /\
             halted Sem2 c2 = Some v2.

  Hypothesis inj_at_external :
      forall mu c1 m1 c2 m2 e vals1 ef_sig,
        match_states c1 mu c1 m1 c2 m2 ->
        at_external Sem1 c1 = Some (e,ef_sig,vals1) ->
        Mem.inject (as_inj mu) m1 m2 /\
          exists vals2,
            Forall2 (val_inject (restrict (as_inj mu) (vis mu))) vals1 vals2 /\
            at_external Sem2 c2 = Some (e,ef_sig,vals2)
    /\ forall
       (pubSrc' pubTgt' : block -> bool)
       (pubSrcHyp : pubSrc' =
                  (fun b : block =>
                  locBlocksSrc mu b && REACH m1 (exportedSrc mu vals1) b))
       (pubTgtHyp: pubTgt' =
                  (fun b : block =>
                  locBlocksTgt mu b && REACH m2 (exportedTgt mu vals2) b))
       nu (Hnu: nu = (replace_locals mu pubSrc' pubTgt')),
       match_states c1 nu c1 m1 c2 m2
       /\ Mem.inject (shared_of nu) m1 m2.

Section EFF_INJ_SIMULATION_STAR_WF.
Variable order: C1 -> C1 -> Prop.
Hypothesis order_wf: well_founded order.

  Hypothesis inj_after_external:
      forall mu st1 st2 m1 e vals1 m2 ef_sig vals2 e' ef_sig'
        (MemInjMu: Mem.inject (as_inj mu) m1 m2)
        (MatchMu: match_states st1 mu st1 m1 st2 m2)
        (AtExtSrc: at_external Sem1 st1 = Some (e,ef_sig,vals1))

        (AtExtTgt: at_external Sem2 st2 = Some (e',ef_sig',vals2))

        (ValInjMu: Forall2 (val_inject (restrict (as_inj mu) (vis mu))) vals1 vals2)

        pubSrc' (pubSrcHyp: pubSrc' = fun b => andb (locBlocksSrc mu b)
                                                    (REACH m1 (exportedSrc mu vals1) b))

        pubTgt' (pubTgtHyp: pubTgt' = fun b => andb (locBlocksTgt mu b)
                                                    (REACH m2 (exportedTgt mu vals2) b))

        nu (NuHyp: nu = replace_locals mu pubSrc' pubTgt'),

      forall nu' ret1 m1' ret2 m2'
        (INC: extern_incr nu nu')
        (GSep: globals_separate ge2 nu nu')

        (WDnu': SM_wd nu') (SMvalNu': sm_valid nu' m1' m2')

        (MemInjNu': Mem.inject (as_inj nu') m1' m2')
        (RValInjNu': val_inject (as_inj nu') ret1 ret2)

        (FwdSrc: mem_forward m1 m1') (FwdTgt: mem_forward m2 m2')

        frgnSrc' (frgnSrcHyp: frgnSrc' = fun b => andb (DomSrc nu' b)
                                                 (andb (negb (locBlocksSrc nu' b))
                                                       (REACH m1' (exportedSrc nu' (ret1::nil)) b)))

        frgnTgt' (frgnTgtHyp: frgnTgt' = fun b => andb (DomTgt nu' b)
                                                 (andb (negb (locBlocksTgt nu' b))
                                                       (REACH m2' (exportedTgt nu' (ret2::nil)) b)))

        mu' (Mu'Hyp: mu' = replace_externs nu' frgnSrc' frgnTgt')

        (UnchPrivSrc: Mem.unchanged_on (fun b ofs => locBlocksSrc nu b = true /\
                                                      pubBlocksSrc nu b = false) m1 m1')

        (UnchLOOR: Mem.unchanged_on (local_out_of_reach nu m1) m2 m2'),
       exists st1', exists st2',
          after_external Sem1 (Some ret1) st1 = Some st1' /\
          after_external Sem2 (Some ret2) st2 = Some st2' /\
          match_states st1' mu' st1' m1' st2' m2'.

  Hypothesis inj_effcore_diagram :
      forall st1 m1 st1' m1' U1,
        effstep Sem1 ge1 U1 st1 m1 st1' m1' ->

      forall st2 mu m2,
        match_states st1 mu st1 m1 st2 m2 ->
        exists st2', exists m2', exists mu',
          intern_incr mu mu' /\
          globals_separate ge1 mu mu' /\
          sm_locally_allocated mu mu' m1 m2 m1' m2' /\

          match_states st1' mu' st1' m1' st2' m2' /\

          exists U2,
            ((effstep_plus Sem2 ge2 U2 st2 m2 st2' m2' \/
              (effstep_star Sem2 ge2 U2 st2 m2 st2' m2' /\
               order st1' st1)) /\

             forall
               (UHyp: forall b z, U1 b z = true -> vis mu b = true)
               b ofs (Ub: U2 b ofs = true),
             visTgt mu b = true /\
                (locBlocksTgt mu b = false ->
                 exists b1 delta1, foreign_of mu b1 = Some(b,delta1) /\
                 U1 b1 (ofs-delta1) = true /\
                 Mem.perm m1 b1 (ofs-delta1) Max Nonempty)).

Lemma  inj_simulation_star_wf:
  SM_simulation.SM_simulation_inject Sem1 Sem2 ge1 ge2.
Proof.
  eapply SM_simulation.Build_SM_simulation_inject with
    (core_ord := order)
    (match_state := fun d j c1 m1 c2 m2 => d = c1 /\ match_states d j c1 m1 c2 m2).
  apply order_wf.
clear - match_sm_wd. intros. destruct H; subst. eauto.
assumption.
clear - match_genv. intros. destruct MC; subst. eauto.
clear - match_visible. intros. destruct H; subst. eauto.
(* RESTRIC : clear - match_restrict. intros. destruct H; subst. eauto.*)
clear - match_validblocks. intros.
    destruct H; subst. eauto.
clear - inj_initial_cores . intros.
    destruct (inj_initial_cores _ _ _ _ _ _ _ _ _ H
         H0 H1 H2 H3 H4 H5 H6 H7)
    as [c2 [INI MS]].
  exists c1, c2. intuition.
clear - inj_effcore_diagram genvs_dom_eq.
  intros. destruct H0; subst.
  destruct (inj_effcore_diagram _ _ _ _ _ H _ _ _ H1) as

    [c2' [m2' [mu' [INC [GSEP [LAC [MC' [U2 [STEP' PROP]]]]]]]]].
  exists c2'. exists m2'. exists st1'. exists mu'.
  split; try assumption.
  split. eapply gsep_domain_eq; eassumption.
  split; try assumption.
  split. split; trivial.
  exists U2. split; assumption.
clear - inj_halted. intros. destruct H; subst.
  destruct (inj_halted _ _ _ _ _ _ _ H1 H0) as [v2 [INJ [VAL HH]]].
  exists v2; intuition.
clear - inj_at_external. intros. destruct H; subst.
  destruct (inj_at_external _ _ _ _ _ _ _ _ H1 H0)
    as [INJ [vals2 [VALS [AtExt2 SH]]]].
  split. trivial. exists vals2. split; trivial. split; trivial.
    intros. split. split. trivial. eapply SH; eassumption. eapply SH; eassumption.
clear - inj_after_external. intros.
  destruct MatchMu as [ZZ matchMu]. subst cd.
  destruct (inj_after_external _ _ _ _ _ _ _ _ _ _ _
      MemInjMu matchMu AtExtSrc AtExtTgt ValInjMu _
      pubSrcHyp _ pubTgtHyp _ NuHyp _ _ _ _ _ INC GSep
      WDnu' SMvalNu' MemInjNu' RValInjNu' FwdSrc FwdTgt
      _ frgnSrcHyp _ frgnTgtHyp _ Mu'Hyp
      UnchPrivSrc UnchLOOR)
    as [st1' [st2' [AftExt1 [AftExt2 MS']]]].
  exists st1', st1', st2'. intuition.
Qed.

End EFF_INJ_SIMULATION_STAR_WF.

Section EFF_INJ_SIMULATION_STAR_WF_TYPED.
Variable order: C1 -> C1 -> Prop.
Hypothesis order_wf: well_founded order.

  Hypothesis inj_after_external:
      forall mu st1 st2 m1 e vals1 m2 ef_sig vals2 e' ef_sig'
        (MemInjMu: Mem.inject (as_inj mu) m1 m2)
        (MatchMu: match_states st1 mu st1 m1 st2 m2)
        (AtExtSrc: at_external Sem1 st1 = Some (e,ef_sig,vals1))

        (AtExtTgt: at_external Sem2 st2 = Some (e',ef_sig',vals2))

        (ValInjMu: Forall2 (val_inject (restrict (as_inj mu) (vis mu))) vals1 vals2)

        pubSrc' (pubSrcHyp: pubSrc' = fun b => andb (locBlocksSrc mu b)
                                                    (REACH m1 (exportedSrc mu vals1) b))

        pubTgt' (pubTgtHyp: pubTgt' = fun b => andb (locBlocksTgt mu b)
                                                    (REACH m2 (exportedTgt mu vals2) b))

        nu (NuHyp: nu = replace_locals mu pubSrc' pubTgt'),

      forall nu' ret1 m1' ret2 m2'
        (HasTy1: Val.has_type ret1 (proj_sig_res (AST.ef_sig e)))
        (HasTy2: Val.has_type ret2 (proj_sig_res (AST.ef_sig e')))
        (INC: extern_incr nu nu')
        (GSep: globals_separate ge2 nu nu')
        (WDnu': SM_wd nu') (SMvalNu': sm_valid nu' m1' m2')

        (MemInjNu': Mem.inject (as_inj nu') m1' m2')
        (RValInjNu': val_inject (as_inj nu') ret1 ret2)

        (FwdSrc: mem_forward m1 m1') (FwdTgt: mem_forward m2 m2')

        frgnSrc' (frgnSrcHyp: frgnSrc' = fun b => andb (DomSrc nu' b)
                                                 (andb (negb (locBlocksSrc nu' b))
                                                       (REACH m1' (exportedSrc nu' (ret1::nil)) b)))

        frgnTgt' (frgnTgtHyp: frgnTgt' = fun b => andb (DomTgt nu' b)
                                                 (andb (negb (locBlocksTgt nu' b))
                                                       (REACH m2' (exportedTgt nu' (ret2::nil)) b)))

        mu' (Mu'Hyp: mu' = replace_externs nu' frgnSrc' frgnTgt')

        (UnchPrivSrc: Mem.unchanged_on (fun b ofs => locBlocksSrc nu b = true /\
                                                      pubBlocksSrc nu b = false) m1 m1')

        (UnchLOOR: Mem.unchanged_on (local_out_of_reach nu m1) m2 m2'),
       exists st1', exists st2',
          after_external Sem1 (Some ret1) st1 = Some st1' /\
          after_external Sem2 (Some ret2) st2 = Some st2' /\
          match_states st1' mu' st1' m1' st2' m2'.

  Hypothesis inj_effcore_diagram :
      forall st1 m1 st1' m1' U1,
        effstep Sem1 ge1 U1 st1 m1 st1' m1' ->

      forall st2 mu m2,
        match_states st1 mu st1 m1 st2 m2 ->
        exists st2', exists m2', exists mu',
          intern_incr mu mu' /\
          globals_separate ge1 mu mu' /\
          sm_locally_allocated mu mu' m1 m2 m1' m2' /\

          match_states st1' mu' st1' m1' st2' m2' /\

          exists U2,
            ((effstep_plus Sem2 ge2 U2 st2 m2 st2' m2' \/
              (effstep_star Sem2 ge2 U2 st2 m2 st2' m2' /\
               order st1' st1)) /\

           forall
             (UHyp: forall b z, U1 b z = true -> vis mu b = true)
             b ofs(Ub: U2 b ofs = true),
             visTgt mu b = true /\
             (locBlocksTgt mu b = false ->
                exists b1 delta1, foreign_of mu b1 = Some(b,delta1) /\
                U1 b1 (ofs-delta1) = true /\
                Mem.perm m1 b1 (ofs-delta1) Max Nonempty)).

Lemma  inj_simulation_star_wf_typed:
  SM_simulation.SM_simulation_inject Sem1 Sem2 ge1 ge2.
Proof.
  eapply SM_simulation.Build_SM_simulation_inject with
    (core_ord := order)
    (match_state := fun d j c1 m1 c2 m2 => d = c1 /\ match_states d j c1 m1 c2 m2).
  apply order_wf.
clear - match_sm_wd. intros. destruct H; subst. eauto.
assumption.
clear - match_genv. intros. destruct MC; subst. eauto.
clear - match_visible. intros. destruct H; subst. eauto.
(* RESTRICT: clear - match_restrict. intros. destruct H; subst. eauto.*)
clear - match_validblocks. intros.
    destruct H; subst. eauto.
clear - inj_initial_cores. intros.
    destruct (inj_initial_cores _ _ _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 H6 H7)
    as [c2 [INI MS]].
  exists c1, c2. intuition.
clear - inj_effcore_diagram genvs_dom_eq.
  intros. destruct H0; subst.
  destruct (inj_effcore_diagram _ _ _ _ _ H _ _ _ H1) as
    [c2' [m2' [mu' [INC [GSEP [LAC [MC' [U2 [STEP' PROP]]]]]]]]].
  exists c2'. exists m2'. exists st1'. exists mu'.
  split; try assumption.
  split. eapply gsep_domain_eq; eassumption.
  split; try assumption.
  split. split; trivial.
  exists U2. split; assumption.
clear - inj_halted. intros. destruct H; subst.
  destruct (inj_halted _ _ _ _ _ _ _ H1 H0) as [v2 [INJ [VAL HH]]].
  exists v2; intuition.
clear - inj_at_external. intros. destruct H; subst.
  destruct (inj_at_external _ _ _ _ _ _ _ _ H1 H0)
    as [INJ [vals2 [VALS [AtExt2 SH]]]].
  split. trivial. exists vals2. split; trivial. split; trivial.
    intros. split. split. trivial. eapply SH; eassumption. eapply SH; eassumption.
clear - inj_after_external. intros.
  destruct MatchMu as [ZZ matchMu]. subst cd.
  destruct (inj_after_external _ _ _ _ _ _ _ _ _ _ _
      MemInjMu matchMu AtExtSrc AtExtTgt ValInjMu _
      pubSrcHyp _ pubTgtHyp _ NuHyp _ _ _ _ _ HasTy1 HasTy2 INC GSep
      WDnu' SMvalNu' MemInjNu' RValInjNu' FwdSrc FwdTgt
      _ frgnSrcHyp _ frgnTgtHyp _ Mu'Hyp
      UnchPrivSrc UnchLOOR)
    as [st1' [st2' [AftExt1 [AftExt2 MS']]]].
  exists st1', st1', st2'. intuition.
Qed.

End EFF_INJ_SIMULATION_STAR_WF_TYPED.

Section EFF_INJ_SIMULATION_STAR.
  Variable measure: C1 -> nat.

  Hypothesis inj_after_external:
      forall mu st1 st2 m1 e vals1 m2 ef_sig vals2 e' ef_sig'
        (MemInjMu: Mem.inject (as_inj mu) m1 m2)
        (MatchMu: match_states st1 mu st1 m1 st2 m2)
        (AtExtSrc: at_external Sem1 st1 = Some (e,ef_sig,vals1))

        (AtExtTgt: at_external Sem2 st2 = Some (e',ef_sig',vals2))

        (ValInjMu: Forall2 (val_inject (restrict (as_inj mu) (vis mu))) vals1 vals2)

        pubSrc' (pubSrcHyp: pubSrc' = fun b => andb (locBlocksSrc mu b)
                                                    (REACH m1 (exportedSrc mu vals1) b))

        pubTgt' (pubTgtHyp: pubTgt' = fun b => andb (locBlocksTgt mu b)
                                                    (REACH m2 (exportedTgt mu vals2) b))

        nu (NuHyp: nu = replace_locals mu pubSrc' pubTgt'),

      forall nu' ret1 m1' ret2 m2'
        (INC: extern_incr nu nu')
        (GSep: globals_separate ge2 nu nu')

        (WDnu': SM_wd nu') (SMvalNu': sm_valid nu' m1' m2')

        (MemInjNu': Mem.inject (as_inj nu') m1' m2')
        (RValInjNu': val_inject (as_inj nu') ret1 ret2)

        (FwdSrc: mem_forward m1 m1') (FwdTgt: mem_forward m2 m2')

        frgnSrc' (frgnSrcHyp: frgnSrc' = fun b => andb (DomSrc nu' b)
                                                 (andb (negb (locBlocksSrc nu' b))
                                                       (REACH m1' (exportedSrc nu' (ret1::nil)) b)))

        frgnTgt' (frgnTgtHyp: frgnTgt' = fun b => andb (DomTgt nu' b)
                                                 (andb (negb (locBlocksTgt nu' b))
                                                       (REACH m2' (exportedTgt nu' (ret2::nil)) b)))

        mu' (Mu'Hyp: mu' = replace_externs nu' frgnSrc' frgnTgt')

        (UnchPrivSrc: Mem.unchanged_on (fun b ofs => locBlocksSrc nu b = true /\
                                                      pubBlocksSrc nu b = false) m1 m1')

        (UnchLOOR: Mem.unchanged_on (local_out_of_reach nu m1) m2 m2'),
       exists st1', exists st2',
          after_external Sem1 (Some ret1) st1 = Some st1' /\
          after_external Sem2 (Some ret2) st2 = Some st2' /\
          match_states st1' mu' st1' m1' st2' m2'.

  Hypothesis inj_effcore_diagram :
      forall st1 m1 st1' m1' U1,
        effstep Sem1 ge1 U1 st1 m1 st1' m1' ->

      forall st2 mu m2,
        match_states st1 mu st1 m1 st2 m2 ->
        exists st2', exists m2', exists mu',
          intern_incr mu mu' /\
          globals_separate ge1 mu mu' /\
          sm_locally_allocated mu mu' m1 m2 m1' m2' /\

          match_states st1' mu' st1' m1' st2' m2' /\

          exists U2,
            (effstep_plus Sem2 ge2 U2 st2 m2 st2' m2' \/
             ((measure st1' < measure st1)%nat /\ effstep_star Sem2 ge2 U2 st2 m2 st2' m2'))
            /\
             forall
               (UHyp: forall b ofs, U1 b ofs = true -> vis mu b = true)
               b ofs(Ub: U2 b ofs = true),
             visTgt mu b = true /\
             (locBlocksTgt mu b = false ->
                 exists b1 delta1, foreign_of mu b1 = Some(b,delta1) /\
                 U1 b1 (ofs-delta1) = true /\
                 Mem.perm m1 b1 (ofs-delta1) Max Nonempty).

Lemma inj_simulation_star:
  SM_simulation.SM_simulation_inject Sem1 Sem2 ge1 ge2.
Proof.
  eapply inj_simulation_star_wf.
  apply  (well_founded_ltof _ measure).
  apply inj_after_external.
  clear - inj_effcore_diagram genvs_dom_eq.  intros.
  destruct (inj_effcore_diagram _ _ _ _ _ H _ _ _ H0)
    as [c2' [m2' [mu' [INC [GSEP [LAC [MC' [U2 [STEP' PROP]]]]]]]]].
  exists c2'. exists m2'. exists mu'.
  split; try assumption.
  split; try assumption.
  (*split. eapply globalsep_domain_eq. eassumption.*)
  split; try assumption.
  split; try assumption.
  exists U2. intuition.
Qed.

End EFF_INJ_SIMULATION_STAR.

Section EFF_INJ_SIMULATION_STAR_TYPED.
  Variable measure: C1 -> nat.

  Hypothesis inj_after_external:
      forall mu st1 st2 m1 e vals1 m2 ef_sig vals2 e' ef_sig'
        (MemInjMu: Mem.inject (as_inj mu) m1 m2)
        (MatchMu: match_states st1 mu st1 m1 st2 m2)
        (AtExtSrc: at_external Sem1 st1 = Some (e,ef_sig,vals1))

        (AtExtTgt: at_external Sem2 st2 = Some (e',ef_sig',vals2))

        (ValInjMu: Forall2 (val_inject (restrict (as_inj mu) (vis mu))) vals1 vals2)

        pubSrc' (pubSrcHyp: pubSrc' = fun b => andb (locBlocksSrc mu b)
                                                    (REACH m1 (exportedSrc mu vals1) b))

        pubTgt' (pubTgtHyp: pubTgt' = fun b => andb (locBlocksTgt mu b)
                                                    (REACH m2 (exportedTgt mu vals2) b))

        nu (NuHyp: nu = replace_locals mu pubSrc' pubTgt'),

      forall nu' ret1 m1' ret2 m2'
        (HasTy1: Val.has_type ret1 (proj_sig_res (AST.ef_sig e)))
        (HasTy2: Val.has_type ret2 (proj_sig_res (AST.ef_sig e')))
        (INC: extern_incr nu nu')
        (GSep: globals_separate ge2 nu nu')
        (WDnu': SM_wd nu') (SMvalNu': sm_valid nu' m1' m2')

        (MemInjNu': Mem.inject (as_inj nu') m1' m2')
        (RValInjNu': val_inject (as_inj nu') ret1 ret2)

        (FwdSrc: mem_forward m1 m1') (FwdTgt: mem_forward m2 m2')

        frgnSrc' (frgnSrcHyp: frgnSrc' = fun b => andb (DomSrc nu' b)
                                                 (andb (negb (locBlocksSrc nu' b))
                                                       (REACH m1' (exportedSrc nu' (ret1::nil)) b)))

        frgnTgt' (frgnTgtHyp: frgnTgt' = fun b => andb (DomTgt nu' b)
                                                 (andb (negb (locBlocksTgt nu' b))
                                                       (REACH m2' (exportedTgt nu' (ret2::nil)) b)))

        mu' (Mu'Hyp: mu' = replace_externs nu' frgnSrc' frgnTgt')

        (UnchPrivSrc: Mem.unchanged_on (fun b ofs => locBlocksSrc nu b = true /\
                                                      pubBlocksSrc nu b = false) m1 m1')

        (UnchLOOR: Mem.unchanged_on (local_out_of_reach nu m1) m2 m2'),
       exists st1', exists st2',
          after_external Sem1 (Some ret1) st1 = Some st1' /\
          after_external Sem2 (Some ret2) st2 = Some st2' /\
          match_states st1' mu' st1' m1' st2' m2'.

  Hypothesis inj_effcore_diagram :
      forall st1 m1 st1' m1' U1,
        effstep Sem1 ge1 U1 st1 m1 st1' m1' ->

      forall st2 mu m2,
        match_states st1 mu st1 m1 st2 m2 ->
        exists st2', exists m2', exists mu',
          intern_incr mu mu' /\
          globals_separate ge1 mu mu' /\
          sm_locally_allocated mu mu' m1 m2 m1' m2' /\

          match_states st1' mu' st1' m1' st2' m2' /\

          exists U2,
            (effstep_plus Sem2 ge2 U2 st2 m2 st2' m2' \/
             ((measure st1' < measure st1)%nat /\ effstep_star Sem2 ge2 U2 st2 m2 st2' m2'))
            /\
             forall
               (UHyp: forall b ofs, U1 b ofs = true -> vis mu b = true)
               b ofs(Ub: U2 b ofs = true),
              visTgt mu b = true /\
                (locBlocksTgt mu b = false ->
                 exists b1 delta1, foreign_of mu b1 = Some(b,delta1) /\
                     U1 b1 (ofs-delta1) = true /\
                     Mem.perm m1 b1 (ofs-delta1) Max Nonempty).

Lemma inj_simulation_star_typed:
  SM_simulation.SM_simulation_inject Sem1 Sem2 ge1 ge2.
Proof.
  eapply inj_simulation_star_wf_typed.
  apply  (well_founded_ltof _ measure).
  intros. eapply inj_after_external with (mu := mu); eauto.
  clear - inj_effcore_diagram. intros.
  destruct (inj_effcore_diagram _ _ _ _ _ H _ _ _ H0)
    as [c2' [m2' [mu' [INC [GSEP [LAC [MC' [U2 [STEP' PROP]]]]]]]]].
  exists c2'. exists m2'. exists mu'.
  split; try assumption.
  split; try assumption.
  split; try assumption.
  split; try assumption.
  exists U2. intuition.
Qed.

End EFF_INJ_SIMULATION_STAR_TYPED.

Section EFF_INJ_SIMULATION_PLUS.
  Variable measure: C1 -> nat.

  Hypothesis inj_after_external:
      forall mu st1 st2 m1 e vals1 m2 ef_sig vals2 e' ef_sig'
        (MemInjMu: Mem.inject (as_inj mu) m1 m2)
        (MatchMu: match_states st1 mu st1 m1 st2 m2)
        (AtExtSrc: at_external Sem1 st1 = Some (e,ef_sig,vals1))

        (AtExtTgt: at_external Sem2 st2 = Some (e',ef_sig',vals2))

        (ValInjMu: Forall2 (val_inject (restrict (as_inj mu) (vis mu))) vals1 vals2)

        pubSrc' (pubSrcHyp: pubSrc' = fun b => andb (locBlocksSrc mu b)
                                                    (REACH m1 (exportedSrc mu vals1) b))

        pubTgt' (pubTgtHyp: pubTgt' = fun b => andb (locBlocksTgt mu b)
                                                    (REACH m2 (exportedTgt mu vals2) b))

        nu (NuHyp: nu = replace_locals mu pubSrc' pubTgt'),

      forall nu' ret1 m1' ret2 m2'
        (INC: extern_incr nu nu')
        (GSep: globals_separate ge2 nu nu')
        (WDnu': SM_wd nu') (SMvalNu': sm_valid nu' m1' m2')

        (MemInjNu': Mem.inject (as_inj nu') m1' m2')
        (RValInjNu': val_inject (as_inj nu') ret1 ret2)

        (FwdSrc: mem_forward m1 m1') (FwdTgt: mem_forward m2 m2')

        frgnSrc' (frgnSrcHyp: frgnSrc' = fun b => andb (DomSrc nu' b)
                                                 (andb (negb (locBlocksSrc nu' b))
                                                       (REACH m1' (exportedSrc nu' (ret1::nil)) b)))

        frgnTgt' (frgnTgtHyp: frgnTgt' = fun b => andb (DomTgt nu' b)
                                                 (andb (negb (locBlocksTgt nu' b))
                                                       (REACH m2' (exportedTgt nu' (ret2::nil)) b)))

        mu' (Mu'Hyp: mu' = replace_externs nu' frgnSrc' frgnTgt')

        (UnchPrivSrc: Mem.unchanged_on (fun b ofs => locBlocksSrc nu b = true /\
                                                      pubBlocksSrc nu b = false) m1 m1')

        (UnchLOOR: Mem.unchanged_on (local_out_of_reach nu m1) m2 m2'),
       exists st1', exists st2',
          after_external Sem1 (Some ret1) st1 = Some st1' /\
          after_external Sem2 (Some ret2) st2 = Some st2' /\
          match_states st1' mu' st1' m1' st2' m2'.

  Hypothesis inj_effcore_diagram :
      forall st1 m1 st1' m1' U1,
        effstep Sem1 ge1 U1 st1 m1 st1' m1' ->

      forall st2 mu m2,
        match_states st1 mu st1 m1 st2 m2 ->
        exists st2', exists m2', exists mu',
          intern_incr mu mu' /\
          globals_separate ge1 mu mu' /\
          sm_locally_allocated mu mu' m1 m2 m1' m2' /\

          match_states st1' mu' st1' m1' st2' m2' /\

          exists U2,
            (effstep_plus Sem2 ge2 U2 st2 m2 st2' m2' \/
             ((measure st1' < measure st1)%nat /\ effstep_star Sem2 ge2 U2 st2 m2 st2' m2'))
            /\ forall
                 (UHyp: forall b ofs, U1 b ofs = true -> vis mu b = true)
                 b ofs (Ub: U2 b ofs = true),
                 visTgt mu b = true /\
                 (locBlocksTgt mu b = false ->
                     exists b1 delta1, foreign_of mu b1 = Some(b,delta1) /\
                     U1 b1 (ofs-delta1) = true /\
                     Mem.perm m1 b1 (ofs-delta1) Max Nonempty).

Lemma inj_simulation_plus:
  SM_simulation.SM_simulation_inject Sem1 Sem2 ge1 ge2.
Proof.
  apply inj_simulation_star with (measure:=measure); auto.
Qed.

End EFF_INJ_SIMULATION_PLUS.

Section EFF_INJ_SIMULATION_PLUS_TYPED.
  Variable measure: C1 -> nat.

  Hypothesis inj_after_external:
      forall mu st1 st2 m1 e vals1 m2 ef_sig vals2 e' ef_sig'
        (MemInjMu: Mem.inject (as_inj mu) m1 m2)
        (MatchMu: match_states st1 mu st1 m1 st2 m2)
        (AtExtSrc: at_external Sem1 st1 = Some (e,ef_sig,vals1))

        (AtExtTgt: at_external Sem2 st2 = Some (e',ef_sig',vals2))

        (ValInjMu: Forall2 (val_inject (restrict (as_inj mu) (vis mu))) vals1 vals2)

        pubSrc' (pubSrcHyp: pubSrc' = fun b => andb (locBlocksSrc mu b)
                                                    (REACH m1 (exportedSrc mu vals1) b))

        pubTgt' (pubTgtHyp: pubTgt' = fun b => andb (locBlocksTgt mu b)
                                                    (REACH m2 (exportedTgt mu vals2) b))

        nu (NuHyp: nu = replace_locals mu pubSrc' pubTgt'),

      forall nu' ret1 m1' ret2 m2'
        (HasTy1: Val.has_type ret1 (proj_sig_res (AST.ef_sig e)))
        (HasTy2: Val.has_type ret2 (proj_sig_res (AST.ef_sig e')))
        (INC: extern_incr nu nu')
        (GSep: globals_separate ge2 nu nu')
        (WDnu': SM_wd nu') (SMvalNu': sm_valid nu' m1' m2')

        (MemInjNu': Mem.inject (as_inj nu') m1' m2')
        (RValInjNu': val_inject (as_inj nu') ret1 ret2)

        (FwdSrc: mem_forward m1 m1') (FwdTgt: mem_forward m2 m2')

        frgnSrc' (frgnSrcHyp: frgnSrc' = fun b => andb (DomSrc nu' b)
                                                 (andb (negb (locBlocksSrc nu' b))
                                                       (REACH m1' (exportedSrc nu' (ret1::nil)) b)))

        frgnTgt' (frgnTgtHyp: frgnTgt' = fun b => andb (DomTgt nu' b)
                                                 (andb (negb (locBlocksTgt nu' b))
                                                       (REACH m2' (exportedTgt nu' (ret2::nil)) b)))

        mu' (Mu'Hyp: mu' = replace_externs nu' frgnSrc' frgnTgt')

        (UnchPrivSrc: Mem.unchanged_on (fun b ofs => locBlocksSrc nu b = true /\
                                                      pubBlocksSrc nu b = false) m1 m1')

        (UnchLOOR: Mem.unchanged_on (local_out_of_reach nu m1) m2 m2'),
       exists st1', exists st2',
          after_external Sem1 (Some ret1) st1 = Some st1' /\
          after_external Sem2 (Some ret2) st2 = Some st2' /\
          match_states st1' mu' st1' m1' st2' m2'.

  Hypothesis inj_effcore_diagram :
      forall st1 m1 st1' m1' U1,
        effstep Sem1 ge1 U1 st1 m1 st1' m1' ->

      forall st2 mu m2,
        match_states st1 mu st1 m1 st2 m2 ->
        exists st2', exists m2', exists mu',
          intern_incr mu mu' /\
          globals_separate ge1 mu mu' /\
          sm_locally_allocated mu mu' m1 m2 m1' m2' /\

          match_states st1' mu' st1' m1' st2' m2' /\

          exists U2,
            (effstep_plus Sem2 ge2 U2 st2 m2 st2' m2' \/
             ((measure st1' < measure st1)%nat /\ effstep_star Sem2 ge2 U2 st2 m2 st2' m2'))
            /\ forall
                 (UHyp: forall b ofs, U1 b ofs = true -> vis mu b = true)
                  b ofs (Ub: U2 b ofs = true),
                visTgt mu b = true /\
                (locBlocksTgt mu b = false ->
                    exists b1 delta1, foreign_of mu b1 = Some(b,delta1) /\
                    U1 b1 (ofs-delta1) = true /\
                    Mem.perm m1 b1 (ofs-delta1) Max Nonempty).

Lemma inj_simulation_plus_typed:
  SM_simulation.SM_simulation_inject Sem1 Sem2 ge1 ge2.
Proof.
  apply inj_simulation_star_typed with (measure:=measure); auto.
Qed.

End EFF_INJ_SIMULATION_PLUS_TYPED.

End Eff_INJ_SIMU_DIAGRAMS.

Definition compose_sm (mu1 mu2 : SM_Injection) : SM_Injection :=
 Build_SM_Injection
   (locBlocksSrc mu1) (locBlocksTgt mu2)
   (pubBlocksSrc mu1) (pubBlocksTgt mu2)
   (compose_meminj (local_of mu1) (local_of mu2))
   (extBlocksSrc mu1) (extBlocksTgt mu2)
   (frgnBlocksSrc mu1) (frgnBlocksTgt mu2)
   (compose_meminj (extern_of mu1) (extern_of mu2)).

Lemma compose_sm_valid: forall mu1 mu2 m1 m2 m2' m3
          (SMV1: sm_valid mu1 m1 m2) (SMV2: sm_valid mu2 m2' m3),
       sm_valid (compose_sm mu1 mu2) m1 m3.
Proof.  split. apply SMV1. apply SMV2. Qed.

Lemma compose_sm_pub: forall mu12 mu23
         (HypPub: forall b, pubBlocksTgt mu12 b = true ->
                            pubBlocksSrc mu23 b = true)
         (WD1:SM_wd mu12),
      pub_of (compose_sm mu12 mu23) =
      compose_meminj (pub_of mu12) (pub_of mu23).
Proof. intros. unfold compose_sm, pub_of.
  extensionality b.
  destruct mu12 as [locBSrc1 locBTgt1 pSrc1 pTgt1 local1 extBSrc1 extBTgt1 fSrc1 fTgt1 extern1]; simpl.
  destruct mu23 as [locBSrc2 locBTgt2 pSrc2 pTgt2 local2 extBSrc2 extBTgt2 fSrc2 fTgt2 extern2]; simpl.
  remember (pSrc1 b) as d; destruct d; apply eq_sym in Heqd.
    destruct (pubSrc _ WD1 _ Heqd) as [b2 [d1 [LOC1 Tgt1]]]; simpl in *.
    rewrite Heqd in LOC1. apply HypPub in Tgt1.
    unfold compose_meminj. rewrite Heqd. rewrite LOC1. rewrite Tgt1.
    trivial.
  unfold compose_meminj.
    rewrite Heqd. trivial.
Qed.

Lemma compose_sm_DomSrc: forall mu12 mu23,
  DomSrc (compose_sm mu12 mu23) = DomSrc mu12.
Proof. intros. unfold compose_sm, DomSrc; simpl. trivial. Qed.

Lemma compose_sm_DomTgt: forall mu12 mu23,
  DomTgt (compose_sm mu12 mu23) = DomTgt mu23.
Proof. intros. unfold compose_sm, DomTgt; simpl. trivial. Qed.

Lemma compose_sm_foreign: forall mu12 mu23
         (HypFrg: forall b, frgnBlocksTgt mu12 b = true ->
                            frgnBlocksSrc mu23 b = true)
         (WD1:SM_wd mu12),
      foreign_of (compose_sm mu12 mu23) =
      compose_meminj (foreign_of mu12) (foreign_of mu23).
Proof. intros. unfold compose_sm, foreign_of.
  extensionality b.
  destruct mu12 as [locBSrc1 locBTgt1 pSrc1 pTgt1 local1 extBSrc1 extBTgt1 fSrc1 fTgt1 extern1]; simpl.
  destruct mu23 as [locBSrc2 locBTgt2 pSrc2 pTgt2 local2 extBSrc2 extBTgt2 fSrc2 fTgt2 extern2]; simpl.
  remember (fSrc1 b) as d; destruct d; apply eq_sym in Heqd.
    destruct (frgnSrc _ WD1 _ Heqd) as [b2 [d1 [EXT1 Tgt1]]]; simpl in *.
    rewrite Heqd in EXT1. apply HypFrg in Tgt1.
    unfold compose_meminj. rewrite Heqd. rewrite EXT1. rewrite Tgt1.
    trivial.
  unfold compose_meminj.
    rewrite Heqd. trivial.
Qed.

Lemma compose_sm_priv: forall mu12 mu23,
   priv_of (compose_sm mu12 mu23) =
   compose_meminj (priv_of mu12) (local_of mu23).
Proof. intros. unfold priv_of, compose_sm.
  extensionality b.
  destruct mu12 as [locBSrc1 locBTgt1 pSrc1 pTgt1 local1 extBSrc1 extBTgt1 fSrc1 fTgt1 extern1]; simpl.
  destruct mu23 as [locBSrc2 locBTgt2 pSrc2 pTgt2 local2 extBSrc2 extBTgt2 fSrc2 fTgt2 extern2]; simpl.
  remember (pSrc1 b) as d; destruct d; apply eq_sym in Heqd.
    unfold compose_meminj. rewrite Heqd. trivial.
  unfold compose_meminj.
    rewrite Heqd. trivial.
Qed.

Lemma compose_sm_unknown: forall mu12 mu23,
   unknown_of (compose_sm mu12 mu23) =
   compose_meminj (unknown_of mu12) (extern_of mu23).
Proof. intros. unfold unknown_of, compose_sm.
  extensionality b.
  destruct mu12 as [locBSrc1 locBTgt1 pSrc1 pTgt1 local1 extBSrc1 extBTgt1 fSrc1 fTgt1 extern1]; simpl.
  destruct mu23 as [locBSrc2 locBTgt2 pSrc2 pTgt2 local2 extBSrc2 extBTgt2 fSrc2 fTgt2 extern2]; simpl.
  remember (locBSrc1 b) as d; destruct d; apply eq_sym in Heqd.
    unfold compose_meminj. rewrite Heqd. trivial.
  remember (fSrc1 b) as q; destruct q; apply eq_sym in Heqq.
    unfold compose_meminj. rewrite Heqd. rewrite Heqq. trivial.
  unfold compose_meminj.
    rewrite Heqd. rewrite Heqq. trivial.
Qed.

Lemma compose_sm_local: forall mu12 mu23,
   local_of (compose_sm mu12 mu23) =
   compose_meminj (local_of mu12) (local_of mu23).
Proof. intros. reflexivity. Qed.

Lemma compose_sm_extern: forall mu12 mu23,
   extern_of (compose_sm mu12 mu23) =
   compose_meminj (extern_of mu12) (extern_of mu23).
Proof. intros. reflexivity. Qed.

Lemma compose_sm_shared: forall mu12 mu23
         (HypPub: forall b, pubBlocksTgt mu12 b = true ->
                            pubBlocksSrc mu23 b = true)
         (HypFrg: forall b, frgnBlocksTgt mu12 b = true ->
                            frgnBlocksSrc mu23 b = true)
         (WD1:SM_wd mu12) (WD2:SM_wd mu23),
      shared_of (compose_sm mu12 mu23) =
      compose_meminj (shared_of mu12) (shared_of mu23).
Proof. intros. unfold shared_of.
  rewrite compose_sm_pub; trivial.
  rewrite compose_sm_foreign; trivial.
  unfold join, compose_meminj. extensionality b.
  remember (foreign_of mu12 b) as f; destruct f; apply eq_sym in Heqf.
    destruct p as [b2 d1].
    destruct (foreign_DomRng _ WD1 _ _ _ Heqf) as [A [B [C [D [E [F [G H]]]]]]].
    apply HypFrg in F.
    destruct (frgnSrc _ WD2 _ F) as [b3 [d2 [FRG2 TGT2]]].
    rewrite FRG2. trivial.
  remember (pub_of mu12 b) as d; destruct d; apply eq_sym in Heqd; trivial.
    destruct p as [b2 d1].
    destruct (pub_locBlocks _ WD1 _ _ _ Heqd) as [A [B [C [D [E [F [G H]]]]]]].
    apply HypPub in B.
    destruct (pubSrc _ WD2 _ B) as [b3 [d2 [PUB2 TGT2]]].
    rewrite PUB2.
    apply (pubBlocksLocalSrc _ WD2) in B.
    apply (locBlocksSrc_frgnBlocksSrc _ WD2) in B.
    unfold foreign_of. destruct mu23. simpl in *. rewrite B. trivial.
Qed.

Lemma compose_sm_wd: forall mu1 mu2 (WD1: SM_wd mu1) (WD2:SM_wd mu2)
         (HypPub: forall b, pubBlocksTgt mu1 b = true ->
                            pubBlocksSrc mu2 b = true)
         (HypFrg: forall b, frgnBlocksTgt mu1 b = true ->
                            frgnBlocksSrc mu2 b = true),
      SM_wd (compose_sm mu1 mu2).
Proof. intros.
  destruct mu1 as [locBSrc1 locBTgt1 pSrc1 pTgt1 local1 extBSrc1 extBTgt1 fSrc1 fTgt1 extern1]; simpl.
  destruct mu2 as [locBSrc2 locBTgt2 pSrc2 pTgt2 local2 extBSrc2 extBTgt2 fSrc2 fTgt2 extern2]; simpl.
split; simpl in *.
apply WD1.
apply WD2.
(*local_DomRng*)
  intros b1 b3 d H.
  destruct (compose_meminjD_Some _ _ _ _ _ H)
    as [b2 [d1 [d2 [PUB1 [PUB2 X]]]]]; subst; clear H.
  split. eapply WD1. apply PUB1.
         eapply WD2. apply PUB2.
(*extern_DomRng*)
  intros b1 b3 d H.
  destruct (compose_meminjD_Some _ _ _ _ _ H)
    as [b2 [d1 [d2 [EXT1 [EXT2 X]]]]]; subst; clear H.
  split. eapply WD1. apply EXT1.
         eapply WD2. apply EXT2.
(*pubSrc*)
  intros.
  destruct (pubSrc _ WD1 _ H) as [b2 [d1 [Loc1 Tgt1]]]. simpl in *.
  apply HypPub in Tgt1.
  destruct (pubSrc _ WD2 _ Tgt1) as [b3 [d2 [Loc2 Tgt2]]]. simpl in *.
  unfold compose_meminj. exists b3, (d1+d2).
  rewrite H in *. rewrite Tgt1 in *. rewrite Loc1. rewrite Loc2. auto.
(*frgnSrc*)
  intros.
  destruct (frgnSrc _ WD1 _ H) as [b2 [d1 [Ext1 Tgt1]]]. simpl in *.
  apply HypFrg in Tgt1.
  destruct (frgnSrc _ WD2 _ Tgt1) as [b3 [d2 [Ext2 Tgt2]]]. simpl in *.
  unfold compose_meminj. exists b3, (d1+d2).
  rewrite H in *. rewrite Tgt1 in *. rewrite Ext1. rewrite Ext2. auto.
(*locBlocksDomTgt*)
  apply WD2.
(*frgnBlocksDomTgt*)
  apply WD2.
Qed.

Lemma compose_sm_as_inj: forall mu12 mu23 (WD1: SM_wd mu12) (WD2: SM_wd mu23)
   (SrcTgtLoc: locBlocksTgt mu12 = locBlocksSrc mu23)
   (SrcTgtExt: extBlocksTgt mu12 = extBlocksSrc mu23),
   as_inj (compose_sm mu12 mu23) =
   compose_meminj (as_inj mu12) (as_inj mu23).
Proof. intros.
  unfold as_inj.
  rewrite compose_sm_extern.
  rewrite compose_sm_local.
  unfold join, compose_meminj. extensionality b.
  remember (extern_of mu12 b) as f; destruct f; apply eq_sym in Heqf.
    destruct p as [b2 d1].
    remember (extern_of mu23 b2) as d; destruct d; apply eq_sym in Heqd.
      destruct p as [b3 d2]. trivial.
    destruct (disjoint_extern_local _ WD1 b).
       rewrite H in Heqf. discriminate.
    rewrite H.
    destruct (extern_DomRng _ WD1 _ _ _ Heqf) as [A B].
    rewrite SrcTgtExt in B.
    remember (local_of mu23 b2) as q; destruct q; trivial; apply eq_sym in Heqq.
    destruct p as [b3 d2].
    destruct (local_DomRng _ WD2 _ _ _ Heqq) as [AA BB].
    destruct (disjoint_extern_local_Src _ WD2 b2); congruence.
  remember (local_of mu12 b) as q; destruct q; trivial; apply eq_sym in Heqq.
    destruct p as [b2 d1].
    destruct (local_DomRng _ WD1 _ _ _ Heqq) as [AA BB].
    remember (extern_of mu23 b2) as d; destruct d; trivial; apply eq_sym in Heqd.
      destruct p as [b3 d2].
      destruct (extern_DomRng _ WD2 _ _ _ Heqd) as [A B].
      rewrite SrcTgtLoc in BB.
      destruct (disjoint_extern_local_Src _ WD2 b2); congruence.
Qed.

Lemma compose_sm_intern_incr:
      forall mu12 mu12' mu23 mu23'
            (inc12: intern_incr mu12 mu12')
            (inc23: intern_incr mu23 mu23'),
      intern_incr (compose_sm mu12 mu23) (compose_sm mu12' mu23').
Proof. intros.
split; simpl in *.
    eapply compose_meminj_inject_incr.
        apply inc12.
        apply intern_incr_local; eassumption.
split. rewrite (intern_incr_extern _ _ inc12).
       rewrite (intern_incr_extern _ _ inc23).
       trivial.
split. apply inc12.
split. apply inc23.
split. apply inc12.
split. apply inc23.
split. apply inc12.
split. apply inc23.
split. apply inc12.
apply inc23.
Qed.

Lemma compose_sm_extern_incr:
      forall mu12 mu12' mu23 mu23'
            (inc12: extern_incr mu12 mu12')
            (inc23: extern_incr mu23 mu23')
  (FRG': forall b1 b2 d1, foreign_of mu12' b1 = Some(b2,d1) ->
         exists b3 d2, foreign_of mu23' b2 = Some(b3,d2))
  (WD12': SM_wd mu12') (WD23': SM_wd mu23'),
  extern_incr (compose_sm mu12 mu23) (compose_sm mu12' mu23').
Proof. intros.
split; intros.
  rewrite compose_sm_extern.
  rewrite compose_sm_extern.
  eapply compose_meminj_inject_incr.
    apply inc12.
    apply extern_incr_extern; eassumption.
split; simpl.
  rewrite (extern_incr_local _ _ inc12).
  rewrite (extern_incr_local _ _ inc23).
  trivial.
split. apply inc12.
split. apply inc23.
split. apply inc12.
split. apply inc23.
split. apply inc12.
split. apply inc23.
split. apply inc12.
apply inc23.
Qed.

Lemma extern_incr_inject_incr:
      forall nu12 nu23 nu' (WDnu' : SM_wd nu')
          (EXT: extern_incr (compose_sm nu12 nu23) nu')
          (GlueInvNu: SM_wd nu12 /\ SM_wd nu23 /\
                      locBlocksTgt nu12 = locBlocksSrc nu23 /\
                      extBlocksTgt nu12 = extBlocksSrc nu23 /\
                      (forall b, pubBlocksTgt nu12 b = true ->
                                 pubBlocksSrc nu23 b = true) /\
                      (forall b, frgnBlocksTgt nu12 b = true ->
                                 frgnBlocksSrc nu23 b = true)),
      inject_incr (compose_meminj (as_inj nu12) (as_inj nu23)) (as_inj nu').
Proof. intros.
  intros b; intros.
  destruct (compose_meminjD_Some _ _ _ _ _ H)
    as [b2 [d1 [d2 [Nu12 [Nu23 D]]]]]; subst; clear H.
  unfold extern_incr in EXT. simpl in EXT.
  destruct EXT as [EXT [LOC [extBSrc12 [extBTgt23 [locBSrc12 [locBTgt23 [pubBSrc12 [pubBTgt23 [frgnBSrc12 frgnBTgt23]]]]]]]]].
  destruct (joinD_Some _ _ _ _ _ Nu12); clear Nu12.
  (*extern12*)
     destruct (joinD_Some _ _ _ _ _ Nu23); clear Nu23.
     (*extern12*)
        apply join_incr_left. apply EXT.
        unfold compose_meminj. rewrite H. rewrite H0. trivial.
     (*local*)
        destruct H0.
        destruct GlueInvNu as [GLa [GLb [GLc [GLd [GLe GLf]]]]].
        destruct (extern_DomRng' _ GLa _ _ _ H) as [? [? [? [? [? [? [? ?]]]]]]].
        destruct (local_locBlocks _ GLb _ _ _ H1) as [? [? [? [? [? [? [? ?]]]]]]].
        rewrite GLd in *. congruence.
  (*local*)
     destruct H.
     destruct (joinD_Some _ _ _ _ _ Nu23); clear Nu23.
     (*extern12*)
        destruct GlueInvNu as [GLa [GLb [GLc [GLd [GLe GLf]]]]].
        destruct (extern_DomRng' _ GLb _ _ _ H1) as [? [? [? [? [? ?]]]]].
        destruct (local_locBlocks _ GLa _ _ _ H0) as [? [? [? [? [? ?]]]]].
        rewrite GLd in *. congruence.
     (*local*)
        destruct H1.
        apply join_incr_right. eapply disjoint_extern_local. apply WDnu'.
        rewrite <- LOC. unfold compose_meminj.
        rewrite H0, H2. trivial.
Qed.

Lemma compose_sm_as_injD: forall mu1 mu2 b1 b3 d
      (I: as_inj (compose_sm mu1 mu2) b1 = Some (b3, d))
      (WD1: SM_wd mu1) (WD2: SM_wd mu2),
      exists b2 d1 d2, as_inj mu1 b1 = Some(b2,d1) /\
                       as_inj mu2 b2 = Some(b3,d2) /\
                       d=d1+d2.
Proof. intros.
destruct (joinD_Some _ _ _ _ _ I); clear I.
(*extern*)
  rewrite compose_sm_extern in H.
  destruct (compose_meminjD_Some _ _ _ _ _ H)
      as [b2 [d1 [d2 [EXT1 [EXT2 D]]]]]; clear H.
  exists b2, d1, d2.
  split. apply join_incr_left. assumption.
  split. apply join_incr_left. assumption.
         assumption.
(*local*)
  destruct H.
  rewrite compose_sm_extern in H.
  rewrite compose_sm_local in H0.
  destruct (compose_meminjD_Some _ _ _ _ _ H0)
      as [b2 [d1 [d2 [LOC1 [LOC2 D]]]]]; clear H0.
  exists b2, d1, d2.
  split. apply join_incr_right.
           apply disjoint_extern_local; assumption.
           assumption.
  split. apply join_incr_right.
           apply disjoint_extern_local; assumption.
           assumption.
         assumption.
Qed.

Lemma compose_sm_as_injD_None:
  forall (mu1 mu2 : SM_Injection) b1,
       SM_wd mu1 ->
       SM_wd mu2 ->
    (locBlocksTgt mu1 = locBlocksSrc mu2 /\
         extBlocksTgt mu1 = extBlocksSrc mu2) ->
       as_inj (compose_sm mu1 mu2) b1 = None ->
         as_inj mu1 b1 = None  \/
         exists b2 d, (as_inj mu1 b1 = Some (b2, d) /\ as_inj mu2 b2 = None).
Proof.
intros mu1 mu2 b1 SMWD1 SMWD2 [GLUEloc GLUEext].
unfold as_inj, join, compose_sm; simpl.
destruct (Values.compose_meminj (extern_of mu1) (extern_of mu2) b1) as [[b2 delta]| ] eqn:extmap.
discriminate.
destruct (Values.compose_meminj (local_of mu1) (local_of mu2) b1) as [[b2 delta]| ] eqn:locmap.
discriminate.
intros tautology.
destruct (compose_meminjD_None _ _ _ extmap) as [extmap' | [b' [ofs' [extmap1 extmap2]]]];
destruct (compose_meminjD_None _ _ _ locmap) as [locmap' | [b'' [ofs'' [locmap1 locmap2]]]].
- rewrite extmap'; simpl.  rewrite locmap'; auto.
- rewrite extmap'; simpl. right.
  exists b'', ofs''. split.
  + auto.
  + destruct (extern_of mu2 b'') as [[b0 d]| ] eqn:extmap0.
    * apply SMWD2 in extmap0. apply SMWD1 in locmap1.
      destruct locmap1; destruct extmap0.
      rewrite GLUEloc in *.
      destruct SMWD2 as [disj_src _].
      destruct (disj_src b'') as [theFalse | theFalse]; rewrite theFalse in *; discriminate.
    * assumption.
- rewrite extmap1; simpl. right.
  exists b', ofs'. split.
  + reflexivity.
  + rewrite extmap2; simpl.
    destruct (local_of mu2 b') as [[b0 d]| ] eqn:locmap0.
    * apply SMWD2 in locmap0. apply SMWD1 in extmap1.
      destruct extmap1; destruct locmap0.
      rewrite GLUEext in *.
      destruct SMWD2 as [disj_src _].
      destruct (disj_src b') as [theFalse | theFalse]; rewrite theFalse in *; discriminate.
    * assumption.
- apply SMWD1 in extmap1; apply SMWD1 in locmap1.
  destruct locmap1; destruct extmap1.
  destruct SMWD1 as [disj_src _].
  destruct (disj_src b1) as [theFalse | theFalse]; rewrite theFalse in *; discriminate.
Qed.

(*
Lemma compose_sm_intern_separated:
      forall mu12 mu12' mu23 mu23' m1 m2 m3
        (inc12: intern_incr mu12 mu12')
        (inc23: intern_incr mu23 mu23')
        (InjSep12 : sm_inject_separated mu12 mu12' m1 m2)
        (InjSep23 : sm_inject_separated mu23 mu23' m2 m3)
        (WD12: SM_wd mu12) (WD12': SM_wd mu12') (WD23: SM_wd mu23) (WD23': SM_wd mu23')
        (BlocksLoc: locBlocksTgt mu12 = locBlocksSrc mu23)
        (BlocksExt: extBlocksTgt mu12 = extBlocksSrc mu23),
      sm_inject_separated (compose_sm mu12 mu23)
                          (compose_sm mu12' mu23') m1 m3.
Proof. intros.
destruct InjSep12 as [AsInj12 [DomTgt12 Sep12]].
destruct InjSep23 as [AsInj23 [DomTgt23 Sep23]].
split.
  intros b1 b3 d; intros.
  simpl.
  destruct (compose_sm_as_injD _ _ _ _ _ H0)
     as [b2 [d1 [d2 [AI12' [AI23' X]]]]]; subst; trivial; clear H0.
  rewrite compose_sm_DomSrc, compose_sm_DomTgt.
  assert (DomSrc (compose_sm mu12' mu23') b1 = true /\
          DomTgt (compose_sm mu12' mu23') b3 = true).
    rewrite compose_sm_DomSrc, compose_sm_DomTgt.
    split. eapply as_inj_DomRng; eassumption.
           eapply as_inj_DomRng; eassumption.
  destruct H0 as [DOM1 TGT3]; simpl in *.
  assert (TGT2: DomTgt mu12' b2 = true).
    eapply as_inj_DomRng. eassumption. eapply WD12'.
  assert (DOMB2: DomSrc mu23' b2 = true).
    eapply as_inj_DomRng. eassumption. eapply WD23'.
  rewrite compose_sm_DomSrc, compose_sm_DomTgt in *.
  remember (as_inj mu12 b1) as q.
  destruct q; apply eq_sym in Heqq.
    destruct p.
    specialize (intern_incr_as_inj _ _ inc12 WD12' _ _ _ Heqq); intros.
    rewrite AI12' in H0. apply eq_sym in H0. inv H0.
    destruct (joinD_Some _ _ _ _ _ Heqq); clear Heqq.
    (*extern12Some*)
       assert (extern_of mu12' b1 = Some (b2, d1)).
          rewrite <- (intern_incr_extern _ _ inc12). assumption.
       destruct (joinD_None _ _ _ H); clear H.
       clear AI12'.
       destruct (joinD_Some _ _ _ _ _ AI23'); clear AI23'.
       (*extern23'Some*)
         assert (extern_of mu23 b2 = Some (b3, d2)).
           rewrite (intern_incr_extern _ _ inc23). assumption.
         rewrite compose_sm_extern in H2.
         unfold compose_meminj in H2.
         rewrite H0 in H2. rewrite H4 in H2. inv H2.
       (*extern23'None*)
         destruct H.
         rewrite compose_sm_extern in H2.
         destruct (compose_meminjD_None _ _ _ H2); clear H2.
            rewrite H5 in H0. discriminate.
         destruct H5 as [bb2 [dd1 [EXT12 EXT23]]].
         rewrite EXT12 in H0. inv H0.
         rewrite compose_sm_local in H3.
         remember (local_of mu23 b2) as qq.
         destruct qq; apply eq_sym in Heqqq.
            destruct p.
            specialize (intern_incr_local _ _ inc23); intros.
            specialize (H0 _ _ _ Heqqq). rewrite H0 in H4. inv H4.
            destruct (extern_DomRng _ WD12 _ _ _ EXT12) as [A B].
            destruct (local_DomRng _ WD23 _ _ _ Heqqq) as [AA BB].
            rewrite BlocksExt in B.
            destruct (disjoint_extern_local_Src _ WD23 b2); congruence.
         destruct (AsInj23 b2 b3 d2).
            apply joinI_None. assumption. assumption.
            apply join_incr_right.
              apply disjoint_extern_local. assumption.
              assumption.
         destruct (extern_DomRng _ WD12 _ _ _ EXT12) as [XX YY].
           rewrite BlocksExt in YY. unfold DomSrc in H0.
           rewrite YY in H0. rewrite orb_comm in H0. discriminate.
    (*extern12None*)
       destruct H0.
       assert (extern_of mu12' b1 = None).
          rewrite <- (intern_incr_extern _ _ inc12). assumption.
       assert (local_of mu12' b1 = Some (b2, d1)).
          eapply (intern_incr_local _ _ inc12). assumption.
       destruct (joinD_None _ _ _ H); clear H.
       clear AI12'.
       destruct (joinD_Some _ _ _ _ _ AI23'); clear AI23'.
       (*extern23'Some*)
         destruct (local_DomRng _ WD12' _ _ _ H3) as [AA BB].
         destruct (extern_DomRng _ WD23' _ _ _ H) as [A B].
         destruct (local_DomRng _ WD12 _ _ _ H1) as [AAA BBB].
         rewrite BlocksLoc in BBB.
         assert (locBlocksSrc mu23' b2 = true). apply inc23. assumption.
         destruct (disjoint_extern_local_Src _ WD23' b2); congruence.
       (*extern23'None*)
         destruct H.
         assert (extern_of mu23 b2 = None).
           rewrite (intern_incr_extern _ _ inc23). assumption.
         rewrite compose_sm_local in H5.
         unfold compose_meminj in H5. rewrite H1 in H5.
         remember (local_of mu23 b2).
         destruct o. destruct p. inv H5. clear H5. apply eq_sym in Heqo.
         clear H4.
         destruct (local_DomRng _ WD12 _ _ _ H1) as [AA BB].
         assert (DomSrc mu23 b2 = false /\ DomTgt mu23 b3 = false).
            eapply AsInj23.
              apply joinI_None; assumption.
              apply join_incr_right; try eassumption.
                apply disjoint_extern_local; eassumption.
         destruct H4.
         destruct (local_locBlocks _ WD12 _ _ _ H1)
           as [AAA [BBB [CCC [DDD [EEE FFF]]]]].
         rewrite BlocksLoc in BBB. unfold DomSrc in H4.
             rewrite BBB in H4. discriminate.
   (*as_inj mu12 b1 = None*)
     destruct (AsInj12 _ _ _ Heqq AI12'). split; trivial. clear H.
     remember (as_inj mu23 b2) as d.
     destruct d; apply eq_sym in Heqd.
       destruct p.
       specialize (intern_incr_as_inj _ _ inc23 WD23' _ _ _ Heqd).
       intros ZZ; rewrite AI23' in ZZ. apply eq_sym in ZZ; inv ZZ.
       destruct (as_inj_DomRng _ _ _ _ Heqd WD23).
       unfold DomSrc in H. unfold DomTgt in H1.
       rewrite BlocksLoc, BlocksExt in H1. rewrite H1 in H; discriminate.
     eapply AsInj23. eassumption. eassumption.
simpl.
  split. apply DomTgt12. apply Sep23.
Qed.*)

Lemma vis_compose_sm: forall mu nu, vis (compose_sm mu nu) = vis mu.
Proof. intros. unfold vis. destruct mu; simpl. reflexivity. Qed.

Lemma restrict_compose: forall j k X,
  restrict (compose_meminj j k) X = compose_meminj (restrict j X) k.
Proof. intros.
  extensionality b.
  unfold compose_meminj, restrict.
  remember (X b) as d.
  destruct d; trivial.
Qed.


Require Import Lia.
Require Import RelationClasses.

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

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

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

Require Import Syntax.
Require Import Semantics.

Require Import PromiseConsistent.
Require Import SimpleSimulation.

Require Import AMemory.
Require Import ALocal.
Require Import ATView.
Require Import AThread.

Require Import PFCommon.
Require Import PFStep.
Require Import PFCertify.
Require Import Invariant.

Set Implicit Arguments.

Section AssertInsertion.
  Variable
    (S:ThreadsProp)
    (J:MemoryProp)
    (program: Threads.syntax).

  Context `{LOGIC: Logic.t S J program}.

  (* simulation relations on threads *)

  Inductive insert_assertion (tid: Ident.t): forall (stmts_src stmts_tgt: list Stmt.t), Prop :=
  | insert_assertion_nil:
      insert_assertion tid [] []
  | insert_assertion_instr
      (i: Instr.t) stmts_src stmts_tgt
      (SIM: insert_assertion tid stmts_src stmts_tgt):
      insert_assertion tid ((Stmt.instr i)::stmts_src) ((Stmt.instr i)::stmts_tgt)
  | insert_assertion_ite
      cond
      stmts1_src stmts2_src stmts_src
      stmts1_tgt stmts2_tgt stmts_tgt
      (SIM1: insert_assertion tid (stmts1_src ++ stmts_src) (stmts1_tgt ++ stmts_tgt))
      (SIM2: insert_assertion tid (stmts2_src ++ stmts_src) (stmts2_tgt ++ stmts_tgt)):
      insert_assertion tid
                       ((Stmt.ite cond stmts1_src stmts2_src)::stmts_src)
                       ((Stmt.ite cond stmts1_tgt stmts2_tgt)::stmts_tgt)
  | insert_assertion_dowhile
      cond
      stmts1_src stmts_src
      stmts1_tgt stmts_tgt
      (SIM: insert_assertion tid
                             (stmts1_src ++ (Stmt.ite cond ((Stmt.dowhile stmts1_src cond)::nil) nil) :: stmts_src)
                             (stmts1_tgt ++ (Stmt.ite cond ((Stmt.dowhile stmts1_tgt cond)::nil) nil) :: stmts_tgt)):
      insert_assertion tid
                       ((Stmt.dowhile stmts1_src cond)::stmts_src)
                       ((Stmt.dowhile stmts1_tgt cond)::stmts_tgt)
  | insert_assertion_assert
      c stmts_src stmts_tgt
      (SIM: insert_assertion tid stmts_src stmts_tgt)
      (SUCCESS: forall rs (TH: S tid lang (State.mk rs stmts_src)),
          RegFile.eval_expr rs c <> 0):
      insert_assertion tid stmts_src ((Stmt.ite c [Stmt.instr Instr.abort] nil)::stmts_tgt)
  .
  #[local]
  Hint Constructors insert_assertion: core.

  Inductive sim_state (tid: Ident.t) (st_src st_tgt: State.t): Prop :=
  | sim_state_intro
      (STMTS: insert_assertion tid (State.stmts st_src) (State.stmts st_tgt))
      (REGS: (State.regs st_src) = (State.regs st_tgt))
  .
  #[local]
  Hint Constructors sim_state: core.

  Inductive sim_thread (tid: Ident.t) (e_src e_tgt: Thread.t lang): Prop :=
  | sim_thread_intro
      (STATE: sim_state tid (Thread.state e_src) (Thread.state e_tgt))
      (LOCAL: (Thread.local e_src) = (Thread.local e_tgt))
      (SC: (Thread.sc e_src) = (Thread.sc e_tgt))
      (MEMORY: (Thread.memory e_src) = (Thread.memory e_tgt))
  .
  #[local]
  Hint Constructors sim_thread: core.

  Lemma sim_state_step
        tid st1_src
        e st1_tgt st2_tgt
        (SIM1: sim_state tid st1_src st1_tgt)
        (STEP: (Language.step lang) e st1_tgt st2_tgt):
    (exists st2_src,
        <<STEP_SRC: State.opt_step e st1_src st2_src>> /\
        <<SIM2: sim_state tid st2_src st2_tgt>>) \/
    (exists c stmts,
        <<STMTS: (State.stmts st1_tgt) =
                 (Stmt.ite c [Stmt.instr Instr.abort] nil)::stmts>> /\
        <<SUCCESS: forall (SOUND: S tid lang st1_src),
            RegFile.eval_expr (State.regs st1_src) c <> 0>> /\
        <<FAIL: RegFile.eval_expr (State.regs st1_src) c = 0>>).
  Proof.
    destruct st1_src, st1_tgt, st2_tgt.
    inv SIM1. ss. subst.
    inv STMTS.
    - inv STEP.
    - left.
      exists (State.mk regs1 stmts_src).
      inv STEP. split; eauto.
      econs 2. econs; eauto.
    - left.
      inv STEP. esplits.
      + econs 2. econs; eauto.
      + condtac; eauto.
    - left.
      inv STEP. esplits.
      + econs 2. econs; eauto.
      + ss.
    - inv STEP. condtac; ss.
      + right. esplits; eauto.
      + left. esplits; [econs 1|]. ss.
  Qed.

  Lemma sim_thread_promise_step
        tid e1_src
        pf e e1_tgt e2_tgt
        (SIM1: sim_thread tid e1_src e1_tgt)
        (STEP_TGT: Thread.promise_step pf e e1_tgt e2_tgt):
    exists e2_src,
      <<STEP_SRC: Thread.promise_step pf e e1_src e2_src>> /\
      <<SIM2: sim_thread tid e2_src e2_tgt>>.
  Proof.
    destruct e1_src, e1_tgt, e2_tgt. ss.
    inv SIM1. ss. subst.
    inv STEP_TGT; ss.
    esplits.
    - econs; eauto.
    - eauto.
  Qed.

  Lemma sim_thread_program_step
        tid e1_src
        e e1_tgt e2_tgt
        (SIM1: sim_thread tid e1_src e1_tgt)
        (STEP_TGT: Thread.program_step e e1_tgt e2_tgt):
    (exists e2_src,
        <<STEP_SRC: Thread.opt_program_step e e1_src e2_src>> /\
        <<SIM2: sim_thread tid e2_src e2_tgt>>) \/
    (exists c stmts,
        <<STMTS: (State.stmts (Thread.state e1_tgt)) =
                 (Stmt.ite c [Stmt.instr Instr.abort] nil)::stmts>> /\
        <<SUCCESS: forall (SOUND: S tid lang (Thread.state e1_src)),
            RegFile.eval_expr (State.regs (Thread.state e1_src)) c <> 0>> /\
        <<FAIL: RegFile.eval_expr (State.regs (Thread.state e1_src)) c = 0>>).
  Proof.
    destruct e1_src, e1_tgt, e2_tgt. ss.
    inv SIM1. ss. subst.
    inv STEP_TGT; ss.
    exploit sim_state_step; eauto. i. des; cycle 1.
    { right. esplits; eauto. }
    left. inv LOCAL; inv STEP_SRC; ss.
    - esplits.
      + econs 1.
      + econs; eauto.
    - esplits.
      + econs 2. econs; eauto.
      + econs; eauto.
    - esplits.
      + econs 2. econs; eauto.
      + econs; eauto.
    - esplits.
      + econs 2. econs; eauto.
      + econs; eauto.
    - esplits.
      + econs 2. econs; eauto.
      + econs; eauto.
    - esplits.
      + econs 2. econs; eauto.
      + econs; eauto.
    - esplits.
      + econs 2. econs; eauto.
      + econs; eauto.
    - esplits.
      + econs 2. econs; eauto.
      + econs; eauto.
  Qed.

  Lemma sim_thread_step
        tid e1_src
        pf e e1_tgt e2_tgt
        (SIM1: sim_thread tid e1_src e1_tgt)
        (STEP_TGT: Thread.step pf e e1_tgt e2_tgt):
    (exists e2_src,
        <<STEP_SRC: Thread.opt_step e e1_src e2_src>> /\
        <<SIM2: sim_thread tid e2_src e2_tgt>>) \/
    (exists c stmts,
        <<STMTS: (State.stmts (Thread.state e1_tgt)) =
                 (Stmt.ite c [Stmt.instr Instr.abort] nil)::stmts>> /\
        <<ASSERT: forall (SOUND: S tid lang (Thread.state e1_src)),
            RegFile.eval_expr (State.regs (Thread.state e1_src)) c <> 0>> /\
        <<FAIL: RegFile.eval_expr (State.regs (Thread.state e1_src)) c = 0>>).
  Proof.
    inv STEP_TGT.
    - left.
      exploit sim_thread_promise_step; eauto. i. des.
      esplits; eauto.
      econs 2. econs 1. eauto.
    - exploit sim_thread_program_step; eauto. i. des.
      + left. esplits; eauto.
        inv STEP_SRC.
        * econs 1.
        * econs 2. econs 2. eauto.
      + right. esplits; eauto.
  Qed.

  Lemma sim_thread_rtc_tau_step
        tid e1_src e1_tgt e2_tgt
        (SIM1: sim_thread tid e1_src e1_tgt)
        (STEPS_TGT: rtc (@Thread.tau_step lang) e1_tgt e2_tgt):
    (exists e2_src,
        <<STEPS_SRC: rtc (@Thread.tau_step lang) e1_src e2_src>> /\
        <<SIM2: sim_thread tid e2_src e2_tgt>>) \/
    (exists e_src e_tgt c stmts,
        <<STEPS1_TGT: rtc (@Thread.tau_step lang) e1_tgt e_tgt>> /\
        <<STEPS2_TGT: rtc (@Thread.tau_step lang) e_tgt e2_tgt>> /\
        <<STEPS_SRC: rtc (@Thread.tau_step lang) e1_src e_src>> /\
        <<SIM: sim_thread tid e_src e_tgt>> /\
        <<STMTS: (State.stmts (Thread.state e_tgt)) =
                 (Stmt.ite c [Stmt.instr Instr.abort] nil)::stmts>> /\
        <<ASSERT: forall (SOUND: S tid lang (Thread.state e_src)),
            RegFile.eval_expr (State.regs (Thread.state e_src)) c <> 0>> /\
        <<FAIL: RegFile.eval_expr (State.regs (Thread.state e_src)) c = 0>>).
  Proof.
    revert e1_src SIM1.
    induction STEPS_TGT; eauto; i.
    inv H. inv TSTEP.
    exploit sim_thread_step; eauto. i. des.
    - exploit IHSTEPS_TGT; eauto. i. des.
      + left. esplits; [|eauto].
        inv STEP_SRC; eauto.
        econs 2; eauto.
        econs; [econs; eauto|ss].
      + right.
        esplits; try exact STEPS2_TGT; try exact SIM; eauto.
        * econs 2; eauto.
          econs; [econs; eauto|ss].
        * inv STEP_SRC; eauto.
          econs 2; eauto.
          econs; [econs; eauto|ss].
    - right.
      esplits; try exact SIM1; eauto.
      econs 2; eauto.
      econs; [econs; eauto| ss].
  Qed.

  Lemma sim_thread_rtc_program_step
        tid e1_src e1_tgt e2_tgt
        (SIM1: sim_thread tid e1_src e1_tgt)
        (STEPS_TGT: rtc (tau (@Thread.program_step lang)) e1_tgt e2_tgt):
    (exists e2_src,
        <<STEPS_SRC: rtc (tau (@Thread.program_step lang)) e1_src e2_src>> /\
        <<SIM2: sim_thread tid e2_src e2_tgt>>) \/
    (exists e_src e_tgt c stmts,
        <<STEPS1_TGT: rtc (tau (@Thread.program_step lang)) e1_tgt e_tgt>> /\
        <<STEPS2_TGT: rtc (tau (@Thread.program_step lang)) e_tgt e2_tgt>> /\
        <<STEPS_SRC: rtc (tau (@Thread.program_step lang)) e1_src e_src>> /\
        <<SIM: sim_thread tid e_src e_tgt>> /\
        <<STMTS: (State.stmts (Thread.state e_tgt)) =
                 (Stmt.ite c [Stmt.instr Instr.abort] nil)::stmts>> /\
        <<ASSERT: forall (SOUND: S tid lang (Thread.state e_src)),
            RegFile.eval_expr (State.regs (Thread.state e_src)) c <> 0>> /\
        <<FAIL: RegFile.eval_expr (State.regs (Thread.state e_src)) c = 0>>).
  Proof.
    revert e1_src SIM1.
    induction STEPS_TGT; eauto; i.
    inv H.
    exploit sim_thread_program_step; eauto. i. des.
    - exploit IHSTEPS_TGT; eauto. i. des.
      + left. esplits; [|eauto].
        inv STEP_SRC; eauto.
      + right.
        esplits; try exact STEPS2_TGT; try exact SIM; eauto.
        inv STEP_SRC; eauto.
    - right.
      esplits; try exact SIM1; eauto.
  Qed.

  (* simulation relation on configurations *)

  Inductive sim_conf (c_src c_tgt: Configuration.t): Prop :=
  | sim_conf_intro
      (SEM: sem S J c_src)
      (TIDS: Threads.tids (Configuration.threads c_src) = Threads.tids (Configuration.threads c_tgt))
      (FIND_SRC: forall tid l st_src lc_src
                   (FIND: IdentMap.find tid (Configuration.threads c_src) = Some (existT _ l st_src, lc_src)),
          l = lang)
      (FIND_TGT: forall tid l st_tgt lc_tgt
                   (FIND: IdentMap.find tid (Configuration.threads c_tgt) = Some (existT _ l st_tgt, lc_tgt)),
          l = lang)
      (THREADS: forall tid st_src lc_src st_tgt lc_tgt
                  (FIND_SRC: IdentMap.find tid (Configuration.threads c_src) = Some (existT _ lang st_src, lc_src))
                  (FIND_TGT: IdentMap.find tid (Configuration.threads c_tgt) = Some (existT _ lang st_tgt, lc_tgt)),
          <<STATE: sim_state tid st_src st_tgt>> /\
          <<LOCAL: lc_src = lc_tgt>>)
      (SC: (Configuration.sc c_src) = (Configuration.sc c_tgt))
      (MEMORY: (Configuration.memory c_src) = (Configuration.memory c_tgt))
  .
  #[local]
  Hint Constructors sim_conf: core.

  Lemma sim_conf_find
        c_src c_tgt tid
        (SIM: sim_conf c_src c_tgt):
    (exists lang_src st_src lc_src,
        IdentMap.find tid (Configuration.threads c_src) = Some (existT _ lang_src st_src, lc_src)) <->
    (exists lang_tgt st_tgt lc_tgt,
        IdentMap.find tid (Configuration.threads c_tgt) = Some (existT _ lang_tgt st_tgt, lc_tgt)).
  Proof.
    inv SIM. destruct c_src, c_tgt. ss.
    eapply Threads.tids_find; eauto.
  Qed.

  Lemma sim_conf_sim_thread
        c_src c_tgt
        tid st_src lc_src st_tgt lc_tgt
        (SIM: sim_conf c_src c_tgt)
        (FIND_SRC: IdentMap.find tid (Configuration.threads c_src) = Some (existT _ lang st_src, lc_src))
        (FIND_TGT: IdentMap.find tid (Configuration.threads c_tgt) = Some (existT _ lang st_tgt, lc_tgt)):
    sim_thread tid
               (Thread.mk lang st_src lc_src (Configuration.sc c_src) (Configuration.memory c_src))
               (Thread.mk lang st_tgt lc_tgt (Configuration.sc c_tgt) (Configuration.memory c_tgt)).
  Proof.
    inv SIM. exploit THREADS; eauto. i. des.
    econs; eauto.
  Qed.

  Lemma sim_conf_sim
        c_src c_tgt
        (SIM: sim_conf c_src c_tgt):
    sim c_src c_tgt.
  Proof.
    revert c_src c_tgt SIM.
    pcofix CIH. i. pfold. econs; ii.
    { (* terminal *)
      esplits; eauto. ii.
      exploit sim_conf_find; eauto. i. des.
      exploit x0; eauto. i. des.
      inv SIM. ss.
      exploit FIND_SRC; eauto. i. subst.
      exploit FIND_TGT; eauto. i. subst.
      exploit THREADS; eauto. i. des. subst.
      exploit TERMINAL_TGT; eauto. i. des.
      split; auto.
      destruct st, st_tgt; ss. inv STATE0. ss. subst.
      inv STATE. inv STMTS. ss.
    }
    inv STEP_TGT.
    { (* failure step *)
      exploit sim_conf_find; eauto. i. des.
      exploit x1; eauto. i. des. clear x0 x1.
      destruct c_src as [ths1_src sc1_src mem1_src].
      destruct c_tgt as [ths1_tgt sc1 mem1].
      dup SIM. inv SIM0. ss. subst.
      exploit FIND_SRC; eauto. i. subst.
      exploit FIND_TGT; eauto. i. subst.
      clear FIND_SRC FIND_TGT THREADS.
      exploit sim_conf_sim_thread; eauto. s. intro SIM_TH.
      exploit sim_thread_rtc_tau_step; eauto. i. des.
      - exploit sim_thread_step; eauto. i. des; cycle 1.
        { destruct e2, state. ss. subst.
          inv STEP; inv STEP0. inv STATE. }
        inv STEP_SRC. destruct e2_src0. ss.
        assert (CSTEP: Configuration.step
                         MachineEvent.failure tid
                         (Configuration.mk ths1_src sc1 mem1)
                         (Configuration.mk
                            (IdentMap.add tid (existT (fun (lang: language) => (Language.state lang)) lang state, local) ths1_src)
                            sc memory)).
        { econs 1; eauto. }
        esplits; [econs 2; eauto|].
        right. apply CIH. econs; ss; try by (inv SIM0; ss).
        + eapply configuration_step_sem; try exact CSTEP; eauto.
        + repeat rewrite Threads.tids_add.
          repeat rewrite IdentSet.add_mem; ss.
          * rewrite Threads.tids_o. rewrite TID. ss.
          * rewrite Threads.tids_o. rewrite x2. ss.
        + i. revert FIND. rewrite IdentMap.gsspec. condtac; ss; i.
          * inv FIND. ss.
          * inv SIM. eapply FIND_SRC; eauto.
        + i. revert FIND. rewrite IdentMap.gsspec. condtac; ss; i.
          * inv FIND. ss.
          * inv SIM. eapply FIND_TGT; eauto.
        + i. revert FIND_SRC. rewrite IdentMap.gsspec. condtac; ss; i.
          * subst. revert FIND_TGT. rewrite IdentMap.gsspec. condtac; ss; i.
            Configuration.simplify2. inv SIM0. ss.
          * revert FIND_TGT. rewrite IdentMap.gsspec. condtac; ss; i.
            inv SIM. eauto.
      - exfalso.
        dup WF_TGT. inv WF_TGT0. inv WF. ss. clear DISJOINT.
        exploit THREADS; eauto. intro WF1_TGT. clear THREADS.
        dup WF_SRC. inv WF_SRC0. inv WF. ss. clear DISJOINT.
        exploit THREADS; eauto. intro WF1_SRC. clear THREADS.
        exploit Thread.rtc_tau_step_future; try exact STEPS1_TGT; eauto. s. i. des.
        exploit (@PFStep.sim_thread_exists lang (Thread.mk lang st_src lc_src sc1 mem1)); ss; eauto. i. des.
        exploit PFStep.thread_rtc_tau_step; try exact SIM1; eauto.
        { inv SIM0. rewrite LOCAL.
          inv STEP; inv STEP0. inv LOCAL0. inv LOCAL1.
          eapply rtc_tau_step_promise_consistent; eauto. }
        i. des.
        inv SEM. ss. exploit TH; eauto. i.
        exploit rtc_tau_aprogram_step_sem; try exact STEPS_SRC0; eauto.
        { inv SIM1. ss. rewrite STATE. eauto. }
        { eapply vals_incl_sem_memory; eauto.
          eapply PFStep.sim_memory_vals_incl; try eapply SIM1. }
        { eapply PFStep.sim_memory_inhabited; try eapply SIM1; ss.
          - apply WF1_SRC.
          - apply MEM. }
        i. des.
        inv SIM2. rewrite STATE in *.
        eapply ASSERT; eauto.
    }
    (* normal step *)
    exploit sim_conf_find; eauto. i. des.
    exploit x1; eauto. i. des. clear x0 x1.
    destruct c_src as [ths1_src sc1_src mem1_src].
    destruct c_tgt as [ths1_tgt sc1 mem1].
    dup SIM. inv SIM0. ss. subst.
    exploit FIND_SRC; eauto. i. subst.
    exploit FIND_TGT; eauto. i. subst.
    clear FIND_SRC FIND_TGT THREADS.
    exploit sim_conf_sim_thread; eauto. s. intro SIM_TH.
    dup WF_TGT. inv WF_TGT0. inv WF. ss. clear DISJOINT.
    exploit THREADS; eauto. intro WF1_TGT. clear THREADS.
    dup WF_SRC. inv WF_SRC0. inv WF. ss. clear DISJOINT.
    exploit THREADS; eauto. intro WF1_SRC. clear THREADS.
    exploit Thread.rtc_tau_step_future; eauto. s. i. des.
    exploit Thread.step_future; eauto. s. i. des.
    exploit sim_thread_rtc_tau_step; eauto. i. des; cycle 1.
    { exfalso.
      exploit Thread.rtc_tau_step_future; try exact STEPS1_TGT; eauto. s. i. des.
      exploit (@PFStep.sim_thread_exists lang (Thread.mk lang st_src lc_src sc1 mem1)); ss; eauto. i. des.
      exploit PFStep.thread_rtc_tau_step; try exact SIM1; eauto.
      { inv SIM0. rewrite LOCAL.
        eapply rtc_tau_step_promise_consistent; eauto.
        eapply step_promise_consistent; eauto.
        eapply consistent_promise_consistent; eauto. }
      i. des.
      inv SEM. ss. exploit TH; eauto. i.
      exploit rtc_tau_aprogram_step_sem; try exact STEPS_SRC0; eauto.
      { inv SIM1. ss. rewrite STATE. eauto. }
      { eapply vals_incl_sem_memory; eauto.
        eapply PFStep.sim_memory_vals_incl; try eapply SIM1. }
      { eapply PFStep.sim_memory_inhabited; try eapply SIM1; ss.
        - apply WF1_SRC.
        - apply MEM. }
      i. des.
      inv SIM2. rewrite STATE in *.
      eapply ASSERT; eauto.
    }
    exploit sim_thread_step; eauto. i. des; cycle 1.
    { exfalso.
      exploit Thread.rtc_tau_step_future; try exact STEPS1_TGT; eauto. s. i. des.
      exploit (@PFStep.sim_thread_exists lang (Thread.mk lang st_src lc_src sc1 mem1)); ss; eauto. i. des.
      exploit PFStep.thread_rtc_tau_step; try exact SIM0; eauto.
      { inv SIM2. rewrite LOCAL.
        eapply step_promise_consistent; eauto.
        eapply consistent_promise_consistent; eauto. }
      i. des.
      inv SEM. ss. exploit TH; eauto. i.
      exploit rtc_tau_aprogram_step_sem; try exact STEPS_SRC0; eauto.
      { inv SIM0. ss. rewrite STATE. eauto. }
      { eapply vals_incl_sem_memory; eauto.
        eapply PFStep.sim_memory_vals_incl; try eapply SIM0. }
      { eapply PFStep.sim_memory_inhabited; try eapply SIM0; ss.
        - apply WF1_SRC.
        - apply MEM. }
      i. des.
      inv SIM1. rewrite STATE in *.
      eapply ASSERT; eauto.
    }
    destruct e2_src0.
    assert (CONSISTENT_SRC: Thread.consistent (Thread.mk lang state local sc memory)).
    { exploit Memory.cap_exists; try exact CLOSED0. i. des.
      exploit Memory.cap_closed; eauto. intro CLOSED_CAP.
      exploit Local.cap_wf; try exact WF0; eauto. intro WF_CAP.
      exploit Memory.max_full_timemap_exists; try apply CLOSED_CAP. i. des.
      hexploit Memory.max_full_timemap_closed; try exact x1; eauto. intro SC_MAX.
      dup SIM0. inv SIM1. ss. subst. ii. ss.
      exploit Memory.cap_inj; [exact CAP|exact CAP0|..]; eauto. i. subst.
      exploit Memory.max_full_timemap_inj; [exact x0|exact SC_MAX0|..]. i. subst.
      exploit CONSISTENT; eauto. s. i. des.
      - (* failure certification *)
        left. unfold Thread.steps_failure in *. des.
        exploit (@sim_thread_rtc_tau_step tid (Thread.mk lang state lc3 sc0 mem0));
          try exact STEPS0; eauto.
        i. des; cycle 1.
        { exfalso.
          exploit Thread.tau_opt_all; try exact STEPS_SRC; eauto. i.
          exploit (@PFStep.sim_thread_exists lang (Thread.mk lang st_src lc_src sc1 mem1)); ss; eauto. i. des.
          exploit PFStep.thread_rtc_all_step; try exact x2; eauto.
          { hexploit consistent_promise_consistent; eauto. }
          i. des.
          exploit PFCertify.sim_thread_exists; try exact SIM4; eauto. s. i. des.
          exploit PFCertify.thread_rtc_tau_step; try exact STEPS_SRC0; eauto.
          { exploit Thread.rtc_tau_step_future; try exact STEPS1_TGT; eauto. s. i. des.
            inv SIM1. rewrite LOCAL.
            eapply rtc_tau_step_promise_consistent; eauto.
            inv FAILURE0; inv STEP0. inv LOCAL0. inv LOCAL1. ss. }
          i. des.
          inv SEM. ss. exploit TH; eauto. i.
          exploit rtc_all_aprogram_step_sem; try exact STEPS_SRC; eauto.
          { inv SIM3. ss. rewrite STATE0. eauto. }
          { eapply vals_incl_sem_memory; eauto.
            eapply PFStep.sim_memory_vals_incl; try eapply SIM3. }
          { eapply PFStep.sim_memory_inhabited; try eapply SIM3; ss.
            - apply WF1_SRC.
            - apply MEM. }
          i. des.
          exploit rtc_pf_step_sem; try exact STEPS_SRC2; eauto; s.
          { eapply vals_incl_sem_memory; eauto. }
          { eapply PFCertify.sim_memory_inhabited; try eapply SIM5.
            - apply WF0.
            - eapply Memory.cap_closed; eauto. }
          i. des.
          inv SIM6. rewrite STATE0 in *.
          eapply ASSERT; eauto.
        }
        exploit sim_thread_step; try exact SIM1; eauto. i. des; cycle 1.
        { exfalso.
          exploit Thread.tau_opt_all; try exact STEPS_SRC; eauto. i.
          exploit (@PFStep.sim_thread_exists lang (Thread.mk lang st_src lc_src sc1 mem1)); ss; eauto. i. des.
          exploit PFStep.thread_rtc_all_step; try exact x2; eauto.
          { hexploit consistent_promise_consistent; eauto. }
          i. des.
          exploit PFCertify.sim_thread_exists; try exact SIM4; eauto. s. i. des.
          exploit PFCertify.thread_rtc_tau_step; try exact STEPS_SRC0; eauto.
          { exploit Thread.rtc_tau_step_future; try exact STEPS0; eauto. s. i. des.
            inv SIM1. rewrite LOCAL.
            eapply rtc_tau_step_promise_consistent; eauto.
            inv FAILURE0; inv STEP0. inv LOCAL0. inv LOCAL1. ss. }
          i. des.
          inv SEM. ss. exploit TH; eauto. i.
          exploit rtc_all_aprogram_step_sem; try exact STEPS_SRC; eauto.
          { inv SIM3. ss. rewrite STATE0. eauto. }
          { eapply vals_incl_sem_memory; eauto.
            eapply PFStep.sim_memory_vals_incl; try eapply SIM3. }
          { eapply PFStep.sim_memory_inhabited; try eapply SIM3; ss.
            - apply WF1_SRC.
            - apply MEM. }
          i. des.
          exploit rtc_pf_step_sem; try exact STEPS_SRC2; eauto; s.
          { eapply vals_incl_sem_memory; eauto. }
          { eapply PFCertify.sim_memory_inhabited; try eapply SIM5.
            - apply WF0.
            - eapply Memory.cap_closed; eauto. }
          i. des.
          inv SIM6. rewrite STATE0 in *.
          eapply ASSERT; eauto.
        }
        inv STEP_SRC0. destruct pf0; try by (inv STEP0; inv STEP1).
        esplits; eauto.
      - (* normal certification *)
        right.
        exploit (@sim_thread_rtc_tau_step tid (Thread.mk lang state lc3 sc0 mem0));
          try exact STEPS0; eauto. i. des; cycle 1.
        { exfalso.
          exploit Thread.tau_opt_all; try exact STEPS_SRC; eauto. i.
          exploit (@PFStep.sim_thread_exists lang (Thread.mk lang st_src lc_src sc1 mem1)); ss; eauto. i. des.
          exploit PFStep.thread_rtc_all_step; try exact x2; eauto.
          { hexploit consistent_promise_consistent; eauto. }
          i. des.
          exploit PFCertify.sim_thread_exists; try exact SIM4; eauto. s. i. des.
          exploit PFCertify.thread_rtc_tau_step; try exact STEPS_SRC0; eauto.
          { exploit Thread.rtc_tau_step_future; try exact STEPS1_TGT; eauto. s. i. des.
            inv SIM1. rewrite LOCAL.
            eapply rtc_tau_step_promise_consistent; eauto.
            eapply Local.bot_promise_consistent; eauto. }
          i. des.
          inv SEM. ss. exploit TH; eauto. i.
          exploit rtc_all_aprogram_step_sem; try exact STEPS_SRC; eauto.
          { inv SIM3. ss. rewrite STATE0. eauto. }
          { eapply vals_incl_sem_memory; eauto.
            eapply PFStep.sim_memory_vals_incl; try eapply SIM3. }
          { eapply PFStep.sim_memory_inhabited; try eapply SIM3; ss.
            - apply WF1_SRC.
            - apply MEM. }
          i. des.
          exploit rtc_pf_step_sem; try exact STEPS_SRC2; eauto; s.
          { eapply vals_incl_sem_memory; eauto. }
          { eapply PFCertify.sim_memory_inhabited; try eapply SIM5.
            - apply WF0.
            - eapply Memory.cap_closed; eauto. }
          i. des.
          inv SIM6. rewrite STATE0 in *.
          eapply ASSERT; eauto.
        }
        esplits; eauto.
        inv SIM1. rewrite LOCAL. ss.
    }
    assert (CSTEP: Configuration.opt_step
                     (ThreadEvent.get_machine_event e0) tid
                     (Configuration.mk ths1_src sc1 mem1)
                     (Configuration.mk
                        (IdentMap.add tid (existT (fun (lang: language) => (Language.state lang)) lang state, local) ths1_src)
                        sc memory)).
    { inv STEP_SRC.
      - generalize (rtc_tail STEPS_SRC). i. des.
        + inv H0. inv TSTEP. ss. rewrite <- EVENT0.
          econs 2. econs; try exact x; try exact H; eauto.
          destruct e; ss.
        + inv H. ss.
          replace (IdentMap.add
                     tid
                     (existT (fun lang:language => (Language.state lang)) lang state, local)
                     ths1_src)
            with ths1_src; eauto.
          apply IdentMap.eq_leibniz. ii.
          rewrite -> IdentMap.gsident; auto.
      - econs 2. econs 2; try exact x; try exact H; eauto.
    }
    esplits; eauto.
    right. apply CIH. econs; ss; try by (inv SIM0; ss).
    - inv CSTEP; ss.
      + repeat rewrite <- H. ss.
      + eapply configuration_step_sem; try exact STEP0; eauto.
    - repeat rewrite Threads.tids_add.
      repeat rewrite IdentSet.add_mem; ss.
      + rewrite Threads.tids_o. rewrite TID. ss.
      + rewrite Threads.tids_o. rewrite x2. ss.
    - i. revert FIND. rewrite IdentMap.gsspec. condtac; ss; i.
      + inv FIND. ss.
      + inv SIM. eapply FIND_SRC; eauto.
    - i. revert FIND. rewrite IdentMap.gsspec. condtac; ss; i.
      + inv FIND. ss.
      + inv SIM. eapply FIND_TGT; eauto.
    - i. revert FIND_SRC. rewrite IdentMap.gsspec. condtac; ss; i.
      + subst. revert FIND_TGT. rewrite IdentMap.gsspec. condtac; ss; i.
        Configuration.simplify2. inv SIM0. ss.
      + revert FIND_TGT. rewrite IdentMap.gsspec. condtac; ss; i.
        inv SIM. eauto.
  Qed.

  (* assert insertion *)

  Definition syntax_tids (pgm: Threads.syntax): IdentSet.t :=
    List.fold_right (fun p s => IdentSet.add (fst p) s) IdentSet.empty (IdentMap.elements pgm).

  Lemma syntax_tids_o tid pgm:
    IdentSet.mem tid (syntax_tids pgm) = IdentMap.find tid pgm.
  Proof.
    unfold syntax_tids. rewrite IdentMap.Facts.elements_o.
    induction (IdentMap.elements pgm); ss. destruct a. s.
    rewrite IdentSet.Facts.add_b, IHl.
    unfold IdentSet.Facts.eqb, IdentMap.Facts.eqb.
    repeat match goal with
           | [|- context[if ?c then true else false]] => destruct c
           end; ss; congr.
  Qed.

  Inductive insert_assertion_program (program_tgt: Threads.syntax): Prop :=
  | insert_assertion_program_intro
      (TIDS: syntax_tids program_tgt = syntax_tids program)
      (FIND_SRC: forall tid l syn_src
                   (FIND: IdentMap.find tid program = Some (existT _ l syn_src)),
          l = lang)
      (FIND_TGT: forall tid l syn_tgt
                   (FIND: IdentMap.find tid program_tgt = Some (existT _ l syn_tgt)),
          l = lang)
      (THREADS: forall tid syn_src syn_tgt
                  (FIND_SRC: IdentMap.find tid program = Some (existT _ lang syn_src))
                  (FIND_TGT: IdentMap.find tid program_tgt = Some (existT _ lang syn_tgt)),
          insert_assertion tid syn_src syn_tgt)
  .

  Lemma init_sim_conf
        program_tgt
        (INSERT: insert_assertion_program program_tgt):
    sim_conf (Configuration.init program) (Configuration.init program_tgt).
  Proof.
    inv INSERT. econs; ss; i.
    - apply init_sem; ss.
    - apply IdentSet.ext. i.
      repeat rewrite Threads.tids_o.
      unfold Threads.init.
      repeat rewrite IdentMap.Facts.map_o.
      specialize (@syntax_tids_o i program). i.
      specialize (@syntax_tids_o i program_tgt). i.
      destruct (@UsualFMapPositive.UsualPositiveMap'.find
                  (@sigT _ (@Language.syntax ProgramEvent.t)) i program) eqn:SRC;
        destruct (@UsualFMapPositive.UsualPositiveMap'.find
                    (@sigT _ (@Language.syntax ProgramEvent.t)) i program_tgt) eqn:TGT; ss.
      + assert (@UsualFMapPositive.UsualPositiveMap'.find
                  (@sigT _ (@Language.syntax ProgramEvent.t)) i program = IdentMap.find i program) by ss.
        rewrite <- H1 in *. rewrite SRC in *. ss.
        assert (@UsualFMapPositive.UsualPositiveMap'.find
                  (@sigT _ (@Language.syntax ProgramEvent.t)) i program_tgt = IdentMap.find i program_tgt) by ss.
        rewrite <- H2 in *. rewrite TGT in *. ss.
        rewrite TIDS in *. congr.
      + assert (@UsualFMapPositive.UsualPositiveMap'.find
                  (@sigT _ (@Language.syntax ProgramEvent.t)) i program = IdentMap.find i program) by ss.
        rewrite <- H1 in *. rewrite SRC in *. ss.
        assert (@UsualFMapPositive.UsualPositiveMap'.find
                  (@sigT _ (@Language.syntax ProgramEvent.t)) i program_tgt = IdentMap.find i program_tgt) by ss.
        rewrite <- H2 in *. rewrite TGT in *. ss.
        rewrite TIDS in *. congr.
    - unfold Threads.init in *.
      rewrite IdentMap.Facts.map_o in *.
      destruct (@UsualFMapPositive.UsualPositiveMap'.find
                  (@sigT _ (@Language.syntax ProgramEvent.t)) tid program) eqn:SRC; ss.
      destruct s. ss. inv FIND. eapply FIND_SRC; eauto.
    - unfold Threads.init in *.
      rewrite IdentMap.Facts.map_o in *.
      destruct (@UsualFMapPositive.UsualPositiveMap'.find
                  (@sigT _ (@Language.syntax ProgramEvent.t)) tid program_tgt) eqn:SRC; ss.
      destruct s. ss. inv FIND. eapply FIND_TGT; eauto.
    - unfold Threads.init in *.
      rewrite IdentMap.Facts.map_o in *.
      destruct (@UsualFMapPositive.UsualPositiveMap'.find
                  (@sigT _ (@Language.syntax ProgramEvent.t)) tid program) eqn:SRC;
        destruct (@UsualFMapPositive.UsualPositiveMap'.find
                    (@sigT _ (@Language.syntax ProgramEvent.t)) tid program_tgt) eqn:TGT; ss.
      destruct s, s0; ss.
      inv FIND_SRC0. inv FIND_TGT0. split; ss. Configuration.simplify2.
      unfold State.init. econs; ss.
      eapply THREADS; eauto.
  Qed.

  Theorem insert_assertion_behavior
          program_tgt
          (INSERT: insert_assertion_program program_tgt):
    behaviors Configuration.step (Configuration.init program_tgt) <1=
    behaviors Configuration.step (Configuration.init program).
  Proof.
    exploit init_sim_conf; eauto. i.
    specialize (Configuration.init_wf program). intro WF_SRC.
    specialize (Configuration.init_wf program_tgt). intro WF_TGT.
    hexploit sim_conf_sim; eauto. i.
    exploit sim_adequacy; try exact H; eauto.
  Qed.
End AssertInsertion.


From iris.program_logic Require Export weakestpre.
From iris.proofmode Require Import tactics.
From iris.bi Require Import fixpoint big_op.
Set Default Proof Using "Type".
Import uPred.

Definition twp_pre `{irisG Λ Σ} (s : stuckness)
      (wp : coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ) :
    coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ := λ E e1 Φ,
  match to_val e1 with
  | Some v => |={E}=> Φ v
  | None => ∀ σ1,
     state_interp σ1 ={E,∅}=∗ ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
     ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅,E}=∗
       state_interp σ2 ∗ wp E e2 Φ ∗
       [∗ list] ef ∈ efs, wp ⊤ ef (λ _, True)
  end%I.

Lemma twp_pre_mono `{irisG Λ Σ} s
    (wp1 wp2 : coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ) :
  ((□ ∀ E e Φ, wp1 E e Φ -∗ wp2 E e Φ) →
  ∀ E e Φ, twp_pre s wp1 E e Φ -∗ twp_pre s wp2 E e Φ)%I.
Proof.
  iIntros "#H"; iIntros (E e1 Φ) "Hwp". rewrite /twp_pre.
  destruct (to_val e1) as [v|]; first done.
  iIntros (σ1) "Hσ". iMod ("Hwp" with "Hσ") as "($ & Hwp)"; iModIntro.
  iIntros (e2 σ2 efs) "Hstep".
  iMod ("Hwp" with "Hstep") as "($ & Hwp & Hfork)"; iModIntro; iSplitL "Hwp".
  - by iApply "H".
  - iApply (@big_sepL_impl with "[$Hfork]"); iIntros "!#" (k e _) "Hwp".
    by iApply "H".
Qed.

(* Uncurry [twp_pre] and equip its type with an OFE structure *)
Definition twp_pre' `{irisG Λ Σ} (s : stuckness) :
  (prodC (prodC (leibnizC coPset) (exprC Λ)) (val Λ -c> iProp Σ) → iProp Σ) →
  prodC (prodC (leibnizC coPset) (exprC Λ)) (val Λ -c> iProp Σ) → iProp Σ :=
    curry3 ∘ twp_pre s ∘ uncurry3.

Local Instance twp_pre_mono' `{irisG Λ Σ} s : BiMonoPred (twp_pre' s).
Proof.
  constructor.
  - iIntros (wp1 wp2) "#H"; iIntros ([[E e1] Φ]); iRevert (E e1 Φ).
    iApply twp_pre_mono. iIntros "!#" (E e Φ). iApply ("H" $! (E,e,Φ)).
  - intros wp Hwp n [[E1 e1] Φ1] [[E2 e2] Φ2]
      [[?%leibniz_equiv ?%leibniz_equiv] ?]; simplify_eq/=.
    rewrite /uncurry3 /twp_pre. do 16 (f_equiv || done). by apply Hwp, pair_ne.
Qed.

Definition twp_def `{irisG Λ Σ} (s : stuckness) (E : coPset)
    (e : expr Λ) (Φ : val Λ → iProp Σ) :
  iProp Σ := bi_least_fixpoint (twp_pre' s) (E,e,Φ).
Definition twp_aux `{irisG Λ Σ} : seal (@twp_def Λ Σ _). by eexists. Qed.
Instance twp' `{irisG Λ Σ} : Twp Λ (iProp Σ) stuckness := twp_aux.(unseal).
Definition twp_eq `{irisG Λ Σ} : twp = @twp_def Λ Σ _ := twp_aux.(seal_eq).

Section twp.
Context `{irisG Λ Σ}.
Implicit Types s : stuckness.
Implicit Types P : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.
Implicit Types v : val Λ.
Implicit Types e : expr Λ.

(* Weakest pre *)
Lemma twp_unfold s E e Φ : WP e @ s; E [{ Φ }] ⊣⊢ twp_pre s (twp s) E e Φ.
Proof. by rewrite twp_eq /twp_def least_fixpoint_unfold. Qed.
Lemma twp_ind s Ψ :
  (∀ n E e, Proper (pointwise_relation _ (dist n) ==> dist n) (Ψ E e)) →
  (□ (∀ e E Φ, twp_pre s (λ E e Φ, Ψ E e Φ ∧ WP e @ s; E [{ Φ }]) E e Φ -∗ Ψ E e Φ) →
  ∀ e E Φ, WP e @ s; E [{ Φ }] -∗ Ψ E e Φ)%I.
Proof.
  iIntros (HΨ). iIntros "#IH" (e E Φ) "H". rewrite twp_eq.
  set (Ψ' := curry3 Ψ :
    prodC (prodC (leibnizC coPset) (exprC Λ)) (val Λ -c> iProp Σ) → iProp Σ).
  assert (NonExpansive Ψ').
  { intros n [[E1 e1] Φ1] [[E2 e2] Φ2]
      [[?%leibniz_equiv ?%leibniz_equiv] ?]; simplify_eq/=. by apply HΨ. }
  iApply (least_fixpoint_strong_ind _ Ψ' with "[] H").
  iIntros "!#" ([[??] ?]) "H". by iApply "IH".
Qed.

Global Instance twp_ne s E e n :
  Proper (pointwise_relation _ (dist n) ==> dist n) (twp (PROP:=iProp Σ) s E e).
Proof.
  intros Φ1 Φ2 HΦ. rewrite !twp_eq. by apply (least_fixpoint_ne _), pair_ne, HΦ.
Qed.
Global Instance twp_proper s E e :
  Proper (pointwise_relation _ (≡) ==> (≡)) (twp (PROP:=iProp Σ) s E e).
Proof.
  by intros Φ Φ' ?; apply equiv_dist=>n; apply twp_ne=>v; apply equiv_dist.
Qed.

Lemma twp_value' s E Φ v : Φ v -∗ WP of_val v @ s; E [{ Φ }].
Proof. iIntros "HΦ". rewrite twp_unfold /twp_pre to_of_val. auto. Qed.
Lemma twp_value_inv' s E Φ v : WP of_val v @ s; E [{ Φ }] ={E}=∗ Φ v.
Proof. by rewrite twp_unfold /twp_pre to_of_val. Qed.

Lemma twp_strong_mono s1 s2 E1 E2 e Φ Ψ :
  s1 ⊑ s2 → E1 ⊆ E2 →
  WP e @ s1; E1 [{ Φ }] -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ WP e @ s2; E2 [{ Ψ }].
Proof.
  iIntros (? HE) "H HΦ". iRevert (E2 Ψ HE) "HΦ"; iRevert (e E1 Φ) "H".
  iApply twp_ind; first solve_proper.
  iIntros "!#" (e E1 Φ) "IH"; iIntros (E2 Ψ HE) "HΦ".
  rewrite !twp_unfold /twp_pre. destruct (to_val e) as [v|] eqn:?.
  { iApply ("HΦ" with "[> -]"). by iApply (fupd_mask_mono E1 _). }
  iIntros (σ1) "Hσ". iMod (fupd_intro_mask' E2 E1) as "Hclose"; first done.
  iMod ("IH" with "[$]") as "[% IH]".
  iModIntro; iSplit; [by destruct s1, s2|]. iIntros (e2 σ2 efs Hstep).
  iMod ("IH" with "[//]") as "($ & IH & IHefs)"; auto.
  iMod "Hclose" as "_"; iModIntro. iSplitR "IHefs".
  - iDestruct "IH" as "[IH _]". iApply ("IH" with "[//] HΦ").
  - iApply (big_sepL_impl with "[$IHefs]"); iIntros "!#" (k ef _) "[IH _]".
    by iApply "IH".
Qed.

Lemma fupd_twp s E e Φ : (|={E}=> WP e @ s; E [{ Φ }]) -∗ WP e @ s; E [{ Φ }].
Proof.
  rewrite twp_unfold /twp_pre. iIntros "H". destruct (to_val e) as [v|] eqn:?.
  { by iMod "H". }
  iIntros (σ1) "Hσ1". iMod "H". by iApply "H".
Qed.
Lemma twp_fupd s E e Φ : WP e @ s; E [{ v, |={E}=> Φ v }] -∗ WP e @ s; E [{ Φ }].
Proof. iIntros "H". iApply (twp_strong_mono with "H"); auto. Qed.

Lemma twp_atomic s E1 E2 e Φ `{!Atomic (stuckness_to_atomicity s) e} :
  (|={E1,E2}=> WP e @ s; E2 [{ v, |={E2,E1}=> Φ v }]) -∗ WP e @ s; E1 [{ Φ }].
Proof.
  iIntros "H". rewrite !twp_unfold /twp_pre /=.
  destruct (to_val e) as [v|] eqn:He.
  { by iDestruct "H" as ">>> $". }
  iIntros (σ1) "Hσ". iMod "H". iMod ("H" $! σ1 with "Hσ") as "[$ H]".
  iModIntro. iIntros (e2 σ2 efs Hstep).
  iMod ("H" with "[//]") as "(Hphy & H & $)". destruct s.
  - rewrite !twp_unfold /twp_pre. destruct (to_val e2) as [v2|] eqn:He2.
    + iDestruct "H" as ">> $". by iFrame.
    + iMod ("H" with "[$]") as "[H _]". iDestruct "H" as %(? & ? & ? & ?).
      by edestruct (atomic _ _ _ _ Hstep).
  - destruct (atomic _ _ _ _ Hstep) as [v <-%of_to_val].
    iMod (twp_value_inv' with "H") as ">H". iFrame "Hphy". by iApply twp_value'.
Qed.

Lemma twp_bind K `{!LanguageCtx K} s E e Φ :
  WP e @ s; E [{ v, WP K (of_val v) @ s; E [{ Φ }] }] -∗ WP K e @ s; E [{ Φ }].
Proof.
  revert Φ. cut (∀ Φ', WP e @ s; E [{ Φ' }] -∗ ∀ Φ,
    (∀ v, Φ' v -∗ WP K (of_val v) @ s; E [{ Φ }]) -∗ WP K e @ s; E [{ Φ }]).
  { iIntros (help Φ) "H". iApply (help with "H"); auto. }
  iIntros (Φ') "H". iRevert (e E Φ') "H". iApply twp_ind; first solve_proper.
  iIntros "!#" (e E1 Φ') "IH". iIntros (Φ) "HΦ".
  rewrite /twp_pre. destruct (to_val e) as [v|] eqn:He.
  { apply of_to_val in He as <-. iApply fupd_twp. by iApply "HΦ". }
  rewrite twp_unfold /twp_pre fill_not_val //.
  iIntros (σ1) "Hσ". iMod ("IH" with "[$]") as "[% IH]". iModIntro; iSplit.
  { iPureIntro. unfold reducible in *.
    destruct s; naive_solver eauto using fill_step. }
  iIntros (e2 σ2 efs Hstep).
  destruct (fill_step_inv e σ1 e2 σ2 efs) as (e2'&->&?); auto.
  iMod ("IH" $! e2' σ2 efs with "[//]") as "($ & IH & IHfork)".
  iModIntro; iSplitR "IHfork".
  - iDestruct "IH" as "[IH _]". by iApply "IH".
  - by setoid_rewrite and_elim_r.
Qed.

Lemma twp_bind_inv K `{!LanguageCtx K} s E e Φ :
  WP K e @ s; E [{ Φ }] -∗ WP e @ s; E [{ v, WP K (of_val v) @ s; E [{ Φ }] }].
Proof.
  iIntros "H". remember (K e) as e' eqn:He'.
  iRevert (e He'). iRevert (e' E Φ) "H". iApply twp_ind; first solve_proper.
  iIntros "!#" (e' E1 Φ) "IH". iIntros (e ->).
  rewrite !twp_unfold {2}/twp_pre. destruct (to_val e) as [v|] eqn:He.
  { iModIntro. apply of_to_val in He as <-. rewrite !twp_unfold.
    iApply (twp_pre_mono with "[] IH"). by iIntros "!#" (E e Φ') "[_ ?]". }
  rewrite /twp_pre fill_not_val //.
  iIntros (σ1) "Hσ". iMod ("IH" with "[$]") as "[% IH]". iModIntro; iSplit.
  { destruct s; eauto using reducible_fill. }
  iIntros (e2 σ2 efs Hstep).
  iMod ("IH" $! (K e2) σ2 efs with "[]") as "($ & IH & IHfork)"; eauto using fill_step.
  iModIntro; iSplitR "IHfork".
  - iDestruct "IH" as "[IH _]". by iApply "IH".
  - by setoid_rewrite and_elim_r.
Qed.

Lemma twp_wp s E e Φ : WP e @ s; E [{ Φ }] -∗ WP e @ s; E {{ Φ }}.
Proof.
  iIntros "H". iLöb as "IH" forall (E e Φ).
  rewrite wp_unfold twp_unfold /wp_pre /twp_pre. destruct (to_val e) as [v|]=>//.
  iIntros (σ1) "Hσ". iMod ("H" with "Hσ") as "[$ H]". iIntros "!>".
  iIntros (e2 σ2 efs) "Hstep". iMod ("H" with "Hstep") as "($ & H & Hfork)".
  iApply step_fupd_intro; [set_solver+|]. iNext.
  iSplitL "H". by iApply "IH". iApply (@big_sepL_impl with "[$Hfork]").
  iIntros "!#" (k e' _) "H". by iApply "IH".
Qed.

(** * Derived rules *)
Lemma twp_mono s E e Φ Ψ :
  (∀ v, Φ v -∗ Ψ v) → WP e @ s; E [{ Φ }] -∗ WP e @ s; E [{ Ψ }].
Proof.
  iIntros (HΦ) "H"; iApply (twp_strong_mono with "H"); auto.
  iIntros (v) "?". by iApply HΦ.
Qed.
Lemma twp_stuck_mono s1 s2 E e Φ :
  s1 ⊑ s2 → WP e @ s1; E [{ Φ }] ⊢ WP e @ s2; E [{ Φ }].
Proof. iIntros (?) "H". iApply (twp_strong_mono with "H"); auto. Qed.
Lemma twp_stuck_weaken s E e Φ :
  WP e @ s; E [{ Φ }] ⊢ WP e @ E ?[{ Φ }].
Proof. apply twp_stuck_mono. by destruct s. Qed.
Lemma twp_mask_mono s E1 E2 e Φ :
  E1 ⊆ E2 → WP e @ s; E1 [{ Φ }] -∗ WP e @ s; E2 [{ Φ }].
Proof. iIntros (?) "H"; iApply (twp_strong_mono with "H"); auto. Qed.
Global Instance twp_mono' s E e :
  Proper (pointwise_relation _ (⊢) ==> (⊢)) (twp (PROP:=iProp Σ) s E e).
Proof. by intros Φ Φ' ?; apply twp_mono. Qed.

Lemma twp_value s E Φ e v : IntoVal e v → Φ v -∗ WP e @ s; E [{ Φ }].
Proof. intros <-. by apply twp_value'. Qed.
Lemma twp_value_fupd' s E Φ v : (|={E}=> Φ v) -∗ WP of_val v @ s; E [{ Φ }].
Proof. intros. by rewrite -twp_fupd -twp_value'. Qed.
Lemma twp_value_fupd s E Φ e v : IntoVal e v → (|={E}=> Φ v) -∗ WP e @ s; E [{ Φ }].
Proof. intros ?. rewrite -twp_fupd -twp_value //. Qed.
Lemma twp_value_inv s E Φ e v : IntoVal e v → WP e @ s; E [{ Φ }] ={E}=∗ Φ v.
Proof. intros <-. by apply twp_value_inv'. Qed.

Lemma twp_frame_l s E e Φ R : R ∗ WP e @ s; E [{ Φ }] -∗ WP e @ s; E [{ v, R ∗ Φ v }].
Proof. iIntros "[? H]". iApply (twp_strong_mono with "H"); auto with iFrame. Qed.
Lemma twp_frame_r s E e Φ R : WP e @ s; E [{ Φ }] ∗ R -∗ WP e @ s; E [{ v, Φ v ∗ R }].
Proof. iIntros "[H ?]". iApply (twp_strong_mono with "H"); auto with iFrame. Qed.

Lemma twp_wand s E e Φ Ψ :
  WP e @ s; E [{ Φ }] -∗ (∀ v, Φ v -∗ Ψ v) -∗ WP e @ s; E [{ Ψ }].
Proof.
  iIntros "H HΦ". iApply (twp_strong_mono with "H"); auto.
  iIntros (?) "?". by iApply "HΦ".
Qed.
Lemma twp_wand_l s E e Φ Ψ :
  (∀ v, Φ v -∗ Ψ v) ∗ WP e @ s; E [{ Φ }] -∗ WP e @ s; E [{ Ψ }].
Proof. iIntros "[H Hwp]". iApply (twp_wand with "Hwp H"). Qed.
Lemma twp_wand_r s E e Φ Ψ :
  WP e @ s; E [{ Φ }] ∗ (∀ v, Φ v -∗ Ψ v) -∗ WP e @ s; E [{ Ψ }].
Proof. iIntros "[Hwp H]". iApply (twp_wand with "Hwp H"). Qed.
End twp.

(** Proofmode class instances *)
Section proofmode_classes.
  Context `{irisG Λ Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : val Λ → iProp Σ.

  Global Instance frame_twp p s E e R Φ Ψ :
    (∀ v, Frame p R (Φ v) (Ψ v)) →
    Frame p R (WP e @ s; E [{ Φ }]) (WP e @ s; E [{ Ψ }]).
  Proof. rewrite /Frame=> HR. rewrite twp_frame_l. apply twp_mono, HR. Qed.

  Global Instance is_except_0_wp s E e Φ : IsExcept0 (WP e @ s; E [{ Φ }]).
  Proof. by rewrite /IsExcept0 -{2}fupd_twp -except_0_fupd -fupd_intro. Qed.

  Global Instance elim_modal_bupd_twp p s E e P Φ :
    ElimModal True p false (|==> P) P (WP e @ s; E [{ Φ }]) (WP e @ s; E [{ Φ }]).
  Proof.
    by rewrite /ElimModal intuitionistically_if_elim
      (bupd_fupd E) fupd_frame_r wand_elim_r fupd_twp.
  Qed.

  Global Instance elim_modal_fupd_twp p s E e P Φ :
    ElimModal True p false (|={E}=> P) P (WP e @ s; E [{ Φ }]) (WP e @ s; E [{ Φ }]).
  Proof.
    by rewrite /ElimModal intuitionistically_if_elim
      fupd_frame_r wand_elim_r fupd_twp.
  Qed.

  Global Instance elim_modal_fupd_twp_atomic p s E1 E2 e P Φ :
    Atomic (stuckness_to_atomicity s) e →
    ElimModal True p false (|={E1,E2}=> P) P
            (WP e @ s; E1 [{ Φ }]) (WP e @ s; E2 [{ v, |={E2,E1}=> Φ v }])%I.
  Proof.
    intros. by rewrite /ElimModal intuitionistically_if_elim
      fupd_frame_r wand_elim_r twp_atomic.
  Qed.

  Global Instance add_modal_fupd_twp s E e P Φ :
    AddModal (|={E}=> P) P (WP e @ s; E [{ Φ }]).
  Proof. by rewrite /AddModal fupd_frame_r wand_elim_r fupd_twp. Qed.
End proofmode_classes.


(* Concurrent Compiler Correcntess *)

(** Prove a simulation between the Clight concurrent semantics and
    the x86 concurrent semantics.
*)

Require Import VST.concurrency.compiler.HybridMachine_simulation.

(*Clight Machine *)
Require Import VST.concurrency.common.ClightMachine.
(*Asm Machine*)
Require Import VST.concurrency.common.x86_context.

Section ConcurrentCopmpilerSpecification.
  (*Import the Clight Hybrid Machine*)
  Import ClightMachine.
  Import DMS.
  (*Import the Asm X86 Hybrid Machine*)
  Import X86Context.

  (*Import the Asm Hybrid Machine*)
  Context (Clight_g : Clight.genv).
  Context (Asm_g : Clight.genv).
  Context (Asm_program: Asm.program).
  Context (Asm_genv_safe: Asm_core.safe_genv (@the_ge Asm_program)).

  Variable opt_init_mem_source: option Memory.Mem.mem.
  Variable opt_init_mem_target: option Memory.Mem.mem.
  Definition ConcurrentCompilerCorrectness_specification: Type:=
    HybridMachine_simulation (ClightConcurSem(ge:=Clight_g) opt_init_mem_source) (@AsmConcurSem Asm_program Asm_genv_safe opt_init_mem_target).

End ConcurrentCopmpilerSpecification.