Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Maps.
Require Import compcert.lib.Integers.

Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import compcert.common.Events.
Require Import compcert.common.AST.
Require Import compcert.common.Globalenvs.

Require Import msl.Axioms.

Require Import sepcomp.mem_lemmas.
Require Import sepcomp.semantics.
Require Import sepcomp.semantics_lemmas.
Require Import sepcomp.effect_semantics.
Require Import sepcomp.structured_injections.
Require Import sepcomp.reach.
Require Import sepcomp.effect_simulations.

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

        (*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,
        match_states c1 mu c1 m1 c2 m2 ->
        at_external Sem1 c1 = Some (e,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,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 vals2 e'
        (MemInjMu: Mem.inject (as_inj mu) m1 m2)
        (MatchMu: match_states st1 mu st1 m1 st2 m2)
        (AtExtSrc: at_external Sem1 st1 = Some (e,vals1))

        (AtExtTgt: at_external Sem2 st2 = Some (e',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')
        (SEP: sm_inject_separated nu nu' m1 m2)

        (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' /\
          sm_inject_separated mu mu' m1 m2 /\
          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.
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)
    as [c2 [INI MS]].
  exists c1, c2. intuition.
clear - inj_effcore_diagram.
  intros. destruct H0; subst.
  destruct (inj_effcore_diagram _ _ _ _ _ H _ _ _ H1) as
    [c2' [m2' [mu' [INC [SEP [LAC [MC' [U2 [STEP' PROP]]]]]]]]].
  exists c2'. exists m2'. exists st1'. exists mu'.
  split; try assumption.
  split; try assumption.
  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 SEP
      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 vals2 e'
        (MemInjMu: Mem.inject (as_inj mu) m1 m2)
        (MatchMu: match_states st1 mu st1 m1 st2 m2)
        (AtExtSrc: at_external Sem1 st1 = Some (e,vals1))

        (AtExtTgt: at_external Sem2 st2 = Some (e',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')
        (SEP: sm_inject_separated nu nu' m1 m2)

        (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' /\
          sm_inject_separated mu mu' m1 m2 /\
          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.
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)
    as [c2 [INI MS]].
  exists c1, c2. intuition.
clear - inj_effcore_diagram.
  intros. destruct H0; subst.
  destruct (inj_effcore_diagram _ _ _ _ _ H _ _ _ H1) as
    [c2' [m2' [mu' [INC [SEP [LAC [MC' [U2 [STEP' PROP]]]]]]]]].
  exists c2'. exists m2'. exists st1'. exists mu'.
  split; try assumption.
  split; try assumption.
  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 SEP
      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 vals2 e'
        (MemInjMu: Mem.inject (as_inj mu) m1 m2)
        (MatchMu: match_states st1 mu st1 m1 st2 m2)
        (AtExtSrc: at_external Sem1 st1 = Some (e,vals1))

        (AtExtTgt: at_external Sem2 st2 = Some (e',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')
        (SEP: sm_inject_separated nu nu' m1 m2)

        (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' /\
          sm_inject_separated mu mu' m1 m2 /\
          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. intros.
  destruct (inj_effcore_diagram _ _ _ _ _ H _ _ _ H0)
    as [c2' [m2' [mu' [INC [SEP [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.

Section EFF_INJ_SIMULATION_STAR_TYPED.
  Variable measure: C1 -> nat.

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

        (AtExtTgt: at_external Sem2 st2 = Some (e',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')
        (SEP: sm_inject_separated nu nu' m1 m2)

        (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' /\
          sm_inject_separated mu mu' m1 m2 /\
          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 [SEP [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 vals2 e'
        (MemInjMu: Mem.inject (as_inj mu) m1 m2)
        (MatchMu: match_states st1 mu st1 m1 st2 m2)
        (AtExtSrc: at_external Sem1 st1 = Some (e,vals1))

        (AtExtTgt: at_external Sem2 st2 = Some (e',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')
        (SEP: sm_inject_separated nu nu' m1 m2)

        (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' /\
          sm_inject_separated mu mu' m1 m2 /\
          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 vals2 e'
        (MemInjMu: Mem.inject (as_inj mu) m1 m2)
        (MatchMu: match_states st1 mu st1 m1 st2 m2)
        (AtExtSrc: at_external Sem1 st1 = Some (e,vals1))

        (AtExtTgt: at_external Sem2 st2 = Some (e',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')
        (SEP: sm_inject_separated nu nu' m1 m2)

        (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' /\
          sm_inject_separated mu mu' m1 m2 /\
          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_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.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*                       mCertiKOS C Source Code                       *)
(*                                                                     *)
(*                        Xiongnan (Newman) Wu                         *)
(*                                                                     *)
(*                          Yale University                            *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Cop.
Require Import Clight.
Require Import CDataTypes.
Require Import Ctypes.

(**
<<
      #define NUM_PROC 64

      extern void set_cr3 (char ** );

      extern char * PTPool_LOC[NUM_PROC][1024];

      void set_pt(unsigned int index)
      {
          set_cr3(PTPool_LOC[index]);
      }
>>
 *)

Let tsetpt_index: ident := 1 % positive.

Definition set_pt_body : statement :=
  (Scall None
  (Evar set_cr3 (Tfunction (Tcons (tptr tvoid) Tnil) tvoid cc_default))
  ((Ederef
     (Ebinop Oadd (Evar PTPool_LOC (tarray (tarray (tptr tchar) 1024) 64))
       (Etempvar tsetpt_index tint) (tptr (tarray (tptr tchar) 1024)))
     (tarray (tptr tchar) 1024)) :: nil))
.

Definition f_set_pt := {|
                        fn_return := Tvoid;
                        fn_callconv := cc_default;
                        fn_vars := nil;
                        fn_params := ((tsetpt_index, tint) :: nil);
                        fn_temps := nil;
                        fn_body := set_pt_body
                      |}.

(**
<<
      #define NUM_PROC 64

      extern char * PTPool_LOC[NUM_PROC][1024];

      unsigned int get_PDE(unsigned int proc_index, unsigned int pde_index)
      {
          unsigned int pde;
          pde = (unsigned int)PTPool_LOC[proc_index][pde_index] / 4096;
          return pde;
      }
>>
 *)

Let tproc_index: ident := 1 % positive.
Let tpde_index: ident := 2 % positive.
Let tpde: ident := 3 % positive.

Definition get_PDE_body : statement :=
  (Ssequence
     (Sset tpde
           (Ebinop Odiv
                   (Ecast
                      (Ederef
                         (Ebinop Oadd
                                 (Ederef
                                    (Ebinop Oadd
                                            (Evar PTPool_LOC (tarray (tarray (tptr tchar) 1024) 64))
                                            (Etempvar tproc_index tint)
                                            (tptr (tarray (tptr tchar) 1024)))
                                    (tarray (tptr tchar) 1024)) (Etempvar tpde_index tint)
                                 (tptr (tptr tchar))) (tptr tchar)) tint)
                   (Econst_int (Int.repr 4096) tint) tint))
     (Sreturn (Some (Etempvar tpde tint))))
.

Definition f_get_PDE := {|
                         fn_return := tint;
                         fn_callconv := cc_default;
                         fn_params := ((tproc_index, tint) :: (tpde_index, tint) :: nil);
                         fn_vars := nil;
                         fn_temps := ((tpde, tint) :: nil);
                         fn_body := get_PDE_body
                       |}.

(**
<<
     #define NUM_PROC 64
     #define PT_PERM_PTU 7

     extern char * PTPool_LOC[NUM_PROC][1024];
     extern unsigned int IDPMap_LOC[1024][1024];

     void set_PDE(unsigned int proc_index, unsigned int pde_index)
     {
         PTPool_LOC[proc_index][pde_index] = ((char * )(IDPMap_LOC[pde_index])) + PT_PERM_PTU;
     }
>>
 *)

Definition set_pde_body: statement :=
  (Sassign
  (Ederef
    (Ebinop Oadd
      (Ederef
        (Ebinop Oadd
          (Evar PTPool_LOC (tarray (tarray (tptr tchar) 1024) 64))
          (Etempvar tproc_index tint) (tptr (tarray (tptr tchar) 1024)))
        (tarray (tptr tchar) 1024)) (Etempvar tpde_index tint)
      (tptr (tptr tchar))) (tptr tchar))
  (Ebinop Oadd
    (Ecast
      (Ederef
        (Ebinop Oadd (Evar IDPMap_LOC (tarray (tarray tint 1024) 1024))
          (Etempvar tpde_index tint) (tptr (tarray tint 1024)))
        (tarray tint 1024)) (tptr tchar)) (Econst_int (Int.repr 7) tint)
    (tptr tchar))).

Definition f_set_pde := {|
                         fn_return := Tvoid;
                         fn_callconv := cc_default;
                         fn_vars := nil;
                         fn_params := ((tproc_index, tint) :: (tpde_index, tint) :: nil);
                         fn_temps := nil;
                         fn_body := set_pde_body
                       |}.

(**
<<
     #define NUM_PROC 64
     #define PT_PERM_UP 0

     extern char * PTPool_LOC[NUM_PROC][1024];

     void rmv_PDE(unsigned int proc_index, unsigned int pde_index)
     {
         PTPool_LOC[proc_index][pde_index] = (char * )PT_PERM_UP;
     }
>>
 *)

Definition rmv_pde_body: statement :=
  (Sassign
  (Ederef
    (Ebinop Oadd
      (Ederef
        (Ebinop Oadd
          (Evar PTPool_LOC (tarray (tarray (tptr tchar) 1024) 64))
          (Etempvar tproc_index tint) (tptr (tarray (tptr tchar) 1024)))
        (tarray (tptr tchar) 1024)) (Etempvar tpde_index tint)
      (tptr (tptr tchar))) (tptr tchar))
  (Ecast (Econst_int (Int.repr 0) tint) (tptr tchar))).

Definition f_rmv_pde := {|
                         fn_return := Tvoid;
                         fn_callconv := cc_default;
                         fn_vars := nil;
                         fn_params := ((tproc_index, tint) :: (tpde_index, tint) :: nil);
                         fn_temps := nil;
                         fn_body := rmv_pde_body
                       |}.

(**
<<
     #define NUM_PROC 64
     #define PT_PERM_PTU 7

     extern char * PTPool_LOC[NUM_PROC][1024];

     void set_PDEU(unsigned int proc_index, unsigned int pde_index, unsigned int pi)
     {
         PTPool_LOC[proc_index][pde_index] = (char * )(pi * 4096 + PT_PERM_PTU);
     }
>>
 *)

Let tpi: ident := 4 % positive.

Definition set_pdeu_body: statement :=
  (Sassign
  (Ederef
    (Ebinop Oadd
      (Ederef
        (Ebinop Oadd
          (Evar PTPool_LOC (tarray (tarray (tptr tchar) 1024) 64))
          (Etempvar tproc_index tint) (tptr (tarray (tptr tchar) 1024)))
        (tarray (tptr tchar) 1024)) (Etempvar tpde_index tint)
      (tptr (tptr tchar))) (tptr tchar))
  (Ecast
    (Ebinop Oadd
      (Ebinop Omul (Etempvar tpi tint) (Econst_int (Int.repr 4096) tint)
        tint) (Econst_int (Int.repr 7) tint) tint) (tptr tchar))).

Definition f_set_pdeu := {|
                         fn_return := Tvoid;
                         fn_callconv := cc_default;
                         fn_vars := nil;
                         fn_params := ((tproc_index, tint) :: (tpde_index, tint) :: (tpi, tint) :: nil);
                         fn_temps := nil;
                         fn_body := set_pdeu_body
                       |}.

(**
<<
     #define NUM_PROC 64
     #define PT_PERM_PTU 7

     extern char * PTPool_LOC[NUM_PROC][1024];
     extern unsigned int fload(unsigned int);

     unsigned int get_PTE(unsigned int proc_index, unsigned int pde_index, unsigned int vadr)
     {
         unsigned int pte;
         unsigned int offset;
         offset = ((unsigned int)PTPool_LOC[proc_index][pde_index] - PT_PERM_PTU) / 4096;
         pte = fload(offset * 1024 + vadr);
         return pte;
     }
>>
 *)

Let tpte: ident := 5 % positive.
Let toffset: ident := 6 % positive.
Let tvadr: ident := 7 % positive.

Definition get_pte_body: statement :=
  (Ssequence
  (Sset toffset
    (Ebinop Odiv
      (Ebinop Osub
        (Ecast
          (Ederef
            (Ebinop Oadd
              (Ederef
                (Ebinop Oadd
                  (Evar PTPool_LOC (tarray (tarray (tptr tchar) 1024) 64))
                  (Etempvar tproc_index tint)
                  (tptr (tarray (tptr tchar) 1024)))
                (tarray (tptr tchar) 1024)) (Etempvar tpde_index tint)
              (tptr (tptr tchar))) (tptr tchar)) tint)
        (Econst_int (Int.repr 7) tint) tint)
      (Econst_int (Int.repr 4096) tint) tint))
  (Ssequence
    (Ssequence
      (Scall (Some 13%positive)
        (Evar fload (Tfunction (Tcons tint Tnil) tint cc_default))
        ((Ebinop Oadd
           (Ebinop Omul (Etempvar toffset tint)
             (Econst_int (Int.repr 1024) tint) tint) (Etempvar tvadr tint)
           tint) :: nil))
      (Sset tpte (Etempvar 13%positive tint)))
      (Sreturn (Some (Etempvar tpte tint))))).

Definition f_get_pte := {|
                         fn_return := tint;
                         fn_callconv := cc_default;
                         fn_vars := nil;
                         fn_params := ((tproc_index, tint) :: (tpde_index, tint) :: (tvadr, tint) :: nil);
                         fn_temps := (toffset, tint) :: (tpte, tint) :: (13%positive, tint) :: nil;
                         fn_body := get_pte_body
                       |}.

(**
<<
     #define NUM_PROC 64
     #define PT_PERM_PTU 7

     extern char * PTPool_LOC[NUM_PROC][1024];
     extern void fstore(unsigned int, unsigned int);

     void set_PTE(unsigned int proc_index, unsigned int pde_index, unsigned int vadr, unsigned int padr, unsigned int perm)
     {
         unsigned int offset;
         offset = ((unsigned int)PTPool_LOC[proc_index][pde_index] - PT_PERM_PTU) / 4096;
         fstore(offset * 1024 + vadr, padr * 4096 + perm);
     }
>>
 *)

Let tpadr: ident := 8 % positive.
Let tperm: ident := 9 % positive.

Definition set_pte_body: statement :=
  (Ssequence
  (Sset toffset
    (Ebinop Odiv
      (Ebinop Osub
        (Ecast
          (Ederef
            (Ebinop Oadd
              (Ederef
                (Ebinop Oadd
                  (Evar PTPool_LOC (tarray (tarray (tptr tchar) 1024) 64))
                  (Etempvar tproc_index tint)
                  (tptr (tarray (tptr tchar) 1024)))
                (tarray (tptr tchar) 1024)) (Etempvar tpde_index tint)
              (tptr (tptr tchar))) (tptr tchar)) tint)
        (Econst_int (Int.repr 7) tint) tint)
      (Econst_int (Int.repr 4096) tint) tint))
  (Scall None
    (Evar fstore (Tfunction (Tcons tint (Tcons tint Tnil)) tvoid cc_default))
    ((Ebinop Oadd
       (Ebinop Omul (Etempvar toffset tint)
         (Econst_int (Int.repr 1024) tint) tint) (Etempvar tvadr tint)
       tint) ::
     (Ebinop Oadd
       (Ebinop Omul (Etempvar tpadr tint) (Econst_int (Int.repr 4096) tint)
         tint) (Etempvar tperm tint) tint) :: nil))).

Definition f_set_pte := {|
                         fn_return := Tvoid;
                         fn_callconv := cc_default;
                         fn_vars := nil;
                         fn_params := ((tproc_index, tint) :: (tpde_index, tint) :: (tvadr, tint) :: (tpadr, tint) :: (tperm, tint) :: nil);
                         fn_temps := (toffset, tint) :: nil;
                         fn_body := set_pte_body
                       |}.

(**
<<
     #define NUM_PROC 64
     #define PT_PERM_PTU 7

     extern char * PTPool_LOC[NUM_PROC][1024];
     extern void fstore(unsigned int, unsigned int);

     void rmv_PTE(unsigned int proc_index, unsigned int pde_index, unsigned int vadr)
     {
         unsigned int offset;
         offset = ((unsigned int)PTPool_LOC[proc_index][pde_index] - PT_PERM_PTU) / 4096;
         fstore(offset * 1024 + vadr, 0);
     }
>>
 *)

Definition rmv_pte_body: statement :=
  (Ssequence
  (Sset toffset
    (Ebinop Odiv
      (Ebinop Osub
        (Ecast
          (Ederef
            (Ebinop Oadd
              (Ederef
                (Ebinop Oadd
                  (Evar PTPool_LOC (tarray (tarray (tptr tchar) 1024) 64))
                  (Etempvar tproc_index tint)
                  (tptr (tarray (tptr tchar) 1024)))
                (tarray (tptr tchar) 1024)) (Etempvar tpde_index tint)
              (tptr (tptr tchar))) (tptr tchar)) tint)
        (Econst_int (Int.repr 7) tint) tint)
      (Econst_int (Int.repr 4096) tint) tint))
  (Scall None
    (Evar fstore (Tfunction (Tcons tint (Tcons tint Tnil)) tvoid cc_default))
    ((Ebinop Oadd
       (Ebinop Omul (Etempvar toffset tint)
         (Econst_int (Int.repr 1024) tint) tint) (Etempvar tvadr tint)
       tint) :: (Econst_int (Int.repr 0) tint) :: nil))).

Definition f_rmv_pte := {|
                         fn_return := Tvoid;
                         fn_callconv := cc_default;
                         fn_vars := nil;
                         fn_params := ((tproc_index, tint) :: (tpde_index, tint) :: (tvadr, tint) :: nil);
                         fn_temps := (toffset, tint) :: nil;
                         fn_body := rmv_pte_body
                       |}.

(**
<<
     extern unsigned int IDPMap_LOC[1024][1024];

     void set_IDPTE(unsigned int pde_index, unsigned int vadr, unsigned int perm)
     {
         IDPMap_LOC[pde_index][vadr] = (pde_index * 1024 + vadr) * 4096 + perm;
     }
>>
 *)

Definition set_idpte_body: statement :=
  (Sassign
  (Ederef
    (Ebinop Oadd
      (Ederef
        (Ebinop Oadd (Evar IDPMap_LOC (tarray (tarray tint 1024) 1024))
          (Etempvar tpde_index tint) (tptr (tarray tint 1024)))
        (tarray tint 1024)) (Etempvar tvadr tint) (tptr tint)) tint)
  (Ebinop Oadd
    (Ebinop Omul
      (Ebinop Oadd
        (Ebinop Omul (Etempvar tpde_index tint)
          (Econst_int (Int.repr 1024) tint) tint) (Etempvar tvadr tint)
        tint) (Econst_int (Int.repr 4096) tint) tint)
    (Etempvar tperm tint) tint)).

Definition f_set_idpte := {|
                         fn_return := Tvoid;
                         fn_callconv := cc_default;
                         fn_vars := nil;
                         fn_params := ((tpde_index, tint) :: (tvadr, tint) :: (tperm, tint) :: nil);
                         fn_temps := nil;
                         fn_body := set_idpte_body
                       |}.


(*
  This module defines the functional unit entries for floating
  point arithmetic.

  TODO: WARNING: check that the instructions set exceptions on invalid rounding modes.
*)
Require Import Kami.AllNotations.
Require Import FpuKami.Definitions.
Require Import FpuKami.MulAdd.
Require Import FpuKami.Compare.
Require Import FpuKami.NFToIN.
Require Import FpuKami.INToNF.
Require Import FpuKami.Classify.
Require Import FpuKami.ModDivSqrt.
Require Import ProcKami.FU.
Require Import ProcKami.RiscvIsaSpec.Insts.Fpu.FpuFuncs.
Require Import List.
Import ListNotations.

Section Fpu.
  Context `{procParams: ProcParams}.
  Context `{fpuParams : FpuParams}.

  Section ty.
    Variable ty : Kind -> Type.

    Open Scope kami_expr.

    Definition csr_invalid_mask : FflagsValue @# ty := Const ty ('b("10000")).

    Definition cmp_cond_width := 2.

    Definition cmp_cond_kind : Kind := Bit cmp_cond_width.

    Definition cmp_cond_not_used : cmp_cond_kind @# ty := $0.
    Definition cmp_cond_eq : cmp_cond_kind @# ty := $1.
    Definition cmp_cond_lt : cmp_cond_kind @# ty := $2.
    Definition cmp_cond_gt : cmp_cond_kind @# ty := $3.

    Definition cmp_cond_get (cond : cmp_cond_kind @# ty) (result : Compare_Output @# ty)
      := ITE (cond == cmp_cond_not_used)
             ($$false)
             (ITE (cond == cmp_cond_eq)
                  (result @% "eq")
                  (ITE (cond == cmp_cond_lt)
                       (result @% "lt")
                       (result @% "gt"))).

    Close Scope kami_expr.

    Definition FCmpInputType
      :  Kind
      := STRUCT_TYPE {
             "fflags" :: FflagsValue;
             "signal" :: Bool;
             "cond0"  :: cmp_cond_kind;
             "cond1"  :: cmp_cond_kind;
             "arg1"   :: NF expWidthMinus2 sigWidthMinus2;
             "arg2"   :: NF expWidthMinus2 sigWidthMinus2
           }.

    Definition FCmpOutputType
      :  Kind
      := STRUCT_TYPE {
             "fflags" :: Maybe FflagsValue;
             "result" :: Bit fpu_len
           }.

    Open Scope kami_expr.

    Definition FCmpInput
        (signal : Bool @# ty)
        (cond0 : cmp_cond_kind @# ty)
        (cond1 : cmp_cond_kind @# ty)
        (_ : ContextCfgPkt @# ty)
        (context_pkt_expr : ExecContextPkt ## ty)
      :  FCmpInputType ## ty
      := LETE context_pkt
           <- context_pkt_expr;
         RetE
           (STRUCT {
              "fflags" ::= #context_pkt @% "fflags";
              "signal" ::= signal;
              "cond0"  ::= cond0;
              "cond1"  ::= cond1;
              "arg1"   ::= bitToNF (fp_get_float Flen (#context_pkt @% "reg1"));
              "arg2"   ::= bitToNF (fp_get_float Flen (#context_pkt @% "reg2"))
            } : FCmpInputType @# ty).

    Definition FCmpOutput
      (resultExpr : FCmpOutputType ## ty)
      :  PktWithException ExecUpdPkt ## ty
      := LETE result <- resultExpr;
         LETC val1 <- (STRUCT {
                               "tag"  ::= $$(natToWord RoutingTagSz IntRegTag);
                               "data" ::= SignExtendTruncLsb Rlen (#result @% "result")
                         } : RoutedReg @# ty);
         LETC val2 <- (STRUCT {
                                  "tag"  ::= $$(natToWord RoutingTagSz FflagsTag);
                                  "data" ::= ZeroExtendTruncLsb Rlen (#result @% "fflags" @% "data")
                         } : RoutedReg @# ty);
         LETC fstVal
           :  ExecUpdPkt
           <- (noUpdPkt ty)
                @%["val1" <- (Valid #val1)]
                @%["val2"
                    <- IF #result @% "fflags" @% "valid"
                         then Valid #val2
                         else Invalid : Maybe RoutedReg @# ty];
         RetE
           (STRUCT {
              "fst" ::= #fstVal;
              "snd" ::= @Invalid ty _
            } : PktWithException ExecUpdPkt @# ty).

    Close Scope kami_expr.

  End ty.

  Open Scope kami_expr.

  Definition FCmp
    :  FUEntry
    := {|
         fuName := append "fcmp" fpu_suffix;
         fuFunc
           := fun ty (sem_in_pkt_expr : FCmpInputType ## ty)
                => LETE sem_in_pkt
                     :  FCmpInputType
                     <- sem_in_pkt_expr;
                   LETE cmp_result
                     :  Compare_Output
                     <- Compare_expr (#sem_in_pkt @% "arg1") (#sem_in_pkt @% "arg2");
                   LETC fflags
                     :  FflagsValue
                     <- ((#sem_in_pkt @% "fflags") .|
                         (ZeroExtendTruncLsb FflagsWidth (csr_invalid_mask ty)));
                   LETC result
                     :  FCmpOutputType
                     <- STRUCT {
                          "fflags"
                            ::= ITE
                                  ((* signaling comparisons *)
                                   ((#sem_in_pkt @% "signal") &&
                                    ((#sem_in_pkt @% "arg1" @% "isNaN") ||
                                     (#sem_in_pkt @% "arg2" @% "isNaN"))) ||
                                    (* quiet comparisons *)
                                   ((!(#sem_in_pkt @% "signal")) &&
                                    ((isSigNaNRawFloat (#sem_in_pkt @% "arg1")) ||
                                     (isSigNaNRawFloat (#sem_in_pkt @% "arg2")))))
                                  (Valid #fflags)
                                  (@Invalid ty FflagsValue);
                          "result"
                          ::= ITE ((#sem_in_pkt @% "arg1" @% "isNaN") ||
                                   (#sem_in_pkt @% "arg2" @% "isNaN"))
                                ($0 : Bit fpu_len @# ty)
                                (ITE
                                  (cmp_cond_get (#sem_in_pkt @% "cond0") #cmp_result ||
                                   cmp_cond_get (#sem_in_pkt @% "cond1") #cmp_result)
                                  $1 $0)
                     } : FCmpOutputType @# ty;
                   RetE #result;
         fuInsts
           := [
                {|
                  instName   := append "feq" fpu_suffix;
                  xlens      := xlens_all;
                  extensions := fpu_exts;
                  ext_ctxt_off := ["fs"];
                  uniqId
                    := [
                         fieldVal fmtField fpu_format_field;
                         fieldVal instSizeField ('b"11");
                         fieldVal opcodeField   ('b"10100");
                         fieldVal funct3Field   ('b"010");
                         fieldVal rs3Field      ('b"10100")
                       ];
                  inputXform  := fun ty => FCmpInput (ty := ty) ($$false) (cmp_cond_eq ty) (cmp_cond_not_used ty);
                  outputXform := FCmpOutput;
                  optMemParams := None;
                  instHints   := falseHints<|hasFrs1 := true|><|hasFrs2 := true|><|hasRd := true|>
                |};
                {|
                  instName   := append "flt" fpu_suffix;
                  xlens      := xlens_all;
                  extensions := fpu_exts;
                  ext_ctxt_off := ["fs"];
                  uniqId
                    := [
                         fieldVal fmtField fpu_format_field;
                         fieldVal instSizeField ('b"11");
                         fieldVal opcodeField   ('b"10100");
                         fieldVal funct3Field   ('b"001");
                         fieldVal rs3Field      ('b"10100")
                       ];
                  inputXform  := fun ty => FCmpInput (ty := ty) ($$true) (cmp_cond_lt ty) (cmp_cond_not_used ty);
                  outputXform := FCmpOutput;
                  optMemParams := None;
                  instHints   := falseHints<|hasFrs1 := true|><|hasFrs2 := true|><|hasRd := true|>
                |};
                {|
                  instName   := append "fle" fpu_suffix;
                  xlens      := xlens_all;
                  extensions := fpu_exts;
                  ext_ctxt_off := ["fs"];
                  uniqId
                    := [
                         fieldVal fmtField fpu_format_field;
                         fieldVal instSizeField ('b"11");
                         fieldVal opcodeField   ('b"10100");
                         fieldVal funct3Field   ('b"000");
                         fieldVal rs3Field      ('b"10100")
                       ];
                  inputXform  := fun ty => FCmpInput (ty := ty) ($$true) (cmp_cond_lt ty) (cmp_cond_eq ty);
                  outputXform := FCmpOutput;
                  optMemParams := None;
                  instHints   := falseHints<|hasFrs1 := true|><|hasFrs2 := true|><|hasRd := true|>
                |}
              ]
       |}.

  Close Scope kami_expr.

End Fpu.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
From fcsl
Require Import pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Freshness State EqTypeX Protocols Worlds NetworkSem Rely.
From DiSeL
Require Import NewStatePredicates.
From DiSeL
Require Import SeqLib.
From DiSeL
Require Import Actions Injection Process Always HoareTriples InferenceRules.
From DiSeL
Require Import TwoPhaseProtocol TwoPhaseCoordinator TwoPhaseParticipant.
From DiSeL
Require TwoPhaseInductiveProof.
From DiSeL
Require Import QueryProtocol QueryHooked.

Section QueryPlusTPC.

(* Querying on behalf of the coordinator (it's easier this way, thanks *)
(* to cn_agreement lemma). In order to query on behald of the *)
(* participan, a different invariant-based fact should be proven. *)

(****************************************************************)
(*************         Basic definitions       ******************)
(****************************************************************)

Variables (lc lq : Label).
Variables (cn : nid) (pts : seq nid).
Hypothesis Lab_neq: lq != lc.
Hypothesis Hnin : cn \notin pts.
Hypothesis Puniq : uniq pts.
Hypothesis PtsNonEmpty : pts != [::].

(* Core protocol *)
Definition pc : protocol := TwoPhaseInductiveProof.tpc_with_inv lc [::] Hnin.
Definition Data : Type := (nat * Log).
Definition qnodes := cn :: pts.

(* Serialization of logs *)
Variable serialize : Data -> seq nat.
Variable deserialize : seq nat -> Data.
Hypothesis ds_inverse : left_inverse serialize deserialize.

(* This one is in the init state *)
Definition local_indicator (d : Data) :=
  [Pred h | h = st :-> (d.1, CInit) \+ log :-> d.2].

(* Data is just a log *)
Definition core_state_to_data n h (d : Data)  :=
  if n == cn
  then h = st :-> (d.1, CInit) \+ log :-> d.2
  else h = st :-> (d.1, PInit) \+ log :-> d.2.

Lemma core_state_to_data_inj n h d d' :
  core_state_to_data n h d -> core_state_to_data n h d' -> d = d'.
Proof.
rewrite/core_state_to_data.
case:ifP=>_ E; rewrite E ![_ \+ log :-> _]joinC=>{E}E.
- have V: valid (log :-> d.2 \+ st :-> (d.1, CInit)).
  - by case: validUn=>//k; rewrite !domPt !inE/==>/eqP<-.
  case: (hcancelV V E)=>E2=>{V E}V E.
  case: (hcancelPtV V E)=>E1.
  by rewrite [d]surjective_pairing [d']surjective_pairing E1 E2.
have V: valid (log :-> d.2 \+ st :-> (d.1, PInit)).
- by case: validUn=>//k; rewrite !domPt !inE/==>/eqP<-.
case: (hcancelV V E)=>E2=>{V E}V E.
case: (hcancelPtV V E)=>E1.
by rewrite [d]surjective_pairing [d']surjective_pairing E1 E2.
Qed.

Lemma cn_in_qnodes : cn \in qnodes.
Proof. by rewrite inE eqxx. Qed.

Notation getLc s n := (getLocal n (getStatelet s lc)).
Notation cn_agree := TwoPhaseInductiveInv.cn_log_agreement.

(****************************************************************)
(*************   Necessary properties of TPC   ******************)
(****************************************************************)

Lemma core_state_stable_step z s d s' n :
  cn != z -> network_step (mkWorld pc) z s s' ->
  n \in qnodes ->
  local_indicator d (getLc s cn) ->
  core_state_to_data n (getLc s n) d  ->
  core_state_to_data n (getLc s' n) d.
Proof.
move=>N S Qn L H0; case: (step_coh S)=>C1 C2.
have R: network_rely (plab pc \\-> pc, Unit) cn s s' by exists 1, z, s'.
rewrite -(rely_loc' _ R) in L.
case: C2=>V1 V2 _ D /(_ lc)/=; rewrite prEq=>/=[[C2] Inv].
case/orP: Qn=>[|P]; first by move/eqP=>Z; subst n; rewrite /core_state_to_data eqxx.
move: (@cn_agree lc cn pts [::] Hnin (getStatelet s' lc) d.1 d.2 n C2 L Inv P)=>H.
rewrite /core_state_to_data; case:ifP=>//; by move=>/eqP Z; subst n.
Qed.

(***************  Intermediate definitions **********************)

(* Composite world *)
Definition W := QueryHooked.W lq pc Data qnodes serialize core_state_to_data.

Notation loc_qry s := (getLocal cn (getStatelet s lq)).
Notation loc_tpc' s n := (getLocal n (getStatelet s lc)).
Notation loc_tpc s := (loc_tpc' s cn).
Notation qry_init := (query_init_state lq Data qnodes serialize cn).

Lemma loc_imp_core s d n :
  Coh W s -> n \in qnodes -> local_indicator d (loc_tpc s) ->
  core_state_to_data n (loc_tpc' s n) d.
Proof.
move=>C Nq E.
case/orP: Nq=>[|P]; first by move/eqP=>z; subst n; rewrite /core_state_to_data eqxx.
case: (C)=>_ _ _ _/(_ lc); rewrite prEqC//=; case=> C2 Inv.
move: (@cn_agree lc cn pts [::] Hnin (getStatelet s lc) d.1 d.2 n C2 E Inv P)=>->.
rewrite /core_state_to_data; case:ifP=>//.
move=>/eqP Z; subst n; move/negbTE: Hnin=>Z.
suff X: cn \in pts by rewrite X in Z.
done.
Qed.

Lemma find_empty l i : l \notin dom i -> getStatelet i l = empty_dstatelet.
Proof. by rewrite /getStatelet; case: dom_find=>//->. Qed.

Definition cn_request_log :=
  request_data_program _ pc _ _ _ _ ds_inverse _ core_state_to_data_inj Lab_neq _ cn_in_qnodes
                       local_indicator core_state_stable_step (0, [::]).

(* Coordinator loop *)
Definition coordinator ds :=
  with_inv (TwoPhaseInductiveProof.ii _ _ _)
           (coordinator_loop_zero lc cn pts [::] Hnin Puniq PtsNonEmpty ds).

(****************************************************************)
(*************   Overall program combining the two  *************)
(****************************************************************)

(* The following program first initiates a series  of TPC rounds as a *)
(* coordinator, and then, on behalf of the coordinator queries a *)
(* particular pariticipant via the side protocol for querying. The *)
(* goal is to show that the resul obtained from querying is coherent *)
(* with respect to coordinator's state. *)

Program Definition coordinate_and_query (ds : seq data) to :
  {rr : seq (nid * nat) * seq (nid * nat)}, DHT [cn, W]
  (fun i =>
      let: (reqs, resp) := rr in
     [/\ loc_tpc i = st :-> (0, CInit) \+ log :-> ([::] : seq (bool * data)),
        to \in qnodes,
        loc_qry i = qst :-> (reqs, resp) &
        qry_init to i],
   fun (res : Data) m =>
     let: (reqs, resp) := rr in
     exists (chs : seq bool),
       let: d := (size ds, seq.zip chs ds) in
       [/\ loc_tpc m = st :-> (d.1, CInit) \+ log :-> d.2,
        loc_qry m = qst :-> (reqs, resp),
        qry_init to m &
        res = d])
  := Do _ (
      iinject (coordinator ds);;
      cn_request_log to).

Next Obligation.
by exact : (query_hookz lq pc Data qnodes serialize core_state_to_data).
Defined.

Next Obligation.
exact: (injW lq pc Data qnodes serialize core_state_to_data Lab_neq).
Defined.

Next Obligation.
apply:ghC=>i0[rq rs][P1 P2 P3 P4]C0; apply: step.
(*Preparing to split the state. *)
move: (C0)=>CD0; rewrite /W eqW in CD0; move: (coh_hooks CD0)=>{CD0}CD0.
case: (coh_split CD0); try apply: hook_complete0.
move=>i1[j1][C1 D1 Z].
subst i0; apply: inject_rule=>//.
have E : loc_tpc (i1 \+ j1) = loc_tpc i1 by rewrite (locProjL CD0 _ C1)// domPt inE andbC eqxx.
rewrite E{E} in P1.
apply: with_inv_rule'.
apply: call_rule=>//_ i2 [chs]L2 C2 Inv j2 CD2/= R.
(* Massaging the complementary state *)
have E : loc_qry (i1 \+ j1) = loc_qry j1 by rewrite (locProjR CD0 _ D1)// domPt inE andbC eqxx.
rewrite E {E} -(rely_loc' _ R) in P3.
case: (rely_coh R)=>_ D2.
rewrite /W eqW in CD2; move: (coh_hooks CD2)=>{CD2}CD2.
rewrite /mkWorld/= in C2.
have C2': i2 \In Coh (plab pc \\-> pc, Unit).
- split=>//=.
  + by rewrite /valid/= valid_unit validPt.
  + by apply: (cohS C2).
  + by apply: hook_complete0.
  + by move=>z; rewrite -(cohD C2) !domPt.
  move=>l; case B: (lc == l).
  + move/eqP:B=>B; subst l; rewrite /getProtocol findPt; split=>//.
    by move: (coh_coh lc C2); rewrite /getProtocol findPt.
  have X: l \notin dom i2 by rewrite -(cohD C2) domPt inE; move/negbT: B.
  rewrite /getProtocol/= (find_empty _ _ X).
  have Y: l \notin dom (lc \\-> pc) by rewrite domPt inE; move/negbT: B.
  by case: dom_find Y=>//->_.
have D2': j2 \In Coh (lq \\-> pq lq Data qnodes serialize, Unit)
    by apply: (cohUnKR CD2 _); try apply: hook_complete0.

rewrite -(locProjL CD2 _ C2') in L2; last by rewrite domPt inE eqxx.
rewrite -(locProjR CD2 _ D2') in P3; last by rewrite domPt inE eqxx.
clear C2 D2.

(* So what's important is for the precondition ofattachment to be *)
(* independent of the core protocol. *)
rewrite injWQ in R.
rewrite /query_init_state/= in P4.
rewrite (locProjR CD0 _ D1) in P4; last by rewrite domPt inE eqxx.
have Q4: qry_init to j2.
- by apply: (query_init_rely' lq Data qnodes serialize cn to _ _ P4 R).
clear P4.
rewrite /query_init_state/= -(locProjR CD2 _ D2') in Q4;
  last by rewrite domPt inE eqxx.

(* Now ready to use the spec for querying. *)
apply (gh_ex (g:=(rq, rs, (size ds, seq.zip chs ds)))).
apply: call_rule=>//=; last by move=>d m[->->T1 T2->]_; eexists _.
move=>CD2'; split=>//.
case/orP: P2=>[|P]; first by move/eqP=>Z; subst to; rewrite /core_state_to_data eqxx.
rewrite !(locProjL CD2 _ C2') in L2 *;
  last by rewrite domPt inE eqxx.
move: (coh_coh lc C2'); rewrite prEq; case=>C3 _.
rewrite /core_state_to_data; case:ifP=>//[|_]; first by move=>/eqP Z; subst to.
by apply: (@cn_agree lc cn pts [::] Hnin _ _ _ to C3 _ Inv).
Qed.

End QueryPlusTPC.


From Perennial.program_proof Require Import grove_prelude.
From Goose.github_com.mit_pdos.gokv Require Import pb.
From Perennial.program_proof.pb Require Export replica_ghost_defns.
From Perennial.Helpers Require Import ListSolver.

#[global]
Hint Unfold log_po : list.

Section replica_ghost_proof.

Context `{!heapGS Σ}.
Context `{!urpcregG Σ}.
Context `{!pb_ghostG Σ}.
Implicit Type γ:pb_names.

(* accept a new log *)
Lemma append_new_ghost {rid} γ r (newCn:u64) newLog :
  int.Z r.(cn) ≤ int.Z newCn →
  int.Z r.(cn) < int.Z newCn ∨ length r.(opLog) ≤ length newLog →
  "Hown" ∷ own_Replica_ghost rid γ r ∗
  "#HnewProp" ∷ proposal_lb_fancy γ newCn newLog
  ={⊤}=∗
  own_Replica_ghost rid γ (mkReplica newLog newCn) ∗
  accepted_lb γ newCn rid newLog.
Proof.
  intros Hfresh Hnew.
  iNamed 1.
  iNamed "Hown".
  assert (int.Z r.(cn) < int.Z newCn ∨ int.Z r.(cn) = int.Z newCn) as [HnewCn|HoldCn] by word.
  { (* brand new cn *)
    iDestruct (big_sepS_elem_of_acc_impl newCn with "HacceptedUnused") as "[HH HacceptedUnused]".
    { set_solver. }
    iClear "Haccepted".
    iDestruct "HH" as "[%Hbad|Haccepted]".
    { exfalso. word. }
    iMod (accepted_update newLog with "Haccepted") as "Haccepted".
    { list_solver. }
    iDestruct (accepted_witness with "Haccepted") as "#$".
    iFrame "Haccepted HnewProp".
    iApply "HacceptedUnused".
    { (* prove impl: we have accepted_ptstos past newCn, since newCn > r.(cn) *)
      iModIntro.
      iIntros (???) "[%Hineq|$]".
      iLeft.
      iPureIntro.
      simpl.
      word.
    }
    { (* Prove that we don't need the element we accessed *)
      simpl.
      by iLeft.
    }
  }
  { (* same cn, but bigger log *)
    assert (r.(cn) = newCn) as HsameCn.
    { word. }
    rewrite HsameCn.
    iDestruct (proposal_lb_fancy_comparable with "Hproposal_lb HnewProp") as %[Hcomp|Hcomp].
    { (* new log bigger *)
      iMod (accepted_update newLog with "Haccepted") as "Haccepted".
      { done. }
      iDestruct (accepted_witness with "Haccepted") as "#$".
      by iFrame "∗ HnewProp".
    }
    { (* new log the same as before *)
      destruct Hnew as [Hbad|HnewLog].
      { exfalso; word. }
      assert (newLog = r.(opLog)) as ->.
      { list_solver. }
      iDestruct (accepted_witness with "Haccepted") as "#$".
      by iFrame "∗#".
    }
  }
Qed.

(*
  If we increase a replica's cn, want to know that we can keep its commitIdx
  unchanged. This is true because the proposal for cn' will need to have all of
  the committed entries from all previous cn's.
 *)
Lemma maintain_committer_ghost γ r c newCn newLog :
  int.Z r.(cn) ≤ int.Z newCn →
  int.Z r.(cn) < int.Z newCn ∨ length r.(opLog) ≤ length newLog →
  "#HoldProp" ∷ proposal_lb_fancy γ r.(cn) r.(opLog) ∗
  "#HnewProp" ∷ proposal_lb_fancy γ newCn newLog ∗
  "#Hownc" ∷ own_Committer_ghost γ r c
  ={⊤}=∗
  own_Committer_ghost γ (mkReplica newLog newCn) c.
Proof.
  intros HnotStale Hnew.
  iNamed 1.
  iNamed "Hownc".
  assert (int.Z r.(cn) = int.Z newCn ∨ int.Z r.(cn) < int.Z newCn) as [Hcase|Hcase] by word.
  { (* case: newCn == oldCn *)
    destruct Hnew as [Hbad|HlongerLog]; first word.
    unfold own_Committer_ghost.
    simpl.
    iSplitR ""; last first.
    { iPureIntro. word. }
    replace (newCn) with (r.(cn)) by word.
    iDestruct (proposal_lb_fancy_comparable with "HoldProp HnewProp") as %Hcomp.
    iApply (commit_lb_by_monotonic with "Hcommit_lb").
    { done. }
    destruct Hcomp as [Hlog|Hlog].
    * list_solver.
    * list_solver.
  }
  { (* case: newCn > oldCn *)
    iDestruct (oldConfMax_commit_lb_by with "HnewProp Hcommit_lb") as %HlogPrefix.
    { done. }
    unfold own_Committer_ghost.
    simpl.
    iModIntro.
    iSplitL "".
    {
      iApply (commit_lb_by_monotonic with "Hcommit_lb").
      { done. }
      (* B[:n] ⪯ A -∗ A[:n] ⪯ B[:n] *)
      list_solver.
    }
    {
      iPureIntro.
      (* A[:n] ⪯ B -∗ n ≤ length B *)
      list_solver.
    }
  }
Qed.

(* Same CN as before, and an old log; just get a witness that we already accepted *)
Lemma append_dup_ghost {rid} γ r (newCn:u64) newLog :
  int.Z r.(cn) = int.Z newCn ∧ length newLog ≤ length r.(opLog) →
  "Hown" ∷ own_Replica_ghost rid γ r ∗
  "#HnewProp" ∷ proposal_lb_fancy γ newCn newLog
  ={⊤}=∗
  own_Replica_ghost rid γ r ∗
  accepted_lb γ newCn rid newLog.
Proof.
  intros [Hre HstaleLog].
  assert (r.(cn) = newCn) as <- by word.
  iNamed 1.
  iNamed "Hown".
  iDestruct (accepted_witness with "Haccepted") as "#Hacc1".
  (* NOTE: idea: introduce a "comparable" predicate, and have some lemmas about that *)
  iDestruct (proposal_lb_fancy_comparable with "Hproposal_lb HnewProp") as %[Hcomp|Hcomp].
  { (* log must be equal *)
    replace (newLog) with (r.(opLog)); last first.
    { (* TODO: list_solver candidate *) admit. } (* len A ≤ len B ∧ B ⪯ A → B = A *)
    iDestruct (accepted_lb_monotonic with "Hacc1") as "$".
    { done. }
    by iFrame "∗#".
  }
  {
    iDestruct (accepted_lb_monotonic with "Hacc1") as "$".
    { done. }
    by iFrame "∗#".
  }
Admitted.

(* Increase commitIdx by getting a commit_lb_by witness from primary *)
Lemma commit_idx_update {rid} γ r log newCommitIdx :
  int.Z newCommitIdx ≤ length log →
  "Hown" ∷ own_Replica_ghost rid γ r ∗
  "#Hacc" ∷ accepted_lb γ r.(cn) rid log ∗
  "#Hcommit_lb" ∷ commit_lb_by γ r.(cn) (take (int.nat newCommitIdx) log)
  -∗
  own_Replica_ghost rid γ r ∗
  own_Committer_ghost γ r (mkCommitterExtra newCommitIdx).
Proof.
  (* argument: log ⪯ r.(log); (take n log) == (take n r.(log)); *)
  intros HcommitIdx.
  iNamed 1.
  iNamed "Hown".
  iDestruct (accepted_lb_le with "Haccepted Hacc") as "%HlogLe".
  replace (take (int.nat newCommitIdx) log)
          with (take (int.nat newCommitIdx) r.(opLog)); last first.
  {
    assert (int.nat newCommitIdx <= length log) by word.
    set (a:=int.nat newCommitIdx) in *.
    admit. (* TODO: list_solver candidate *)
  }
  iFrame "∗#".
  iPureIntro.
  simpl.
  list_solver.
Admitted.

Lemma primary_matchidx_lookup {rid} conf (i:u64) γ r p :
  conf !! int.nat i = Some rid →
  "#Hconf" ∷ config_ptsto γ r.(cn) conf ∗
  "HprimaryG" ∷ own_Primary_ghost γ r p
  -∗
  ⌜∃ (x:u64), p.(matchIdx) !! int.nat i = Some x⌝.
Proof.
  intros HconfLookup.
  iNamed 1.
  iNamed "HprimaryG".
  iDestruct (config_ptsto_agree with "Hconf HconfPtsto") as %->.
  iDestruct (big_sepL2_lookup_1_some with "HmatchIdxAccepted") as "$".
  done.
Qed.

Lemma primary_update_matchidx {rid} (i oldIdx:u64) γ r p newLog (newLogLen:u64) :
  p.(matchIdx) !! int.nat i = Some oldIdx →
  p.(conf) !! int.nat i = Some rid →
  length newLog = int.nat newLogLen →
  "HprimaryG" ∷ own_Primary_ghost γ r p ∗
  "#Hacc_lb" ∷ accepted_lb γ r.(cn) rid newLog ∗
  "#Hprop_lb" ∷ proposal_lb γ r.(cn) newLog
  -∗
  own_Primary_ghost γ r (mkPrimaryExtra
                           p.(conf)
                           (<[int.nat i:=newLogLen]> p.(matchIdx)) ).
Proof.
  intros HmatchIdxLookup HconfLookup Hlen.
  iNamed 1.
  iNamed "HprimaryG".
  iDestruct (proposal_lb_le with "HprimaryOwnsProposal Hprop_lb") as %HlogLe.
  unfold own_Primary_ghost.
  iFrame "∗#".
  iDestruct (big_sepL2_insert_acc with "HmatchIdxAccepted") as "[_ HH]".
  { done. }
  { done. }
  iSpecialize ("HH" $! rid).
  replace (<[int.nat i:=rid]> p.(conf)) with (p.(conf)); last first.
  { by rewrite list_insert_id. }
  iApply "HH".
  replace (take (int.nat newLogLen) r.(opLog)) with (newLog); last first.
  {
    admit. (* TODO: list_solver. candidate *)
  }
  iFrame "#".
Admitted.

Lemma primary_commit m γ r (p:PrimaryExtra) :
  m ∈ p.(matchIdx) →
  (∀ n, n ∈ p.(matchIdx) → int.Z m ≤ int.Z n) →
  int.Z m ≤ length r.(opLog) →
  pb_inv γ -∗
  proposal_lb_fancy γ r.(cn) r.(opLog) -∗
  own_Primary_ghost γ r p
  ={⊤}=∗
  own_Primary_ghost γ r p ∗
  own_Committer_ghost γ r (mkCommitterExtra m).
Proof.
  intros Hm Hmin HmLog.
  iIntros "#HpbInv #Hprop_lb".
  iNamed 1.
  iFrame "∗#".
  unfold own_Committer_ghost.
  simpl.
  iSplitR ""; last done.
  iMod (do_commit with "HpbInv [] []") as "$".
  { (* TODO: Use accepted_by_fancy. *) admit. }
  { unfold accepted_by.
    iExists _; iFrame "HconfPtsto".
    iIntros (rid Hrid).
    assert (exists i, p.(conf) !! i = Some rid) as [i HconfLookup].
    { by apply elem_of_list_lookup_1. }
    iDestruct (big_sepL2_lookup_1_some with "HmatchIdxAccepted") as %[n HmatchIdxLookup].
    { done. }
    iDestruct (big_sepL2_lookup_acc with "HmatchIdxAccepted") as "[Hacc _]".
    { done. }
    { done. }
    assert (int.Z m <= int.Z n).
    {
      apply Hmin.
      by eapply elem_of_list_lookup_2.
    }
    iApply (accepted_lb_monotonic with "Hacc").
    list_solver.
  }
  done.
Admitted.

End replica_ghost_proof.


Require Import Platform.AutoSep Platform.Malloc Platform.Bootstrap Platform.Cito.examples.CountUnique.

Module Type S.
  Variable heapSize : nat.
End S.

Module Make(M : S).
Import M.

Section boot.
  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.

  Definition size := heapSize + 50 + 0.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize * 4).
    goodSize.
  Qed.

  Definition bootS := bootS heapSize 0.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "top"!"top" @ [topS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%nat;;

        Assert [PREonly[_] 0 =?> heapSize];;

        Call "malloc"!"init"(0, heapSize)
        [PREonly[_] mallocHeap 0];;

        Call "top"!"top"()
        [PREonly[_] [| False |] ]
      end
    }}.

  Theorem ok : moduleOk boot.
    vcgen; abstract genesis.
  Qed.

  Require Platform.Cito.examples.ExampleImpl.

  Definition m0 := link ExampleImpl.m boot.
  Definition m1 := link all m0.

  Lemma ok0 : moduleOk m0.
    link ExampleImpl.ok ok.
  Qed.

  Lemma ok1 : moduleOk m1.
    link all_ok ok0.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m1)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m1)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis mem_low : forall n, (n < size * 4)%nat -> st.(Mem) n <> None.
  Hypothesis mem_high : forall w, ($ (size * 4) <= w)%word -> st.(Mem) w = None.

  Theorem safe : sys_safe stn prog (w, st).
    safety ok1.
  Qed.
End boot.

End Make.


Require Import ConcurExec.
Require Import Spec.Equiv.Execution.
Require Import Spec.Equiv.
Require Import ProcMatch.
Require Import Equiv ProcMatch.
Require Import ProofAutomation.
Require Import FunctionalExtensionality.
Require Import Omega.
Require Import List.
Require Import Compile.

Import ListNotations.

Global Set Implicit Arguments.
Global Generalizable All Variables.

Section Compiler.

  Variable OpLo : Type -> Type.
  Variable OpHi : Type -> Type.

  Variable compile_op : forall T, OpHi T -> ((option T -> OpLo T) * (T -> bool) * option T).

  Definition compile :=
    Compile.compile (fun T op =>
      let '(body, cond, iv) := compile_op op in
      Until cond (fun x => Call (body x)) iv).

  Inductive compile_ok : forall T (p1 : proc OpLo T) (p2 : proc OpHi T), Prop :=
  | CompileOp : forall `(op : OpHi T) body cond iv v,
    compile_op op = (body, cond, iv) ->
    compile_ok (Until cond (fun x => Call (body x)) v) (Call op)
  | CompileOp1 : forall `(op : OpHi T) body cond iv v,
    compile_op op = (body, cond, iv) ->
    compile_ok (until1 cond (fun x => Call (body x)) v) (Call op)
  | CompileRet : forall `(x : T),
    compile_ok (Ret x) (Ret x)
  | CompileExtraRet : forall `(x : T) `(p1 : T -> proc OpLo TF) p2,
    compile_ok (p1 x) (p2 x) ->
    compile_ok (Bind (Ret x) p1) (p2 x)
  | CompileBind : forall `(p1a : proc OpLo T1) (p2a : proc OpHi T1)
                         `(p1b : T1 -> proc _ T2) (p2b : T1 -> proc _ T2),
    compile_ok p1a p2a ->
    (forall x, compile_ok (p1b x) (p2b x)) ->
    compile_ok (Bind p1a p1b) (Bind p2a p2b)
  | CompileUntil : forall `(p1 : option T -> proc OpLo T) (p2 : option T -> proc OpHi T) (c : T -> bool) v,
    (forall v', compile_ok (p1 v') (p2 v')) ->
    compile_ok (Until c p1 v) (Until c p2 v)
  | CompileSpawn : forall T (p1: proc OpLo T) (p2: proc OpHi T),
      compile_ok p1 p2 ->
      compile_ok (Spawn p1) (Spawn p2)
  .

  Hint Constructors compile_ok.

  Theorem compile_ok_compile :
    forall `(p : proc _ T),
      no_atomics p ->
      compile_ok (compile p) p.
  Proof.
    induction p; simpl; intros; eauto.
    - destruct (compile_op op) as [x iv] eqn:He1.
      destruct x as [body cond] eqn:He2.
      eauto.
    - invert H0; eauto.
    - invert H0; eauto.
    - invert H.
    - invert H; eauto.
  Qed.

  Theorem compile_no_atomics :
    forall `(p : proc _ T),
      no_atomics p ->
      no_atomics (compile p).
  Proof.
    intros.
    eapply Compile.compile_no_atomics; eauto.
    intros.
    destruct (compile_op op); destruct p0; eauto.
  Qed.

  Definition compile_ts ts :=
    thread_map compile ts.

  Hint Resolve compile_ok_compile.

  Theorem compile_ts_ok :
    forall ts,
      no_atomics_ts ts ->
      proc_match compile_ok (compile_ts ts) ts.
  Proof.
    intros.
    apply proc_match_sym.
    unfold proc_match; intros.
    unfold compile_ts.
    destruct_with_eqn (ts tid).
    rewrite thread_map_get_match.
    destruct_with_eqn (ts tid); try congruence.
    invert Heqm; eauto.
    rewrite thread_map_get_match.
    simpl_match; auto.
  Qed.

  Hint Resolve compile_no_atomics.

  Theorem compile_ts_no_atomics :
    forall ts,
      no_atomics_ts ts ->
      no_atomics_ts (compile_ts ts).
  Proof.
    unfold no_atomics_ts, compile_ts; intros.
    eapply map_thread_Forall; eauto.
  Qed.

  Variable State : Type.
  Variable lo_step : OpSemantics OpLo State.
  Variable hi_step : OpSemantics OpHi State.

  Definition noop_or_success :=
    forall T (opM : OpHi T) opL cond iv tid s r s',
      (opL, cond, iv) = compile_op opM ->
      forall v evs,
        lo_step (opL v) tid s r s' evs ->
          cond r = false /\ s = s' /\ evs = nil \/
          cond r = true /\ hi_step opM tid s r s' evs.

  Variable is_noop_or_success : noop_or_success.

  Hint Constructors exec_tid.

  Lemma compile_ok_exec_tid : forall T (p1 : proc _ T) p2,
    compile_ok p1 p2 ->
    forall tid s s' result spawned evs,
      exec_tid lo_step tid s p1 s' result spawned evs ->
      (exists p1',
        s' = s /\
        result = inr p1' /\
        compile_ok p1' p2 /\
        spawned = NoProc /\
        evs = nil) \/
      (exists spawned' result',
        exec_tid hi_step tid s p2 s' result' spawned' evs /\
        proc_optR compile_ok spawned spawned' /\
        match result with
        | inl v => match result' with
          | inl v' => v = v'
          | inr _ => False
          end
        | inr p' => match result' with
          | inl v' => p' = Ret v'
          | inr p'' => compile_ok p' p''
          end
        end).
  Proof.
    induction 1; intros.
    - left.
      exec_tid_inv.
      eexists; intuition idtac.
      eauto.
    - repeat exec_tid_inv.
      eapply is_noop_or_success in H6; eauto.
      intuition idtac; subst.
      + left.
        descend; intuition eauto.
        simpl_match; eauto.
      + right.
        descend; intuition eauto.
        simpl_match; eauto.
    - right.
      exec_tid_inv.
      descend; intuition eauto.
    - left.
      repeat exec_tid_inv.
      eexists; intuition idtac.
    - exec_tid_inv.
      edestruct IHcompile_ok; eauto; intuition idtac.
      + repeat deex; subst.
        left.
        eexists; intuition eauto.
      + repeat deex; subst.
        right.
        descend; intuition eauto.
        destruct matches; propositional; eauto.
    - right.
      exec_tid_inv.
      descend; intuition eauto.
      constructor; eauto; intros.
      destruct (c x); eauto.
    - right.
      exec_tid_inv.
      descend; intuition eauto.
  Qed.

  Theorem compile_traces_match_ts :
    forall ts1 ts2,
      proc_match compile_ok ts1 ts2 ->
      traces_match_ts lo_step hi_step ts1 ts2.
  Proof.
    unfold traces_match_ts; intros.
    generalize dependent ts2.
    induction H0; eauto; intros.

    eapply proc_match_pick with (tid := tid) in H3 as H2'.
    intuition idtac; try congruence.
    repeat deex.
    rewrite H in H4; invert H4.

    eapply compile_ok_exec_tid in H1; eauto.
    (intuition eauto); propositional.

    - simpl.
      rewrite thread_upd_same_eq with (tid:=tid') in * by auto.
      eapply IHexec.
      erewrite <- thread_upd_same_eq with (ts := ts2) (tid := tid) by eassumption.
      apply proc_match_upd; eauto.
    - assert (ts2 tid' = NoProc) by eauto using proc_match_none.
      destruct result.
      + epose_proof IHexec.
        eapply proc_match_del; eauto.
        apply proc_match_upd_opt; eauto.
        ExecPrefix tid tid'.
        destruct result'; propositional; eauto.

      + destruct result'; propositional.
        * epose_proof IHexec.
            eapply proc_match_upd; eauto.
            apply proc_match_upd_opt; eauto.

          rewrite exec_equiv_ret_None in H8.

          abstract_tr.
          ExecPrefix tid tid'.
          reflexivity.

        * epose_proof IHexec.
            eapply proc_match_upd; eauto.
            apply proc_match_upd_opt; eauto.
          ExecPrefix tid tid'.
  Qed.

End Compiler.

Arguments compile_ts {OpLo OpHi}.