Require Import CoqlibC.
Require Import SmallstepC.
Require Import Simulation.
Require Import ModSem AsmregsC GlobalenvsC MemoryC ASTC.
Require Import Skeleton SimModSemSR SimMem SimSymb.
Require Import Sound Preservation.
Require Import ModSemProps.

Set Implicit Arguments.

Section MATCHSIMFORWARD.

  Context {SM: SimMem.class} {SS: SimSymb.class SM} {SU: Sound.class}.

  Variable msp: ModSemPair.t.
  Variable index: Type.
  Variable order: index -> index -> Prop.
  Hypothesis WFORD: well_founded order.
  Let ms_src: ModSem.t := msp.(ModSemPair.src).
  Let ms_tgt: ModSem.t := msp.(ModSemPair.tgt).
  Variable sound_state: Sound.t -> mem -> ms_src.(state) -> Prop.
  Hypothesis PRSV: local_preservation ms_src sound_state.

  Variable match_states: forall
      (idx: index) (st_src0: ms_src.(ModSem.state)) (st_tgt0: ms_tgt.(ModSem.state)) (sm0: SimMem.t),
      Prop.

  Variable match_states_at: forall
      (st_src0: ms_src.(ModSem.state)) (st_tgt0: ms_tgt.(ModSem.state)) (sm_at sm_arg: SimMem.t),
      Prop.

  Inductive match_states_at_helper
            (idx_at: index) (st_src0: ms_src.(ModSem.state)) (st_tgt0: ms_tgt.(ModSem.state)) (sm_at sm_arg: SimMem.t): Prop :=
  | match_states_at_intro
      (MATCH: match_states idx_at st_src0 st_tgt0 sm_at)
      args_src args_tgt
      (CALLSRC: ms_src.(ModSem.at_external) st_src0 args_src)
      (CALLTGT: ms_tgt.(ModSem.at_external) st_tgt0 args_tgt)
      (SIMARGS: SimMem.sim_args args_src args_tgt sm_arg)
      (MLE: SimMem.le sm_at sm_arg)
      (MWF: SimMem.wf sm_arg)
      (MATCHARG: match_states_at st_src0 st_tgt0 sm_at sm_arg).

  Hypothesis INITBSIM: forall sm_arg args_src args_tgt st_init_tgt
      (SIMSKENV: ModSemPair.sim_skenv msp sm_arg)
      (MWF: SimMem.wf sm_arg)
      (SIMARGS: SimMem.sim_args args_src args_tgt sm_arg)
      (INITTGT: ms_tgt.(ModSem.initial_frame) args_tgt st_init_tgt)
      (SAFESRC: exists _st_init_src, ms_src.(ModSem.initial_frame) args_src _st_init_src),
      exists st_init_src sm_init idx_init,
        (<<INITSRC: ms_src.(ModSem.initial_frame) args_src st_init_src>>) /\
        (<<MLE: SimMem.le sm_arg sm_init>>) /\
        (<<MATCH: match_states idx_init st_init_src st_init_tgt sm_init>>).

  Hypothesis INITPROGRESS: forall sm_arg args_src args_tgt
      (SIMSKENV: ModSemPair.sim_skenv msp sm_arg)
      (MWF: SimMem.wf sm_arg)
      (SIMARGS: SimMem.sim_args args_src args_tgt sm_arg)
      (SAFESRC: exists st_init_src, ms_src.(ModSem.initial_frame) args_src st_init_src),
      exists st_init_tgt, (<<INITTGT: ms_tgt.(ModSem.initial_frame) args_tgt st_init_tgt>>).

  Hypothesis ATMWF: forall idx0 st_src0 st_tgt0 sm0
      (MATCH: match_states idx0 st_src0 st_tgt0 sm0)
      (CALLSRC: ms_src.(ModSem.is_call) st_src0),
      <<MWF: SimMem.wf sm0>>.

  Hypothesis ATFSIM: forall idx0 st_src0 st_tgt0 sm0 args_src
      (SIMSKENV: ModSemPair.sim_skenv msp sm0)
      (MATCH: match_states idx0 st_src0 st_tgt0 sm0)
      (CALLSRC: ms_src.(ModSem.at_external) st_src0 args_src)
      (SOUND: exists su0 m_init, sound_state su0 m_init st_src0),
      exists args_tgt sm_arg,
        (<<CALLTGT: ms_tgt.(ModSem.at_external) st_tgt0 args_tgt>>) /\
        (<<SIMARGS: SimMem.sim_args args_src args_tgt sm_arg>>) /\
        (<<MLE: SimMem.le sm0 sm_arg>>) /\
        (<<MWF: SimMem.wf sm_arg>>) /\
        (<<MATCHAT: match_states_at st_src0 st_tgt0 sm0 sm_arg>>).

  Hypothesis AFTERFSIM: forall idx0 st_src0 st_tgt0 sm0 sm_arg sm_ret retv_src retv_tgt st_src1
      (SIMSKENV: ModSemPair.sim_skenv msp sm0)
      (MATCH: match_states idx0 st_src0 st_tgt0 sm0)
      (MLE: SimMem.le sm0 sm_arg)
      (* (MWF: SimMem.wf sm_arg) *)
      (MLE: SimMem.lepriv sm_arg sm_ret)
      (MWF: SimMem.wf sm_ret)
      (SIMRET: SimMem.sim_retv retv_src retv_tgt sm_ret)
      (AFTERSRC: ms_src.(ModSem.after_external) st_src0 retv_src st_src1)
      (SOUND: exists su0 m_init, sound_state su0 m_init st_src0)

      (* history *)
      (HISTORY: match_states_at_helper idx0 st_src0 st_tgt0 sm0 sm_arg),

      (* just helpers *)
      (* (MWFAFTR: SimMem.wf (SimMem.unlift sm_arg sm_ret)) *)
      (* (MLEAFTR: SimMem.le sm_arg (SimMem.unlift sm_arg sm_ret)) *)
      exists sm_after idx1 st_tgt1,
        (<<AFTERTGT: ms_tgt.(ModSem.after_external) st_tgt0 retv_tgt st_tgt1>>) /\
        (<<MATCH: match_states idx1 st_src1 st_tgt1 sm_after>>) /\
        (<<MLE: SimMem.lepriv sm_ret sm_after>>) /\
        (<<MLE: SimMem.le sm0 sm_after>>).

  Hypothesis FINALFSIM: forall idx0 st_src0 st_tgt0 sm0 retv_src
      (SIMSKENV: ModSemPair.sim_skenv msp sm0)
      (MATCH: match_states idx0 st_src0 st_tgt0 sm0)
      (FINALSRC: ms_src.(ModSem.final_frame) st_src0 retv_src),
      exists sm_ret retv_tgt,
        (<<FINALTGT: ms_tgt.(ModSem.final_frame) st_tgt0 retv_tgt>>) /\
        (<<SIMRET: SimMem.sim_retv retv_src retv_tgt sm_ret>>) /\
        (<<MLE: SimMem.le sm0 sm_ret>>) /\
        (<<MWF: SimMem.wf sm_ret>>).

  Let STEPFSIM := forall idx0 st_src0 st_tgt0 sm0
      (SIMSKENV: ModSemPair.sim_skenv msp sm0)
      (NOTCALL: ~ ModSem.is_call ms_src st_src0)
      (NOTRET: ~ ModSem.is_return ms_src st_src0)
      (MATCH: match_states idx0 st_src0 st_tgt0 sm0)
      (SOUND: exists su0 m_init, sound_state su0 m_init st_src0),
      (<<RECEP: strongly_receptive_at ms_src st_src0>>) /\
      (<<STEPFSIM: forall tr st_src1
             (STEPSRC: Step ms_src st_src0 tr st_src1),
             exists idx1 st_tgt1 sm1,
               (<<PLUS: DPlus ms_tgt st_tgt0 tr st_tgt1>> \/
                           <<STAR: DStar ms_tgt st_tgt0 tr st_tgt1 /\ order idx1 idx0>>)
               /\ (<<MLE: SimMem.le sm0 sm1>>)
               (* Note: We require le for mle_preserves_sim_ge, but we cannot require SimMem.wf, beacuse of DCEproof *)
               /\ (<<MATCH: match_states idx1 st_src1 st_tgt1 sm1>>)>>).

  Let STEPBSIM := forall idx0 st_src0 st_tgt0 sm0
      (SIMSKENV: ModSemPair.sim_skenv msp sm0)
      (NOTCALL: ~ ModSem.is_call ms_src st_src0)
      (NOTRET: ~ ModSem.is_return ms_src st_src0)
      (MATCH: match_states idx0 st_src0 st_tgt0 sm0)
      (SOUND: exists su0 m_init, sound_state su0 m_init st_src0),
      (* (<<PROGRESS: ModSem.is_step ms_src st_src0 -> ModSem.is_step ms_tgt st_tgt0>>) *)
      (<<PROGRESS: safe_modsem ms_src st_src0 -> ModSem.is_step ms_tgt st_tgt0>>) /\
      (<<STEPBSIM: forall tr st_tgt1
             (STEPTGT: Step ms_tgt st_tgt0 tr st_tgt1) ,
             exists idx1 st_src1 sm1,
               (<<PLUS: Plus ms_src st_src0 tr st_src1>> \/
                           <<STAR: Star ms_src st_src0 tr st_src1 /\ order idx1 idx0>>)
               /\ (<<MLE: SimMem.le sm0 sm1>>)
               (* Note: We require le for mle_preserves_sim_ge, but we cannot require SimMem.wf, beacuse of DCEproof *)
               /\ (<<MATCH: match_states idx1 st_src1 st_tgt1 sm1>>)>>).

  Remark safe_modsem_is_smaller
         st_src0
         (NOTCALL: ~ ModSem.is_call ms_src st_src0)
         (NOTRET: ~ ModSem.is_return ms_src st_src0)
         (SAFE: safe_modsem ms_src st_src0):
      ModSem.is_step ms_src st_src0.
  Proof. rr. specialize (SAFE _ (star_refl _ _ _ _)). des; ss. eauto. Qed.

  Hypothesis STEPSIM: STEPFSIM \/ STEPBSIM.

  Hypothesis BAR: bar_True.

  Lemma match_states_lxsimSR
        i0 st_src0 st_tgt0 sm0
        (SIMSKENV: ModSemPair.sim_skenv msp sm0)
        (* (MWF: SimMem.wf sm0) *)
        (* (MCOMPAT: mem_compat st_src0 st_tgt0 sm0) *)
        (MATCH: match_states i0 st_src0 st_tgt0 sm0):
        (* su0 *)
      (* <<LXSIM: lxsim ms_src ms_tgt (sound_state su0) sm_init i0.(to_idx WFORD) st_src0 st_tgt0 sm0>> *)
      <<LXSIM: lxsimSR ms_src ms_tgt (fun st => unit -> exists su0 m_init, sound_state su0 m_init st)
                       (Ord.lift_idx WFORD i0) st_src0 st_tgt0 sm0>>.
  Proof.
    (* move su0 at top. *)
    revert_until BAR. pcofix CIH. i. pfold. ii.
    generalize (classic (ModSem.is_call ms_src st_src0)). intro CALLSRC; des.
    { (* CALL *)
      - (* u in CALLSRC. des. *)
        exploit ATMWF; eauto. i; des. eapply lxsimSR_at_external; eauto. ii. clear CALLSRC.
        exploit ATFSIM; eauto. { ii. eapply SUSTAR; eauto. eapply star_refl. apply tt. } i; des.
        (* determ_tac ModSem.at_external_dtm. clear_tac. *)
        esplits; eauto. i. exploit AFTERFSIM; try apply SAFESRC; try apply SIMRET; eauto.
        { ii. eapply SUSTAR; eauto. eapply star_refl. apply tt. }
        { econs; eauto. }
        i; des.
        assert(MLE4: SimMem.le sm0 sm_after).
        { etrans; cycle 1. { et. } refl. }
        esplits; eauto. right. eapply CIH; [..|eauto].
        { eapply ModSemPair.mfuture_preserves_sim_skenv; try apply SIMSKENV; eauto. apply rtc_once. left. et. }
    }
    generalize (classic (ModSem.is_return ms_src st_src0)). intro RETSRC; des.
    { (* RETURN *)
      u in RETSRC. des. exploit FINALFSIM; eauto. i; des.
      eapply lxsimSR_final; try apply SIMRET; eauto.
    }
    destruct STEPSIM as [STEPFSIM0|STEPBSIM0].
    { eapply lxsimSR_step_forward; eauto. i.
      (* hexploit1 SU0; ss. *)
      exploit STEPFSIM0; eauto. { ii. eapply SUSTAR; eauto. eapply star_refl. apply tt. } i; des.
      esplits; eauto. econs 1; eauto.
      ii. exploit STEPFSIM1; eauto. i; des_safe. esplits; eauto.
      - des.
        + left. eauto.
        + right. esplits; eauto. eapply Ord.lift_idx_spec; eauto.
      - right. eapply CIH; [..|eauto].
        { eapply ModSemPair.mfuture_preserves_sim_skenv; try apply SIMSKENV; eauto. apply rtc_once; eauto. }
    }
    { rr in STEPBSIM0. eapply lxsimSR_step_backward; eauto. i.
      (* hexploit1 SU0; ss. *)
      exploit STEPBSIM0; eauto. { ii. eapply SUSTAR; eauto. eapply star_refl. apply tt. } i; des. rr in PROGRESS. des.
      esplits; eauto; cycle 1. econs 1; eauto. ii. exploit STEPBSIM1; eauto. i; des_safe. esplits; eauto.
      - des.
        + left. eauto.
        + right. esplits; eauto. eapply Ord.lift_idx_spec; eauto.
      - right. eapply CIH; [..|eauto].
        { eapply ModSemPair.mfuture_preserves_sim_skenv; try apply SIMSKENV; eauto. apply rtc_once; eauto. }
    }
  Qed.

  Theorem match_states_sim: <<SIM: msp.(ModSemPair.simSR)>>.
  Proof.
    econs.
    { eauto. }
    { instantiate (2 := unit). ii. eapply local_preservation_noguarantee_weak; eauto. eapply PRSV. }
    ii; ss. folder.
    exploit SimSymb.sim_skenv_func_bisim; eauto. { apply SIMSKENV. } intro FSIM; des.
    inv FSIM. exploit FUNCFSIM; eauto. { apply SimMem.sim_args_sim_fptr; et. } i; des.
    split; ii.
    - exploit INITBSIM; eauto. i; des.
      esplits; eauto.
      eapply match_states_lxsimSR; eauto.
      { eapply ModSemPair.mfuture_preserves_sim_skenv; try apply SIMSKENV; eauto. apply rtc_once; eauto. }
    - exploit INITPROGRESS; eauto.
  Unshelve.
    all: ss.
  Qed.

End MATCHSIMFORWARD.


(** * Extraction of various contracts to CameLIGO *)

From Coq Require Import ZArith.
From Coq Require Import List.
From Coq Require Import String.
From MetaCoq.Template Require Import All.
From ConCert.Embedding Require Import Notations.
From ConCert.Embedding.Extraction Require Import PreludeExt.
From ConCert.Embedding.Extraction Require SimpleBlockchainExt.
From ConCert.Examples.Crowdfunding Require Import CrowdfundingExt.
From ConCert.Examples.Crowdfunding Require CrowdfundingDataExt.
From ConCert.Extraction Require Import Common.
From ConCert.Extraction Require Import CameLIGOPretty.
From ConCert.Extraction Require Import CameLIGOExtract.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import ResultMonad.

Import MCMonadNotation.

Local Open Scope string_scope.
Open Scope Z.

#[local]
Existing Instance PrintConfShortNames.PrintWithShortNames.

Module Crowdfunding.

  Notation storage := ((time_coq × Z × address_coq) × Maps.addr_map_coq × bool).

  Definition crowdfunding_init (ctx : ContractCallContext)
                               (setup : (time_coq × Z × address_coq))
                               : result storage nat :=
      if ctx.(ctx_amount) =? 0 then Ok (setup, (Maps.mnil, false)) else Err 0%nat.

  Definition init (setup : (time_coq × Z × address_coq))
                  : result storage nat :=
    Ok (setup, (Maps.mnil, false)).

  Lemma crowdfunding_init_eq_init ctx setup :
    ctx.(ctx_amount) =? 0 -> (* no money should be sent on deployment *)
    crowdfunding_init ctx setup = init setup.
  Proof.
    intros Hamount.
    unfold crowdfunding_init.
    now rewrite Hamount.
  Qed.

  Open Scope Z.
  Import SimpleBlockchainExt.AcornBlockchain.
  Import CrowdfundingDataExt.
  Import CrowdfundingContract.Receive.

  (* We assume that there is a function converting addresses to [nat] *)
  Parameter addr_to_nat : forall `{ChainBase}, Blockchain.Address -> nat.

  Definition to_simple_ctx_addr `{ChainBase} (addr : Blockchain.Address) : address_coq :=
    if address_is_contract addr then ContractAddr_coq (addr_to_nat addr) else
      UserAddr_coq (addr_to_nat addr).

  Definition crowdfunding_receive_inner
            (c : Chain)
            (ctx : ContractCallContext)
            (params : msg_coq)
            (st : storage)
            : result (list SimpleActionBody_coq × storage) nat :=
    let res := receive params st
            (Time_coq c.(current_slot),
             (to_simple_ctx_addr ctx.(ctx_from),
             (ctx.(ctx_amount),
             ctx.(ctx_contract_balance)))) in
      result_of_option res 0%nat.

  Definition crowdfunding_receive (c : Chain) (ctx : ContractCallContext) st msg :=
    match msg with
    | Some msg => crowdfunding_receive_inner c ctx msg st
    | None => Err 0%nat
    end.

  Definition CF_MODULE :
    CameLIGOMod _ _ _ storage SimpleActionBody_coq nat :=
    {| (* a name for the definition with the extracted code *)
      lmd_module_name := "cameLIGO_crowdfunding" ;

      (* definitions of operations on pairs and ints *)
      lmd_prelude :=
        CameLIGOPrelude
          ++ nl
          ++ nl
          ++ "let test_account : address = (""tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"" : address)"
          ++ nl
          ++ "let init_storage : (timestamp * (tez * address)) =
          (Tezos.get_now (), (42tez,(""tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"": address)))";

      (* initial storage *)
      lmd_init := init ;

      (* init requires some extra operations *)
      lmd_init_prelude := "";

      lmd_receive_prelude := "";

      (* the main functionality *)
      lmd_receive := crowdfunding_receive;

      (* code for the entry point *)
      lmd_entry_point :=
      "type storage = ((time_coq * (tez * address)) * ((address,tez) map * bool))" ++ nl
       ++ CameLIGOPretty.printMain "crowdfunding_receive"
                                    "msg_coq"
                                    "storage"
    |}.

  (** We run the extraction procedure inside the [TemplateMonad].
      It uses the certified erasure from [MetaCoq] and the certified deboxing procedure
      that removes application of boxes to constants and constructors. *)

End Crowdfunding.

Section CrowdfundingExtraction.
  Import Crowdfunding.
  Import SimpleBlockchainExt.AcornBlockchain.
  Import CrowdfundingDataExt.
  Import CrowdfundingContract.Receive.

  Definition TT_remap_crowdfunding : list (kername * String.string) :=

  [ (* types *)
    remap <%% address_coq %%> "address"
  ; remap <%% SimpleActionBody_coq %%> "operation"
  ; remap <%% Maps.addr_map_coq %%> "(address,tez) map"

  (* simple addresses and the execution layer addresses are treated as the same *)
  ; remap <%% @to_simple_ctx_addr %%> "(fun (x : address) -> x)"

  (* operations *)
  ; remap <%% eqb_addr %%> "eq_addr"
  ; remap <%% Maps.add_map %%> "Map.add"
  ; remap <%% lookup_map' %%> "Map.find_opt"
  ].

  (** A translation table of constructors and some constants. The corresponding definitions will be extracted and renamed. *)
  Definition TT_rename :=
    [ ("nil", "[]");
      ("mnil", "Map.empty") ].

  Time MetaCoq Run
       (CameLIGO_prepare_extraction [] TT_remap_crowdfunding (TT_rename ++ TT_rename_ctors_default) [] "cctx_instance" CF_MODULE).

  Time Definition cameLIGO_crowdfunding := Eval vm_compute in cameLIGO_crowdfunding_prepared.

  (** We redirect the extraction result for later processing and compiling with the CameLIGO compiler *)
  Redirect "../extraction/tests/extracted-code/cameligo-extract/CrowdfundingCertifiedExtraction.mligo"
  MetaCoq Run (tmMsg (String.of_string cameLIGO_crowdfunding)).

End CrowdfundingExtraction.


Require Import Classical List Relations Peano_dec.
Require Import Hahn.

Require Import Basic Dom RC11_Events RC11_Model RC11_PSC.

Set Implicit Arguments.
Remove Hints plus_n_O.

Section GlobalSC.

Variable G : execution.

Notation "'acts'" := G.(acts).
Notation "'lab'" := G.(lab).
Notation "'sb'" := G.(sb).
Notation "'rmw'" := G.(rmw).
Notation "'rf'" := G.(rf).
Notation "'mo'" := G.(mo).
Notation "'eco'" := G.(eco).
Notation "'rb'" := G.(rb).
Notation "'hb'" := G.(hb).
Notation "'psc_f'" := G.(psc_f).
Notation "'psc'" := G.(psc).
Notation "'scb'" := G.(scb).
Notation "'sb_neq_loc'" := G.(sb_neq_loc).
Notation "'sb''" := (sb \ rmw).

Notation "'E'" := G.(E).
Notation "'R'" := (R lab).
Notation "'W'" := (W lab).
Notation "'F'" := (F lab).
Notation "'RMW'" := (RMW lab).

Notation "'RW'" := (RW lab).
Notation "'FR'" := (FR lab).
Notation "'FW'" := (FW lab).

Notation "'Na'" := (Only_Na lab).
Notation "'Rlx'" := (Rlx lab).
Notation "'Rel'" := (Rel lab).
Notation "'Acq'" := (Acq lab).
Notation "'Acqrel'" := (Acqrel lab).
Notation "'Sc'" := (Sc lab).

Notation "type ~ mode" := (type ∩₁ mode) (at level 1).

Notation "'same_loc'" := G.(same_loc).
Notation "rel |loc" := (rel ∩ same_loc) (at level 1).

Implicit Type WF : Wf G.
Implicit Type NRMW : NO_RMW_EVENTS G.

Lemma global_sc_helper
  WF NRMW
  (HSC: ⦗RW~Sc⦘ ⨾ (sb' ∪ sb' ⨾ hb ⨾ sb') ⨾ ⦗RW~Sc⦘ ⊆ hb ⨾ ⦗F~Sc⦘ ⨾ hb) :
  ⦗F~Sc⦘ ⨾ hb ⨾ eco^? ⨾
    (⦗RW~Sc⦘ ⨾ (sb' ∪ sb' ⨾ hb ⨾ sb' ∪ eco) ⨾ ⦗RW~Sc⦘)^* ⨾
      eco^? ⨾ hb ⨾ ⦗F~Sc⦘ ⊆ psc_f⁺.
Proof.
assert (transitive eco).
  by apply eco_trans; assumption.
assert (transitive hb).
  by apply hb_trans; assumption.
eapply rt_ind_left with (P:= fun __ => ⦗F~Sc⦘ ⨾
  hb ⨾ eco ^? ⨾ __ ⨾ eco ^? ⨾ hb ⨾ ⦗F~Sc⦘).
- eauto with rel.
- relsf.
  arewrite (hb ⨾ eco ^? ⨾ hb ⊆ hb ∪ hb ⨾ eco ⨾ hb).
    by rewrite crE; relsf.
  apply inclusion_step_t, inclusion_refl2.
- intros k IH.
  arewrite (⦗RW~Sc⦘ ⨾ (sb' ∪ sb' ⨾ hb ⨾ sb' ∪ eco) ⨾ ⦗RW~Sc⦘ ⊆
                           ⦗RW~Sc⦘ ⨾ (sb' ∪ sb' ⨾ hb ⨾ sb') ⨾ ⦗RW~Sc⦘ ∪ eco) by basic_solver 42.
  rewrite HSC.
  arewrite (⦗F~Sc⦘ ⨾ hb ⨾ eco ^? ⨾ (hb ⨾ ⦗F~Sc⦘ ⨾ hb ∪ eco) ⊆
                           ⦗F~Sc⦘ ⨾ hb ⨾ eco ^? ⨾ hb ⨾ ⦗F~Sc⦘ ⨾ hb ⨾ eco^? ∪ ⦗F~Sc⦘ ⨾ hb ⨾ eco^?)
    by basic_solver 42.
  relsf.
  rewrite !seqA, IH.
  apply inclusion_union_l; try done.
  arewrite (psc_f⁺ ⊆ ⦗F~Sc⦘ ⨾ psc_f⁺).
    by apply doma_helper, ct_doma, doma_helper2.
  rewrite <- !seqA with (r3 := psc_f⁺).
  arewrite (⦗F~Sc⦘ ⨾ hb ⨾ eco ^? ⨾ hb ⨾ ⦗F~Sc⦘ ⊆ psc_f).
    unfold RC11_Model.psc_f; basic_solver 10.
  rewrite ct_begin at 2; basic_solver.
Qed.

Lemma RW_scb_RW :
  ⦗RW~Sc⦘ ⨾ scb ⨾ ⦗RW~Sc⦘ ⊆
    ⦗RW ~ Sc⦘ ⨾
    (sb ∪ sb_neq_loc ⨾ hb ⨾ sb_neq_loc ∪ ⦗RW⦘ ⨾ hb |loc ⨾ ⦗RW⦘ ∪ mo ∪ rb)
      ⨾ ⦗RW ~ Sc⦘.
Proof.
  unfold RC11_Model.scb; basic_solver 42.
Qed.

Lemma global_sc
  WF NRMW
  (COH: irreflexive (hb ⨾ eco^?))
  (HSC: ⦗RW~Sc⦘ ⨾ (sb' ∪ sb' ⨾ hb ⨾ sb') ⨾ ⦗RW~Sc⦘ ⊆ hb ⨾ ⦗F~Sc⦘ ⨾ hb)
  (ACYC: acyclic psc_f) : acyclic psc.
Proof.
assert (transitive eco).
  by apply eco_trans; assumption.
assert (transitive hb).
  by apply hb_trans; assumption.
eapply acyc_dom with (d:= RW~Sc) (e:= F~Sc); try edone.
- unfold RC11_Model.psc, RC11_Model.psc_base, RC11_Model.psc_f; unionL.
  arewrite (⦗Sc⦘ ≡ ⦗RW~Sc⦘ ∪ ⦗F~Sc⦘) by solve_type_mismatch 42.
  basic_solver 42.
  basic_solver 42.
- solve_type_mismatch 6.
- unfold RC11_Model.psc, RC11_Model.psc_base, RC11_Model.psc_f; relsf; rewrite !seqA.
  arewrite_false !(⦗RW~Sc⦘ ⨾ ⦗F~Sc⦘).
    solve_type_mismatch 6.
  arewrite_false !( ⦗F~Sc⦘ ⨾ ⦗RW~Sc⦘).
    solve_type_mismatch 6.
  rels.
  arewrite (⦗RW~Sc⦘ ⨾ ⦗Sc⦘ ⊆ ⦗RW~Sc⦘).
  arewrite (⦗Sc⦘ ⨾ ⦗RW~Sc⦘ ⊆ ⦗RW~Sc⦘).
  rewrite RW_scb_RW.
  rewrite hb_loc_in_eco; auto.
  arewrite (sb_neq_loc ⊆ sb').
    by apply sb_neq_loc_in_sb_minus_rmw; auto.
  arewrite (sb ⊆ sb' ∪ rmw) at 1.
    by unfold inclusion, minus_rel, union; ins; tauto.
  rewrite rmw_in_rb at 2; auto.
  rewrite mo_in_eco; auto.
  rewrite rb_in_eco; auto.
  rewrite <- !unionA.
  relsf.
  arewrite (⦗RW~Sc⦘ ⨾ sb' ⨾ ⦗RW~Sc⦘ ⊆ hb ⨾ ⦗F~Sc⦘ ⨾ hb).
    by rewrite <- HSC; rels.
  arewrite (⦗RW~Sc⦘ ⨾ sb' ⨾ hb ⨾ sb' ⨾ ⦗RW~Sc⦘ ⊆ hb ⨾ ⦗F~Sc⦘ ⨾ hb).
    by rewrite <- HSC; rels; basic_solver 10.
  eapply acyclic_mon with (r := hb ⨾ ⦗F~Sc⦘ ⨾ hb ∪ ⦗RW~Sc⦘ ⨾ eco ⨾ ⦗RW~Sc⦘).
  2: repeat apply inclusion_union_l; rels.
  apply acyclic_utt; splits.
  * apply transitiveI; arewrite_id ⦗F~Sc⦘ at 1; relsf.
  * apply transitiveI.
    arewrite_id ⦗RW~Sc⦘ at 2; relsf.
    arewrite_id ⦗RW~Sc⦘ at 2; relsf.
  * arewrite_id ⦗F~Sc⦘ at 1; relsf.
    by apply irr_hb.
  * arewrite_id ⦗RW~Sc⦘; relsf.
    by apply irr_eco.
  * arewrite (⦗F~Sc⦘ ⊆ ⦗F~Sc⦘ ⨾ ⦗F~Sc⦘).
      by basic_solver.
    do 2 (apply acyclic_seqC; try rewrite !seqA).
    eapply acyclic_mon with (r := psc_f); try done.
    unfold RC11_Model.psc_f.
    basic_solver 12.
- by rewrite psc_f_f.
- rewrite psc_rw_rw; try assumption.
  rewrite RW_scb_RW.
  arewrite (
    sb ∪ sb_neq_loc ⨾ hb ⨾ sb_neq_loc ∪ ⦗RW⦘ ⨾ hb|loc ⨾ ⦗RW⦘ ∪ mo ∪ rb
      ⊆ sb' ∪ sb' ⨾ hb ⨾ sb' ∪ eco
  ).
  { arewrite (sb ⊆ sb' ∪ rmw).
      by apply inclusion_union_minus.
    rewrite rmw_in_rb at 2; try assumption.
    rewrite rb_in_eco, mo_in_eco, sb_neq_loc_in_sb_minus_rmw, hb_loc_in_eco; try assumption.
    basic_solver 10.
  }
  sin_rewrite psc_rw_f; try assumption.
  sin_rewrite psc_f_rw; try assumption.
  rewrite psc_f_f; try assumption.
  arewrite_id ⦗RW~Sc⦘ at 1.
  arewrite_id ⦗RW~Sc⦘ at 3.
  rels.
  rewrite <- !seqA with (r3 := psc_f ^*), global_sc_helper; try assumption.
  red; rels.
Qed.

(* Definition change_mode (l: label) (m: mode) : label :=
  match l with
  | Aload l v _ => Aload l v m
  | Astore l v _ => Astore l v m
  | Afence _ => Afence m
  end. *)

(* Definition change_modes (G: execution) (A: event -> Prop) (m: mode): execution :=
  Build_execution
    acts
    (fun a => if (A a) then change_mode (lab a) m else lab a)
    sb rmw rf mo. *)

(* Lemma transf_g
  (NO_SC: ⦗Sc⦘ ≡ ∅₂)
  A (A_SUB: A ⊆₁ R_acq ∪₁ W_rel)
  (A1: ⦗A⦘ ⨾ (sb' ∪ sb'⨾hb⨾sb') ⨾ ⦗A⦘ ⊆ hb ⨾ ⦗F~Sc⦘ ⨾ hb)
  (A2: ⦗A⦘ ⨾ rmw ≡ rmw ⨾ ⦗A⦘)
  (G' : execution) (CHANGE: G' = G)
  : consistent G'.
Proof.
Admitted. *)

End GlobalSC.


(* *********************************************************************)
(*                                                                     *)
(*            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.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Export AuxStateDataType.
Require Import Constant.
Require Import Coqlib.
Require Import Maps.
Require Import Integers.
Require Import XOmega.
Require Import CLemmas.
Require Import INVLemmaIntel.
Require Import Values.
Require Import liblayers.compat.CompatGenSem.

Section REAL_EPT.

  Function Calculate_EPDTE_at_j (i: Z) (j: Z) (ept: EPT) : EPT :=
    match ZMap.get 0 ept with
      | EPML4EValid epdpt =>
        match ZMap.get i epdpt with
          | EPDPTEValid epdt =>
            ZMap.set 0 (EPML4EValid (ZMap.set i (EPDPTEValid (ZMap.set j (EPDTEValid (ZMap.init EPTEUndef)) epdt)) epdpt)) ept
          | _ => ept
        end
      | _ => ept
    end.

  Fixpoint Calculate_EPDTE (i: Z) (j: nat) (ept: EPT) : EPT :=
    match j with
      | O => Calculate_EPDTE_at_j i 0 ept
      | S k => Calculate_EPDTE_at_j i (Z.of_nat (S k)) (Calculate_EPDTE i k ept)
    end.

  Function Calculate_EPDPTE_at_i (i: Z) (ept: EPT) : EPT :=
    match ZMap.get 0 ept with
      | EPML4EValid epdpt =>
        Calculate_EPDTE i 511 (ZMap.set 0 (EPML4EValid (ZMap.set i (EPDPTEValid (ZMap.init EPDTEUndef)) epdpt)) ept)
      | _ => ept
    end.
  Fixpoint Calculate_EPDPTE (i: nat) (ept: EPT) : EPT :=
    match i with
      | O => Calculate_EPDPTE_at_i 0 ept
      | S k => Calculate_EPDPTE_at_i (Z.of_nat (S k)) (Calculate_EPDPTE k ept)
    end.

  Definition real_ept (ept: EPT) := Calculate_EPDPTE 3 (ZMap.set 0 (EPML4EValid (ZMap.init EPDPTEUndef)) ept).

End REAL_EPT.

Section REAL_VMCS.

  Definition write64_aux (enc: Z) (value: Z64) (d: ZMap.t val) : ZMap.t val :=
    let d1 := ZMap.set enc (Vint (Int64.loword (Int64.repr (Z642Z value)))) d in
    ZMap.set (enc + 1) (Vint (Int64.hiword (Int64.repr (Z642Z value)))) d1.

  Definition write64_block_aux (enc: Z) (value: val) (d: ZMap.t val) : ZMap.t val :=
    let d1 := ZMap.set enc value d in
    ZMap.set (enc + 1) Vzero d1.

  Definition real_vmcs (vm: VMCS) (vmi: VMXInfo) (pml4ept_b tss_b gdt_b idt_b msr_bitmap_b io_bitmap_b host_rip_b: block):=
    match vm with
      | VMCSValid revid abrtid m =>

        let pinbased_ctls := ZMap.get (VMX_INFO_PINBASED_CTLS) vmi in
        let procbased_ctls := ZMap.get (VMX_INFO_PROCBASED_CTLS) vmi in
        let procbased_ctls2 := ZMap.get (VMX_INFO_PROCBASED_CTLS2) vmi in
        let exit_ctls := ZMap.get (VMX_INFO_EXIT_CTLS) vmi in
        let entry_ctls := ZMap.get (VMX_INFO_ENTRY_CTLS) vmi in
        let cr0_ones_mask := ZMap.get (VMX_INFO_CR0_ONES_MASK) vmi in
        let cr0_zeros_mask := ZMap.get (VMX_INFO_CR0_ZEROS_MASK) vmi in
        let cr4_ones_mask := ZMap.get (VMX_INFO_CR4_ONES_MASK) vmi in
        let cr4_zeros_mask := ZMap.get (VMX_INFO_CR4_ZEROS_MASK) vmi in

        let m1 := ZMap.set C_VMCS_PIN_BASED_CTLS (Vint (Int.repr pinbased_ctls)) m in
        let m2 := ZMap.set C_VMCS_PRI_PROC_BASED_CTLS (Vint (Int.repr procbased_ctls)) m1 in
        let m3 := ZMap.set C_VMCS_SEC_PROC_BASED_CTLS (Vint (Int.repr procbased_ctls2)) m2 in
        let m4 := ZMap.set C_VMCS_EXIT_CTLS (Vint (Int.repr exit_ctls)) m3 in
        let m5 := ZMap.set C_VMCS_ENTRY_CTLS (Vint (Int.repr entry_ctls)) m4 in

        let m6 := ZMap.set C_VMCS_HOST_RIP (Vptr host_rip_b Int.zero) m5 in

        (*rcr0_spec adt*)
        let m7 := ZMap.set C_VMCS_HOST_CR0 Vzero m6 in
        (*rcr3_spec adt*)
        let m8 := ZMap.set C_VMCS_HOST_CR3 Vzero m7 in
        (*rcr4_spec adt*)
        let m9 := ZMap.set C_VMCS_HOST_CR4 Vzero m8 in

        let m10 := ZMap.set C_VMCS_HOST_ES_SELECTOR (Vint (Int.repr CPU_GDT_KDATA)) m9 in
        let m11 := ZMap.set C_VMCS_HOST_CS_SELECTOR (Vint (Int.repr CPU_GDT_KCODE)) m10 in
        let m12 := ZMap.set C_VMCS_HOST_SS_SELECTOR (Vint (Int.repr CPU_GDT_KDATA)) m11 in
        let m13 := ZMap.set C_VMCS_HOST_DS_SELECTOR (Vint (Int.repr CPU_GDT_KDATA)) m12 in
        let m14 := ZMap.set C_VMCS_HOST_FS_SELECTOR (Vint (Int.repr CPU_GDT_KDATA)) m13 in
        let m15 := ZMap.set C_VMCS_HOST_GS_SELECTOR (Vint (Int.repr CPU_GDT_KDATA)) m14 in
        let m16 := ZMap.set C_VMCS_HOST_TR_SELECTOR (Vint (Int.repr CPU_GDT_TSS)) m15 in

        let m17 := ZMap.set C_VMCS_HOST_FS_BASE Vzero m16 in
        let m18 := ZMap.set C_VMCS_HOST_GS_BASE Vzero m17 in

        let m19 := ZMap.set C_VMCS_HOST_TR_BASE (Vptr tss_b Int.zero) m18 in
        let m20 := ZMap.set C_VMCS_HOST_GDTR_BASE (Vptr gdt_b Int.zero) m19 in
        let m21 := ZMap.set C_VMCS_HOST_IDTR_BASE (Vptr idt_b Int.zero) m20 in

        (* rdmsr_spec MSR_IA32_SYSENTER_CS adt *)
        let m22 := ZMap.set C_VMCS_HOST_IA32_SYSENTER_CS Vzero m21 in
        (*rdmsr_spec MSR_IA32_SYSENTER_ESP adt*)
        let m23 := ZMap.set C_VMCS_HOST_IA32_SYSENTER_ESP Vzero m22 in
        (*rdmsr_spec MSR_IA32_SYSENTER_EIP adt*)
        let m24 := ZMap.set C_VMCS_HOST_IA32_SYSENTER_EIP Vzero m23 in
        (*rdmsr_spec MSR_IA32_PERF_GLOBAL_CTRL adt*)
        let m25 := write64_aux C_VMCS_HOST_IA32_PERF_GLOBAL_CTRL (VZ64 0) m24 in
        (*rdmsr_spec MSR_PAT adt*)
        let m26 := write64_aux C_VMCS_HOST_IA32_PAT (VZ64 0) m25 in
        (*rdmsr_spec MSR_EFER adt*)
        let m27 := write64_aux C_VMCS_HOST_IA32_EFER (VZ64 0) m26 in

        let m28 := ZMap.set C_VMCS_GUEST_CR0 (Vint (Int.repr (Z.lor v0x60000010 CR0_NE))) m27 in
        let m29 := ZMap.set C_VMCS_GUEST_CR3 Vzero m28 in
        let m30 := ZMap.set C_VMCS_GUEST_CR4 (Vint (Int.repr CR4_VMXE)) m29 in
        let m31 := ZMap.set C_VMCS_GUEST_DR7 (Vint (Int.repr v0x00000400)) m30 in

        let m32 := write64_aux C_VMCS_GUEST_IA32_PAT (VZ64 v0x7040600070406) m31 in
        let m33 := ZMap.set C_VMCS_GUEST_IA32_SYSENTER_CS Vzero m32 in
        let m34 := ZMap.set C_VMCS_GUEST_IA32_SYSENTER_ESP Vzero m33 in
        let m35 := ZMap.set C_VMCS_GUEST_IA32_SYSENTER_EIP Vzero m34 in
        let m36 := write64_aux C_VMCS_GUEST_IA32_DEBUGCTL (VZ64 0) m35 in
        (*FIXME: it should be 64 bits*)
        let m37 := write64_block_aux C_VMCS_EPTP (Vptr pml4ept_b (Int.repr EPTP_pml4)) m36 in

        let m38 := ZMap.set C_VMCS_VPID Vone m37 in
(*        let m38' := ZMap.set C_VMCS_EXCEPTION_BITMAP (Vint (Int.repr T_MCHK_SHIFT)) m38 in *)
        let m39 := write64_block_aux C_VMCS_MSR_BITMAP (Vptr msr_bitmap_b Int.zero) m38 in
        let m40 := write64_aux C_VMCS_LINK_POINTER (VZ64 v0xffffffffffffffff) m39 in
        let m41 := ZMap.set C_VMCS_CR0_MASK (Vint (Int.repr (Z.lor cr0_ones_mask cr0_zeros_mask))) m40 in
        let m42 := ZMap.set C_VMCS_CR0_SHADOW (Vint (Int.repr cr0_ones_mask)) m41 in
        let m43 := ZMap.set C_VMCS_CR4_MASK (Vint (Int.repr (Z.lor cr4_ones_mask cr4_zeros_mask))) m42 in
        let m44 := ZMap.set C_VMCS_CR4_SHADOW (Vint (Int.repr cr4_ones_mask)) m43 in
        let m45 := write64_block_aux C_VMCS_IO_BITMAP_A (Vptr io_bitmap_b Int.zero) m44 in
        let m46 := write64_block_aux C_VMCS_IO_BITMAP_B (Vptr io_bitmap_b (Int.repr PgSize)) m45 in

        let m47 := ZMap.set C_VMCS_GUEST_ACTIVITY Vzero m46 in
        let m48 := ZMap.set C_VMCS_GUEST_INTERRUPTIBILITY Vzero m47 in
        let m49 := ZMap.set C_VMCS_GUEST_PENDING_DBG_EXCEPTIONS Vzero m48 in
        let m50 := ZMap.set C_VMCS_ENTRY_INTR_INFO Vzero m49 in

        let revid1 := Vzero in
        VMCSValid revid1 abrtid m50
    end.

  Lemma real_vmcs_inject_neutral:
    forall vm vmi n pml4ept_b tss_b gdt_b idt_b msr_bitmap_b io_bitmap_b
           host_rip_b,
      VMCS_inject_neutral vm n ->
      Mem.flat_inj n pml4ept_b = Some (pml4ept_b, 0) ->
      Mem.flat_inj n tss_b = Some (tss_b, 0) ->
      Mem.flat_inj n gdt_b = Some (gdt_b, 0) ->
      Mem.flat_inj n idt_b = Some (idt_b, 0) ->
      Mem.flat_inj n msr_bitmap_b = Some (msr_bitmap_b, 0) ->
      Mem.flat_inj n io_bitmap_b = Some (io_bitmap_b, 0) ->
      Mem.flat_inj n host_rip_b = Some (host_rip_b, 0) ->
      VMCS_inject_neutral
        (real_vmcs vm vmi pml4ept_b tss_b gdt_b idt_b msr_bitmap_b io_bitmap_b
                   host_rip_b) n.
  Proof.
    intros. unfold real_vmcs.
    destruct vm.
    inversion H; subst.
    repeat (eapply VMCS_inject_neutral_gss_Vint_same
                   || eapply VMCS_inject_neutral_gss_same); eauto 1;
    split; econstructor; eauto;
    generalize (H11 ofs); intro tmp; destruct tmp; eauto.
  Qed.

End REAL_VMCS.

Section REAL_VMX.

  Definition real_vmx (vm: VMX): VMX :=
    let vm1 := ZMap.set VMX_G_RIP' (Vint (Int.repr v0xfff0)) vm in
    let vm2 := ZMap.set VMX_VPID' Vone vm1 in
    let vm3 := ZMap.set VMX_G_CR2' Vzero vm2 in
    let vm4 := ZMap.set VMX_G_DR0' Vzero vm3 in
    let vm5 := ZMap.set VMX_G_DR1' Vzero vm4 in
    let vm6 := ZMap.set VMX_G_DR2' Vzero vm5 in
    let vm7 := ZMap.set VMX_G_DR3' Vzero vm6 in
    ZMap.set VMX_G_DR6' (Vint (Int.repr v0xffff0ff0)) vm7.

  Lemma real_vmx_inject_neutral:
    forall vm n,
      VMX_inject_neutral vm n ->
      VMX_inject_neutral
        (real_vmx vm) n.
  Proof.
    intros. unfold real_vmx.
    repeat eapply VMX_inject_neutral_gss_Vint.
    assumption.
  Qed.

End REAL_VMX.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                Xavier Leroy, INRIA Paris                            *)
(*                Jacques-Henri Jourdan, INRIA Paris                   *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Architecture-dependent parameters for x86 in 64-bit mode *)

From Flocq Require Import Binary Bits.
Require Import ZArith List.

Definition ptr64 := true.

Definition big_endian := false.

Definition align_int64 := 8%Z.
Definition align_float64 := 8%Z.

Definition splitlong := negb ptr64.

Lemma splitlong_ptr32: splitlong = true -> ptr64 = false.
Proof.
  unfold splitlong. destruct ptr64; simpl; congruence.
Qed.

Definition default_nan_64 := (true, iter_nat 51 _ xO xH).
Definition default_nan_32 := (true, iter_nat 22 _ xO xH).

(* Always choose the first NaN argument, if any *)

Definition choose_nan_64 (l: list (bool * positive)) : bool * positive :=
  match l with nil => default_nan_64 | n :: _ => n end.

Definition choose_nan_32 (l: list (bool * positive)) : bool * positive :=
  match l with nil => default_nan_32 | n :: _ => n end.

Lemma choose_nan_64_idem: forall n,
  choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil).
Proof. auto. Qed.

Lemma choose_nan_32_idem: forall n,
  choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil).
Proof. auto. Qed.

Definition fma_order {A: Type} (x y z: A) := (x, y, z).

Definition fma_invalid_mul_is_nan := false.

Definition float_of_single_preserves_sNaN := false.

(** Which ABI to use. *)
Parameter win64: bool.

Global Opaque ptr64 big_endian splitlong
              default_nan_64 choose_nan_64
              default_nan_32 choose_nan_32
              fma_order fma_invalid_mul_is_nan
              float_of_single_preserves_sNaN.


(* SPDX-License-Identifier: GPL-2.0 *)
Require Import Coqlib.
Require Import Maps.
Require Import Integers.
Require Import Values.
Require Import GenSem.
Require Import Maps.
Require Import Integers.
Require Import Values.
Require Import RealParams.
Require Import GenSem.
Require Import Clight.
Require Import CDataTypes.
Require Import Ctypes.
Require Import PrimSemantics.
Require Import CompatClightSem.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.

Require Import MmioCoreAux.Spec.
Require Import AbstractMachine.Spec.
Require Import MmioCoreAux.Layer.
Require Import RData.
Require Import MmioRaw.Spec.
Require Import Constants.
Require Import HypsecCommLib.

Local Open Scope Z_scope.

Section MmioCoreSpec.

  Definition handle_smmu_write_spec (hsr: Z) (fault_ipa: Z64) (len: Z) (index: Z) (adt: RData) : option RData :=
    match fault_ipa with
    | VZ64 fault_ipa =>
      rely is_int hsr; rely is_addr fault_ipa; rely is_smmu index;
      if halt adt then Some adt else
      match SMMU_ID @ (lock adt) with
      | LockOwn true =>
        let vcpuid := cur_vcpuid adt in
        let rt := host_dabt_get_rd' hsr in
        rely is_vcpu vcpuid; rely is_int rt;
        let offset := Z.land fault_ipa SMMU_OFFSET_MASK in
        if offset <? SMMU_GLOBAL_BASE then
          when' data == get_shadow_ctxt_spec HOSTVISOR vcpuid rt adt;
          rely is_int64 data;
          when ret ==
            (if (offset >=? 0) && (offset <=? ARM_SMMU_GR1_BASE) then
              if offset =? ARM_SMMU_GR0_sCR0 then
                let smmu_enable := Z.land (Z.shiftr data sCR0_SMCFCFG_SHIFT) 1 in
                if smmu_enable =? 0 then Some 0 else Some 1
              else if offset =? ARM_SMMU_GR0_sCR2 then
                      if (Z.land data 255) =? 0 then Some 1 else Some 0
                  else Some 1
            else if (offset >=? ARM_SMMU_GR1_BASE) && (offset <? ARM_SMMU_GR1_END) then
                    let n := (offset - ARM_SMMU_GR1_BASE) / 4 in
                    rely is_smmu_cfg n;
                    let vmid := (smmu_id index n) @ (smmu_vmid (shared adt)) in
                    rely is_vmid vmid;
                    let type := Z.shiftr data CBAR_TYPE_SHIFT in
                    let t_vmid := Z.land data CBAR_VMID_MASK in
                    if vmid =? 0 then Some 1
                    else
                      if (type =? CBAR_TYPE_S2_TRANS) && (vmid =? t_vmid) then Some 1 else Some 0
                else Some 1);
          if ret =? 0 then Some adt {halt: true}
          else if len =? 8 then Some adt
               else if len =? 4 then Some adt
                    else Some adt {halt: true}
        else
          let off' := offset - SMMU_GLOBAL_BASE in
          let cb_offset := Z.land off' ARM_SMMU_PGSHIFT_MASK in
          if cb_offset =? ARM_SMMU_CB_TTBR0 then
            let cbndx := Z.shiftr (offset - SMMU_GLOBAL_BASE) ARM_SMMU_PGSHIFT in
            rely is_smmu_cfg cbndx;
            let val := SMMU_TTBR index cbndx in
            if len =? 8 then Some adt
            else if len =? 4 then Some adt
                 else Some adt {halt: true}
          else if cb_offset =? ARM_SMMU_CB_CONTEXTIDR then Some adt {halt: true}
               else
                 if len =? 8 then
                   when' data == get_shadow_ctxt_spec HOSTVISOR vcpuid rt adt;
                   rely is_int64 data;
                   Some adt
                 else if len =? 4 then Some adt
                      else Some adt {halt: true}
      | _ => None
      end
    end.

  Definition handle_smmu_read_spec (hsr: Z) (fault_ipa: Z64) (len: Z) (adt: RData) : option RData :=
    match fault_ipa with
    | VZ64 fault_ipa =>
      rely is_int hsr;
      if halt adt then Some adt else
      let vcpuid := cur_vcpuid adt in
      let rt := host_dabt_get_rd' hsr in
      let n := HOSTVISOR @ (data_log adt) in
      let data := (doracle adt) HOSTVISOR n in
      rely is_vcpu vcpuid; rely is_int rt; rely is_int64 data;
      let dlog' := (data_log adt) # HOSTVISOR == (n + 1) in
      if len =? 8 then
        set_shadow_ctxt_spec HOSTVISOR vcpuid rt (VZ64 data) (adt {data_log: dlog'})
      else if len =? 4 then
        set_shadow_ctxt_spec HOSTVISOR vcpuid rt (VZ64 (Z.land data INVALID)) (adt {data_log: dlog'})
      else
        Some adt {halt: true}
    end.

End MmioCoreSpec.

Section MmioCoreSpecLow.

  Context `{real_params: RealParams}.

  Notation LDATA := RData.

  Notation LDATAOps := (cdata (cdata_ops := MmioCoreAux_ops) LDATA).

  Definition handle_smmu_write_spec0 (hsr: Z) (fault_ipa: Z64) (len: Z) (index: Z) (adt: RData) : option RData :=
    match fault_ipa with
    | VZ64 fault_ipa =>
      let offset := Z.land fault_ipa SMMU_OFFSET_MASK in
      if offset <? SMMU_GLOBAL_BASE then
        when ret == handle_smmu_global_access_spec hsr (VZ64 offset) index adt;
        rely is_int ret;
        if ret =? 0 then
          panic_spec adt
        else
          __handle_smmu_write_spec hsr (VZ64 fault_ipa) len (VZ64 0) 0 adt
      else
        when ret == handle_smmu_cb_access_spec (VZ64 offset) adt;
        rely is_int ret;
        if ret =? 0 then
          panic_spec adt
        else
          if ret =? 2 then
            when cbndx == smmu_get_cbndx_spec (VZ64 offset) adt;
            rely is_int cbndx;
            when' val == get_smmu_cfg_hw_ttbr_spec cbndx index adt;
            rely is_int64 val;
            __handle_smmu_write_spec hsr (VZ64 fault_ipa) len (VZ64 val) 1 adt
          else
            __handle_smmu_write_spec hsr (VZ64 fault_ipa) len (VZ64 0) 0 adt
    end.

  Definition handle_smmu_read_spec0 (hsr: Z) (fault_ipa: Z64) (len: Z) (adt: RData) : option RData :=
    match fault_ipa with
    | VZ64 fault_ipa =>
      let offset := Z.land fault_ipa SMMU_OFFSET_MASK in
      if offset <? SMMU_GLOBAL_BASE then
        __handle_smmu_read_spec hsr (VZ64 fault_ipa) len adt
      else
        __handle_smmu_read_spec hsr (VZ64 fault_ipa) len adt
    end.

  Inductive handle_smmu_write_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | handle_smmu_write_spec_low_intro s (WB: _ -> Prop) m'0 labd labd' hsr fault_ipa len index
      (Hinv: high_level_invariant labd)
      (Hspec: handle_smmu_write_spec0 (Int.unsigned hsr) (VZ64 (Int64.unsigned fault_ipa)) (Int.unsigned len) (Int.unsigned index) labd = Some labd'):
      handle_smmu_write_spec_low_step s WB ((Vint hsr)::(Vlong fault_ipa)::(Vint len)::(Vint index)::nil) (m'0, labd) Vundef (m'0, labd').

  Inductive handle_smmu_read_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | handle_smmu_read_spec_low_intro s (WB: _ -> Prop) m'0 labd labd' hsr fault_ipa len
      (Hinv: high_level_invariant labd)
      (Hspec: handle_smmu_read_spec0 (Int.unsigned hsr) (VZ64 (Int64.unsigned fault_ipa)) (Int.unsigned len) labd = Some labd'):
      handle_smmu_read_spec_low_step s WB ((Vint hsr)::(Vlong fault_ipa)::(Vint len)::nil) (m'0, labd) Vundef (m'0, labd').

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModelX}.
    Context `{Hmwd: UseMemWithData mem}.

    Definition handle_smmu_write_spec_low: compatsem LDATAOps :=
      csem handle_smmu_write_spec_low_step (type_of_list_type (Tint32::Tint64::Tint32::Tint32::nil)) Tvoid.

    Definition handle_smmu_read_spec_low: compatsem LDATAOps :=
      csem handle_smmu_read_spec_low_step (type_of_list_type (Tint32::Tint64::Tint32::nil)) Tvoid.

  End WITHMEM.

End MmioCoreSpecLow.


(******************************************************************************)
(** Conversions between single steps and block execution steps                *)
(******************************************************************************)
Require Import Classical Peano_dec.
From hahn Require Import Hahn.
Require Import Omega.
Require Import Events.
Require Import Execution.
Require Import Execution_eco.
Require Import imm_s_hb.
Require Import imm_s.
Require Import OCaml.
Require Import OmmProgram.
Require Import ListHelpers.
Require Import OmmImmCompScheme.
Require Import ListHelpersTemp.
Require Import Utils.
Require Import ClosuresProperties.
Require Import Prog.
Require Import ProgToExecution.
Require Import ProgToExecutionProperties.
Require Import Logic.Decidable.
From PromisingLib Require Import Basic Loc.
Require Import Basics.
Set Implicit Arguments.

Section Steps.

Lemma init_mm_same: forall PO BPI (COMP: is_thread_block_compiled PO BPI),
    mm_similar_states (init PO) (binit BPI).
Proof.
  ins. red. simpl. splits; auto.
  3: { basic_solver. }
  2: { ins. simpl. unfold DepsFile.init. simpl. basic_solver. }
  unfold init_execution. red. simpl. basic_solver.
Qed.

Lemma steps_same_instrs sti sti' (STEPS: exists tid, (step tid)＊ sti sti'):
  instrs sti = instrs sti'.
Proof.
  destruct STEPS as [tid STEPS]. apply crt_num_steps in STEPS.
  destruct STEPS as [n STEPS].
  generalize dependent sti'.
  induction n.
  - intros sti' STEPS. simpl in STEPS. generalize STEPS. basic_solver 10.
  - intros sti' STEPS.
    rewrite step_prev in STEPS. destruct STEPS as [sti'' STEPS'']. desc.
    replace (instrs sti) with (instrs sti'').
    { red in STEPS''0. desf. red in STEPS''0. desf. }
    symmetry. eapply IHn. eauto.
Qed.

Lemma omm_steps_same_instrs sto sto' (STEPS: exists tid, (Ostep tid)＊ sto sto'):
  instrs sto = instrs sto'.
Proof.
  (* TODO: join with previous*)
  destruct STEPS as [tid STEPS]. apply crt_num_steps in STEPS.
  destruct STEPS as [n STEPS].
  generalize dependent sto'.
  induction n.
  - intros sto' STEPS. simpl in STEPS. generalize STEPS. basic_solver 10.
  - intros sto' STEPS.
    rewrite step_prev in STEPS. destruct STEPS as [sto'' STEPS'']. desc.
    replace (instrs sto) with (instrs sto'').
    { red in STEPS''0. desf. red in STEPS''0. desf. }
    symmetry. eapply IHn. eauto.
Qed.

Definition on_block st block :=
  ⟪ PROG_BLOCK: block = sublist (instrs st) (pc st) (length block) ⟫ /\
  ⟪ COMP_BLOCK: (exists oinstr, is_instruction_compiled oinstr block) ⟫.

Definition at_compilation_block st :=
  (exists block, on_block st block) \/ is_terminal st.

Definition oseq_step (tid : thread_id) sti1 sti2 :=
  exists block, on_block sti1 block /\
           (step tid) ^^ (length block) sti1 sti2.

Lemma igt_compiled_addr cond addr PO PI (IN_COMP: In (Instr.ifgoto cond addr) PI)
      (COMP: is_thread_compiled PO PI):
  addr <= length PI.
Proof.
  cdes COMP. cdes COMP0.
  red in COMP1. desc. clear COMP COMP0. subst PI.
  replace (length (flatten BPI)) with (length (flatten BPI0)).
  2: { ins.
       rewrite <- firstn_all with (l := BPI0).
       rewrite <- firstn_all with (l := BPI).
       replace (length BPI) with (length BPI0).
       2: { eapply Forall2_length; eauto. }
       apply SAME_STRUCT_PREF. eapply correction_same_struct; eauto. }
  assert (exists BPI_corr, Forall2 (block_corrected BPI_corr) BPI0 BPI /\ same_struct BPI_corr BPI0) as CORR_ALT.
  { exists BPI0. splits; vauto. apply same_struct_refl. }
  desc.
  replace (length (flatten BPI0)) with (length (flatten BPI_corr)).
  2: { ins.
       rewrite <- firstn_all with (l := BPI0).
       rewrite <- firstn_all with (l := BPI_corr).
       replace (length BPI_corr) with (length BPI0).
       2: { symmetry. red in CORR_ALT0. eapply Forall2_length; eauto. }
       apply SAME_STRUCT_PREF. auto. }
  clear COMP3 CORR_ALT0.
  generalize dependent BPI. generalize dependent BPI0. induction PO.
  { ins. inversion COMP1. subst. inversion CORR_ALT. subst. vauto. }
  ins. inversion COMP1. subst. inversion CORR_ALT. subst.
  simpl in IN_COMP. apply in_app_or in IN_COMP. des.
  2: { specialize (IHPO l' H3 l'0 IN_COMP H5). auto. }
  (* Ltac invert_nil := match goal with *)
  (*                    | H:  *)
  inversion H1; subst.
  { inversion H2. subst. inversion H7. subst. inversion H4. subst.
    subst ld. simpl in IN_COMP. des; vauto. }
  { subst. inversion H2. subst. inversion H7. subst. inversion H9. subst.
    inversion H6. subst. inversion H4. subst.
    subst f st. simpl in IN_COMP. des; vauto. }
  { subst. inversion H2. subst. inversion H7. subst. inversion H9. subst.
    inversion H6. subst. inversion H4. subst.
    subst f ld. simpl in IN_COMP. des; vauto. }
  { subst. inversion H2. subst. inversion H7. subst. inversion H9. subst.
    inversion H6. subst. inversion H4. subst.
    subst f exc. simpl in IN_COMP. des; vauto. }
  { subst. inversion H2. subst. inversion H7. subst. inversion H4. subst.
    subst asn. simpl in IN_COMP. des; vauto. }
  subst. inversion H2. subst. inversion H7. subst.
  subst igt. inversion H4; vauto.
  simpl in IN_COMP. des; [| done].
  inversion IN_COMP. subst.
  subst addr1.
  rewrite <- firstn_skipn with (l := BPI_corr) (n := n) at 2.
  rewrite flatten_app, app_length. omega.
Qed.

Lemma is_terminal_pc_bounded st tid PO PI (REACH: (step tid)＊ (init PI) st)
      (COMP: is_thread_compiled PO PI):
  is_terminal st <-> pc st = length (instrs st).
Proof.
  unfold is_terminal.
  split; [|omega].
  apply crt_num_steps in REACH. desc. generalize dependent st. induction n.
  { ins. red in REACH. desc. subst. simpl in *. omega. }
  ins. red in REACH. desc.
  do 2 (red in REACH0; desc).
  assert (forall instr, Some instr = nth_error (instrs z) (pc z) ->
                   pc st = pc z + 1 -> pc st = length (instrs st)) as NEXT_HELPER.
  { ins. assert (pc z < length (instrs st)).
    { apply nth_error_Some, OPT_VAL. rewrite <- INSTRS. eauto. }
    omega. }
  inversion ISTEP0; try (by eapply NEXT_HELPER; eauto).
  destruct (Const.eq_dec (RegFile.eval_expr (regf z) expr) 0).
  { eapply NEXT_HELPER; eauto. }
  forward eapply (@igt_compiled_addr expr shift PO (instrs z)) as BOUND.
  { subst instr. eapply nth_error_In. eauto. }
  { replace (instrs z) with PI; auto.
    replace PI with (instrs (init PI)) by vauto.
    apply steps_same_instrs. exists tid. apply crt_num_steps. eauto. }
  rewrite INSTRS in BOUND. omega.
Qed.

Definition bst_from_st st BPI b :=
  {|
    binstrs := BPI;
    bpc := b;
    bG := G st;
    beindex := eindex st;
    bregf := regf st;
    bdepf := depf st;
    bectrl := ectrl st |}.

Definition min_prop {A: Type} (P: list A -> Prop)
  := forall l (Pl: P l), (forall l1 l2 (LT: l2 <> []) (SPLIT: l = l1 ++ l2), ~ P l1).

Lemma firstn_length_leq {A: Type} (l: list A) i:
  length (firstn i l) <= length l.
Proof.
  generalize dependent l. induction i.
  { ins. omega. }
  ins. destruct l; vauto.
  simpl. apply le_n_S. auto.
Qed.

Lemma start_block_deterministic
      (A : Type)
      (P : list A -> Prop)
      (block : list A)
      (block' : list A)
      (ll : list (list A))
      (MINPROP : min_prop P)
      (NEblock: block <> [])
      (Pblock: P block)
      (NE_B : block' <> [])
      (BLOCK'_P : P block')
      (BLOCK' : block' = firstn (length block') (flatten (block :: ll))):
  block' = block.
Proof.
  assert (block = firstn (length block) (block ++ flatten ll)) as L0.
  { rewrite <- Nat.add_0_r with (n := length block).
    rewrite firstn_app_2. simpl. symmetry. apply app_nil_r. }
  assert (length block' <= length (flatten (block :: ll))) as LEN_B.
  { apply (@f_equal _ _ (@length _)) in BLOCK'.
    pose proof (firstn_length_leq (flatten (block :: ll)) (length block')). omega. }
  assert (length block <= length (flatten (block :: ll))) as LEN_L0.
  { simpl. rewrite app_length. omega. }
  destruct (lt_eq_lt_dec (length block') (length block)) as [[LT | EQ] | GT].
  2: { forward eapply (@firstn_ge_incl _ (flatten (block :: ll)) (length block') (length block)) as PREF; [omega| ].
       rewrite EQ in PREF at 2. rewrite skipn_firstn_nil in PREF.
       rewrite app_nil_r in PREF. simpl in BLOCK'. congruence. }
  { forward eapply (@firstn_ge_incl _ (flatten (block :: ll)) (length block') (length block)) as PREF; [omega| ].
    exfalso.
    simpl in *. rewrite <- BLOCK', <- L0 in PREF.
    red in MINPROP. specialize (MINPROP block Pblock block' (skipn (length block') block)).
    apply MINPROP; vauto.
    apply (@f_equal _ _ (@length _)) in PREF. rewrite app_length in PREF.
    red. ins. apply NE_B. apply length_zero_iff_nil.
    apply length_zero_iff_nil in H. omega. }
  forward eapply (@firstn_ge_incl _ (flatten (block :: ll)) (length block) (length block')) as PREF; [omega| ].
  exfalso.
  simpl in *. rewrite <- BLOCK', <- L0 in PREF.
  red in MINPROP. specialize (MINPROP block' BLOCK'_P block (skipn (length block) block')).
  apply MINPROP; vauto.
  apply (@f_equal _ _ (@length _)) in PREF. rewrite app_length in PREF.
  red. ins. apply NEblock.
  apply length_zero_iff_nil.  apply length_zero_iff_nil in H. omega.
Qed.

Lemma ll_l_corr {A: Type} ll (l: list A) (FLT: l = flatten ll) block b
      (NE_LL: Forall (fun l => l <> []) ll)
      P (MINPROP: min_prop P)
      (P_LL: Forall P ll)
      (NE_B: block <> [])
      (BLOCK_P: P block):
  block = sublist l (length (flatten (firstn b ll))) (length block)
  <-> Some block = nth_error ll b.
Proof.
  generalize dependent block. generalize dependent ll. generalize dependent l.
  induction b.
  { intros. unfold sublist. rewrite FLT. simpl.
    split.
    { intros BLOCK. destruct ll.
      { simpl in BLOCK. rewrite firstn_nil in BLOCK. vauto. }
      f_equal.
      eapply start_block_deterministic; eauto; [inv NE_LL| inv P_LL]. }
    intros BLOCK. destruct ll; vauto. simpl.
    rewrite <- Nat.add_0_r with (n := length l0). rewrite firstn_app_2.
    simpl. symmetry. apply app_nil_r. }
  ins. destruct ll; vauto.
  { simpl. unfold sublist. simpl. rewrite firstn_nil. vauto. }
  simpl. rewrite app_length. unfold sublist.
  rewrite skipn_app.
  replace (skipn (length l0 + length (flatten (firstn b ll))) l0) with (@nil A).
  2: { clear NE_LL. clear P_LL. induction l0.
       { simpl. destruct (length (flatten (firstn b ll))); vauto. }
       simpl. auto. }
  rewrite app_nil_l.
  replace (length l0 + length (flatten (firstn b ll)) - length l0) with (length (flatten (firstn b ll))) by omega.
  apply IHb; vauto.
  { inversion NE_LL. vauto. }
  inversion P_LL. vauto.
Qed.

Lemma instr_compiled_min_prop:
  min_prop (fun blk : list Instr.t =>
              exists oinstr : Instr.t, is_instruction_compiled oinstr blk).
Proof.
  red. intros block [oinstr COMP] block' block'' NE'' BLOCK_STRUCT.
  red. intros [oinstr' COMP'].
  inversion COMP; subst.
  all: (inversion COMP'; subst; inversion H0; subst; auto).
Qed.

Lemma ll_l_corr_helper BPI PI (FLT: PI = flatten BPI) block b
      (COMP: exists PO, is_thread_block_compiled PO BPI)
      (COMP_BLOCK: exists oinstr, is_instruction_compiled oinstr block)
  :
    block = sublist PI (length (flatten (firstn b BPI))) (length block)
    <-> Some block = nth_error BPI b.
Proof.
  eapply ll_l_corr with (P := fun blk => exists oinstr, is_instruction_compiled oinstr blk); vauto.
  { desc. eapply COMPILED_NONEMPTY; eauto. }
  { apply instr_compiled_min_prop. }
  { clear COMP_BLOCK. eapply Forall_index. ins.
    desc. eapply resulting_block_compiled; eauto.
    eapply COMPILED_NONEMPTY; eauto. }
  desc. inversion COMP_BLOCK; vauto.
Qed.

Lemma st_bst_prog_blocks bst block (COMP: exists PO, is_thread_block_compiled PO (binstrs bst)):
  on_block (bst2st bst) block <-> Some block = nth_error (binstrs bst) (bpc bst).
Proof.
  desc.
  assert (Forall (fun l : list Instr.t => l <> []) (binstrs bst)) as BPI_NE.
  { eapply COMPILED_NONEMPTY; eauto. }
  split.
  { intros ON_BLOCK. red in ON_BLOCK. desc.
    unfold bst2st in PROG_BLOCK. simpl in PROG_BLOCK.
    eapply ll_l_corr_helper in PROG_BLOCK; eauto. }
  intros BLOCK. red.
  forward eapply resulting_block_compiled as COMP'; eauto.
  splits; auto.
  eapply ll_l_corr_helper; vauto.
Qed.

Definition on_block_pc pc PI block :=
  ⟪BLOCK: block = sublist PI pc (length block)⟫ /\
  ⟪COMP_BLOCK: exists oinstr : Instr.t, is_instruction_compiled oinstr block⟫.

(* TODO: remove it since exact instruction is known when block_start is called? *)
Lemma block_start pc PI block instr (BLOCK: on_block_pc pc PI block)
      (AT_PC: Some instr = nth_error PI pc):
  (exists mode, instr = Prog.Instr.fence mode) \/
  (exists loc expr, instr = Prog.Instr.load Orlx loc expr) \/
  (exists cond loc, instr = Prog.Instr.ifgoto cond loc) \/
  (exists reg expr, instr = Prog.Instr.assign reg expr).
Proof.
  red in BLOCK. desc.
  inversion COMP_BLOCK.
  all: subst; simpl in *.
  (* TODO: refactor *)
  - assert (AT_PC1: Some ld = nth_error PI pc).
    { apply eq_trans with (y := nth_error [ld] 0); auto.
      rewrite <- (NPeano.Nat.add_0_r pc).
      eapply sublist_items; eauto. }
    rewrite <- AT_PC in AT_PC1. inversion AT_PC1.
    right. left. subst ld. eauto.
  - assert (AT_PC1: Some f = nth_error PI pc).
    { apply eq_trans with (y := nth_error [f; st] 0); auto.
      rewrite <- (NPeano.Nat.add_0_r pc).
      eapply sublist_items; eauto. }
    rewrite <- AT_PC in AT_PC1. inversion AT_PC1.
    left. subst f. eauto.
  - assert (AT_PC1: Some f = nth_error PI pc).
    { apply eq_trans with (y := nth_error [f; ld] 0); auto.
      rewrite <- (NPeano.Nat.add_0_r pc).
      eapply sublist_items; eauto. }
    rewrite <- AT_PC in AT_PC1. inversion AT_PC1.
    left. subst f. eauto.
  - assert (AT_PC1: Some f = nth_error PI pc).
    { apply eq_trans with (y := nth_error [f; exc] 0); auto.
      rewrite <- (NPeano.Nat.add_0_r pc).
      eapply sublist_items; eauto. }
    rewrite <- AT_PC in AT_PC1. inversion AT_PC1.
    left. subst f. eauto.
  - assert (AT_PC1: Some asn = nth_error PI pc).
    { apply eq_trans with (y := nth_error [asn] 0); auto.
      rewrite <- (NPeano.Nat.add_0_r pc).
      eapply sublist_items; eauto. }
    rewrite <- AT_PC in AT_PC1. inversion AT_PC1.
    do 3 right. subst asn. eauto.
  - assert (AT_PC1: Some igt = nth_error PI pc).
    { apply eq_trans with (y := nth_error [igt] 0); auto.
      rewrite <- (NPeano.Nat.add_0_r pc).
      eapply sublist_items; eauto. }
    rewrite <- AT_PC in AT_PC1. inversion AT_PC1.
    do 2 right. left. subst igt. eauto.
Qed.

Lemma block_mid pc PI block instr (BLOCK: on_block_pc pc PI block)
      (BLOCK_LEN: length block >= 2)
      (AT_PC1: Some instr = nth_error PI (pc + 1)):
  (exists loc expr, instr = Prog.Instr.store Orlx loc expr) \/
  (exists loc expr, instr = Prog.Instr.load Osc loc expr) \/
  (exists expr loc, instr = Prog.Instr.update (Prog.Instr.exchange expr) false Xpln Osc Osc exchange_reg loc).
Proof.
  red in BLOCK. desc.
  inversion COMP_BLOCK.
  all: (rename H into OINSTR; rename H0 into BLOCK_CONTENTS).
  all: subst block; simpl in *.
  (* trivial cases for single instruction blocks *)
  all: try omega.
  (* now only 2-blocks remain*)
  (* TODO: refactor *)
  { assert (AT_PC1': Some st = nth_error PI (pc + 1)).
    { apply eq_trans with (y := nth_error [f; st] 1); auto.
      eapply sublist_items; eauto. }
    replace instr with st; [| congruence].
    subst st. eauto. }
  { assert (AT_PC1': Some ld = nth_error PI (pc + 1)).
    { apply eq_trans with (y := nth_error [f; ld] 1); auto.
      eapply sublist_items; eauto. }
    replace instr with ld; [| congruence].
    subst ld. eauto. }
  { assert (AT_PC1': Some exc = nth_error PI (pc + 1)).
    { apply eq_trans with (y := nth_error [f; exc] 1); auto.
      eapply sublist_items; eauto. }
    replace instr with exc; [| congruence].
    subst exc. eauto. }
Qed.

Lemma no_acb_between_pc pc1 pc2 n (PC2: pc2 = pc1 + n)
      block (* (BLOCK: on_block st1 block) *)
      PI (BLOCK: on_block_pc pc1 PI block)
      (LT: n < length block) (NZ: n <> 0):
  not ((exists block', on_block_pc pc2 PI block') \/ pc2 >= length PI).
Proof.
  pose proof BLOCK as BLOCK1.
  red in BLOCK. desc.
  inversion COMP_BLOCK.
  all: rename H into OINSTR.
  all: rename H0 into BLOCK_CONTENTS.
  all: subst block; simpl in *.
  (* trivial cases for single instruction blocks *)
  all: try (replace (n) with (0) in *; [vauto | omega]).
  (* now only 2-blocks remain*)
  all: replace n with 1 in *; [| omega].
  (* TODO: refactor *)
  { assert (AT_PC1: Some st = nth_error PI (pc1 + 1)).
    { apply eq_trans with (y := nth_error [f; st] 1); auto.
      eapply sublist_items; eauto. }
    assert (AT_PC: Some f = nth_error PI pc1).
    { apply eq_trans with (y := nth_error [f; st] 0); auto.
      replace pc1 with (pc1 + 0) by omega.
      eapply sublist_items; eauto. }

    red. intros ACB2. (* red in ACB2. *)
    destruct ACB2 as [[block2 BLOCK2]| TERM2].
    2: { subst pc2.
         red in TERM2. (* rewrite NEXT_PC, SAME_INSTRS in TERM2. *)
         pose proof (nth_error_None PI (pc1 + 1)) as CONTRA.
         apply not_iff_compat in CONTRA. destruct CONTRA as [CONTRA _].
         forward eapply CONTRA; [apply OPT_VAL; eauto| ].
         ins. }
    forward eapply (block_start) as PC1_INSTR; eauto.
    { rewrite PC2. eauto. }
    forward eapply (block_mid BLOCK1) as PC1_INSTR'; eauto.
    des.
    all: (rewrite PC1_INSTR in PC1_INSTR'; discriminate). }
  { assert (AT_PC1: Some ld = nth_error PI (pc1 + 1)).
    { apply eq_trans with (y := nth_error [f; ld] 1); auto.
      eapply sublist_items; eauto. }
    assert (AT_PC: Some f = nth_error PI pc1).
    { apply eq_trans with (y := nth_error [f; ld] 0); auto.
      replace pc1 with (pc1 + 0) by omega.
      eapply sublist_items; eauto. }

    red. intros ACB2.
    destruct ACB2 as [[block2 BLOCK2]| TERM2].
    2: { red in TERM2. (* rewrite NEXT_PC, SAME_INSTRS in TERM2. *)
         pose proof (nth_error_None PI (pc1 + 1)) as CONTRA.
         destruct CONTRA. forward eapply H0; try omega.
         intros. rewrite H1 in AT_PC1. discriminate. }
    forward eapply (block_start) as PC1_INSTR; eauto.
    { rewrite PC2. eauto. }
    forward eapply (block_mid BLOCK1) as PC1_INSTR'; eauto.
    des.
    all: (rewrite PC1_INSTR in PC1_INSTR'; discriminate). }
  { assert (AT_PC1: Some exc = nth_error PI (pc1 + 1)).
    { apply eq_trans with (y := nth_error [f; exc] 1); auto.
      eapply sublist_items; eauto. }
    assert (AT_PC: Some f = nth_error PI pc1).
    { apply eq_trans with (y := nth_error [f; exc] 0); auto.
      replace pc1 with (pc1 + 0) by omega.
      eapply sublist_items; eauto. }
    red. intros ACB2.
    destruct ACB2 as [[block2 BLOCK2]| TERM2].
    2: { red in TERM2. rewrite PC2 in TERM2.
         pose proof (nth_error_None PI (pc1 + 1)) as CONTRA.
         destruct CONTRA. forward eapply H0; try omega.
         intros. rewrite H1 in AT_PC1. discriminate. }
    forward eapply (block_start) as PC1_INSTR; eauto.
    { rewrite PC2. eauto. }
    forward eapply (block_mid BLOCK1) as PC1_INSTR'; eauto.
    des.
    all: (rewrite PC1_INSTR in PC1_INSTR'; discriminate). }
Qed.

Lemma no_acb_between st1 st2 tid block n (STEPS: (step tid) ^^ n st1 st2)
      (BLOCK: on_block st1 block) (LT: n < length block) (NZ: n <> 0):
  not (at_compilation_block st2).
Proof.
  assert (SAME_INSTRS: instrs st2 = instrs st1).
  { symmetry. apply steps_same_instrs. eexists. eapply crt_num_steps. eauto. }
  pose proof BLOCK as BLOCK1.
  red in BLOCK. desc.

  cut (not ((exists block', on_block_pc (pc st2) (instrs st1) block') \/ (pc st2 >= length (instrs st1)))).
  { ins. red. ins. apply H. red in H0. des.
    { left. exists block0. red in H0.
      rewrite SAME_INSTRS in H0.
      desc. red. splits; eauto. }
    right. red in H0. congruence. }

  eapply no_acb_between_pc; eauto.
  assert (length block = 2 -> exists md, Some (Instr.fence md) = nth_error (instrs st1) (pc st1)).
  { ins. inversion COMP_BLOCK; vauto.
    all: subst f.
    { exists Oacqrel.
      apply eq_trans with (y := nth_error [Instr.fence Oacqrel; st] 0); auto.
      replace (pc st1) with (pc st1 + 0) by omega.
      eapply sublist_items; vauto. }
    { exists Oacq.
      apply eq_trans with (y := nth_error [Instr.fence Oacq; ld] 0); auto.
      replace (pc st1) with (pc st1 + 0) by omega.
      eapply sublist_items; vauto. }
    exists Oacq.
    apply eq_trans with (y := nth_error [Instr.fence Oacq; exc] 0); auto.
    replace (pc st1) with (pc st1 + 0) by omega.
    eapply sublist_items; vauto. }
  inversion COMP_BLOCK; subst; simpl in *; try omega.
  all: replace n with 1 in * by omega.
  all: apply (same_relation_exp (pow_1 (step tid))) in STEPS.
  all: red in STEPS; desc; red in STEPS; desc.
  all: inversion ISTEP0; vauto.
  all: destruct H as [md FENCE]; auto.
  all: rewrite <- FENCE in ISTEP.
  all: inversion ISTEP.
Qed.

Lemma skipn_0 {A: Type} (l: list A): skipn 0 l = l.
Proof. destruct l; vauto. Qed.

Lemma on_block_iff_bindex BPI
      block pc (SL: block = sublist (flatten BPI) pc (length block))
      (COMP: exists PO, is_thread_block_compiled PO BPI):
  (exists oinstr, is_instruction_compiled oinstr block) <->
  exists b, Some block = nth_error BPI b /\ pc = length (flatten (firstn b BPI)).
Proof.
  split.
  2: { ins. desc. eapply resulting_block_compiled; eauto.
       eapply COMPILED_NONEMPTY; eauto. }
  intros COMP_BLOCK.
  assert (COMP': exists PO, itbc_weak PO BPI).
  { desc. exists PO. red. red in COMP. desc. eauto. }
  clear COMP.
  generalize dependent BPI.
  set (P := fun pc =>   forall BPI : list (list Instr.t),
                block = sublist (flatten BPI) pc (length block) ->
                (exists PO : list Instr.t, itbc_weak PO BPI) ->
                exists b : nat, Some block = nth_error BPI b /\ pc = length (flatten (firstn b BPI))).
  generalize dependent pc. apply (strong_induction P).
  intros pc IH. red. intros BPI BLOCK COMP.
  destruct BPI as [| blk0 BPI'].
  { exfalso. unfold sublist in BLOCK.
    desc.
    destruct pc; simpl in BLOCK; rewrite firstn_nil in BLOCK; inversion COMP_BLOCK; vauto. }
  destruct (ge_dec pc (length blk0)) as [GE | LT].
  { assert (block = sublist (flatten BPI') (pc - length blk0) (length block)).
    { rewrite BLOCK at 1.
      simpl. unfold sublist at 1.
      rewrite skipn_app. unfold sublist.
      rewrite firstn_app.
      rewrite skipn_all2; [| omega]. rewrite firstn_nil. simpl.
      rewrite Nat.sub_0_r. auto. }
    forward eapply (IH (pc - length blk0)) as IHprev.
    { desc. forward eapply COMPILED_NONEMPTY_weak as NE; eauto.
      inversion NE. subst. destruct blk0; vauto. simpl in *. omega. }
    red in IHprev. forward eapply (IHprev BPI' H) as [b' BLOCK'].
    { desc. destruct PO as [| oinstr_ PO'].
      { red in COMP. desc. inversion COMP. subst. inversion COMP0. }
      exists PO'. red. red in COMP. destruct COMP as [BPI0 [BPI0' [COMP CORR]]].
      inversion CORR. subst. inversion COMP. subst. eauto. }
    exists (S b'). desc. split; auto.
    simpl. rewrite app_length. omega. }
  apply not_ge in LT.
  assert (blk0 = firstn (length blk0) (blk0 ++ flatten BPI')) as BLK0.
  { rewrite <- Nat.add_0_r with (n := length blk0). rewrite firstn_app_2.
    rewrite firstn_O. symmetry. apply app_nil_r. }
  destruct (gt_0_eq pc).
  2: { subst. exists 0. simpl in *. split; auto. f_equal.
       unfold sublist in BLOCK. rewrite skipn_0 in BLOCK.
       eapply (start_block_deterministic (P := fun blk => exists oinstr, is_instruction_compiled oinstr blk)); eauto.
       { apply instr_compiled_min_prop. }
       { desc. pose proof (COMPILED_NONEMPTY_weak COMP).
         inv H. }
       { desc.
         eapply resulting_block_compiled_weak; eauto.
         { eapply COMPILED_NONEMPTY_weak; eauto. }
         Unshelve. 2: exact 0. vauto. }
       desc. inversion COMP_BLOCK; vauto. }
  exfalso.
  forward eapply (@no_acb_between_pc 0 pc pc) as NOACB; eauto.
  { Unshelve. 2: exact (blk0 ++ flatten BPI').
    red. splits; vauto.
    desc. eapply resulting_block_compiled_weak; eauto.
    { eapply COMPILED_NONEMPTY_weak; eauto. }
    Unshelve. 2: exact 0. auto. }
  { omega. }
  apply not_or in NOACB. desc.
  apply NOACB. exists block. red. splits; eauto.
Qed.

Lemma acb_iff_bst st BPI
      (COMP: exists PO, is_thread_compiled_with PO (instrs st) BPI)
      (REACH: exists tid, (step tid)＊ (init (instrs st)) st):
  at_compilation_block st <-> exists bst, ⟪ST: st = bst2st bst⟫ /\
                                   ⟪BINSTRS: binstrs bst = BPI⟫ /\
                                   ⟪BPC: bpc bst <= length BPI⟫.
Proof.
  split.
  { intros ACB. desc. red in COMP. desc.
    red in ACB. des.
    2: { exists (bst_from_st st BPI (length BPI)). splits; auto.
         unfold bst2st. simpl. rewrite firstn_all. rewrite <- COMP0.
         forward eapply (@is_terminal_pc_bounded st tid PO (flatten BPI)) as TERM; vauto.
         { congruence. }
         apply TERM in ACB. rewrite <- ACB.
         by destruct st. }
    red in ACB. desc.
    forward eapply (@on_block_iff_bindex BPI block (pc st)) as [BLOCK_INDEX _]; vauto.
    { congruence. }
    forward eapply BLOCK_INDEX as [b [BLOCK PC]]; eauto.
    exists (bst_from_st st BPI b). splits; auto.
    2: { apply Nat.lt_le_incl. apply nth_error_Some, OPT_VAL. eauto. }
    unfold bst2st, bst_from_st. simpl.
    rewrite <- PC, <- COMP0. by destruct st. }
  intros. desc. red. red in COMP. desc.
  subst.
  destruct (ge_dec (bpc bst) (length (binstrs bst))) as [TERM | NONTERM].
  { right.
    forward eapply (@is_terminal_pc_bounded (bst2st bst) tid PO (instrs (bst2st bst))) as TERM_EQ; vauto.
    apply TERM_EQ.
    pose proof is_terminal_pc_bounded.
    simpl.
    rewrite <- firstn_skipn with (n := bpc bst) (l := binstrs bst) at 2.
    rewrite skipn_all2; [| auto].
    rewrite app_nil_r. auto. }
  apply not_ge in NONTERM. left.
  apply nth_error_Some, OPT_VAL in NONTERM. destruct NONTERM as [block BLOCK].
  exists block. apply st_bst_prog_blocks; eauto.
Qed.

Definition non_igt instr :=
  ~ match instr with | Instr.ifgoto _ _ => True | _ => False end.

Lemma regular_pc_change st1 st2 tid (STEP: step tid st1 st2)
      instr (AT_PC: Some instr = nth_error (instrs st1) (pc st1))
      (NOT_IGT: non_igt instr):
  pc st2 = pc st1 + 1.
Proof.
  do 2 (red in STEP; desc). red in NOT_IGT.
  inversion ISTEP0; auto.
  assert (instr = instr0) by congruence. subst. vauto.
Qed.

Lemma steps_pc_change st1 st2 tid block (ON_BLOCK: on_block st1 block)
      (STEPS: (step tid) ^^ (length block) st1 st2):
  pc st2 = pc st1 + length block \/
  (exists (cond : Instr.expr) (addr : nat),
      block = [Instr.ifgoto cond addr] /\ pc st2 = addr).
Proof.
  red in ON_BLOCK. desc.
  destruct block as [| instr block'].
  { inversion COMP_BLOCK. }
  assert ([instr] = sublist (instrs st1) (pc st1) 1).
  { unfold sublist in *. simpl in PROG_BLOCK.
    simpl. destruct (skipn (pc st1) (instrs st1)); vauto. }
  assert (AT_PC: Some instr = nth_error (instrs st1) (pc st1)).
  { apply eq_trans with (y := nth_error [instr] 0); auto.
    rewrite <- (NPeano.Nat.add_0_r (pc st1)).
    eapply sublist_items; eauto. }
  destruct block' as [| instr' block''].
  {
    inversion COMP_BLOCK.
    3: { subst. simpl in *.
         apply (same_relation_exp (seq_id_l (step tid))) in STEPS.
         do 2 (red in STEPS; desc).
         (* actually most cases here are nonsense, but they still fit into lemma statement *)
         inversion ISTEP0; auto.
         subst instr.
         destruct (Const.eq_dec (RegFile.eval_expr (regf st1) expr) 0); auto.
         right. exists e. exists n. split; eauto.
         assert (igt = Instr.ifgoto expr shift) by congruence.
         inversion H0. auto. }
    all: left; subst; simpl in *.
    all: try apply (same_relation_exp (seq_id_l (step tid))) in STEPS.
    all: eapply regular_pc_change; vauto. }
  left.
  assert ([instr;  instr'] = sublist (instrs st1) (pc st1) 2).
  { unfold sublist in *. simpl in PROG_BLOCK.
    simpl. destruct (skipn (pc st1) (instrs st1)); vauto.
    destruct l; vauto. }
  assert (AT_PC': Some instr' = nth_error (instrs st1) (pc st1 + 1)).
  { apply eq_trans with (y := nth_error [instr; instr'] 1); auto.
    eapply sublist_items; eauto. }
  simpl.
  simpl in STEPS. red in STEPS. desc. red in STEPS. desc.
  assert (forall st' (STEP1: step tid st1 st') (STEP2: step tid st' st2)
            (NOT_IGT1: non_igt instr) (NOT_IGT2: non_igt instr'),
             pc st2 = pc st1 + 2) as STEPS2_HELPER.
  { ins.
    assert (pc st' = pc st1 + 1) by (eapply regular_pc_change; eauto).
    replace (pc st2) with (pc st' + 1); [omega| ].
    symmetry. eapply regular_pc_change; eauto.
    replace (instrs st') with (instrs st1); [congruence |].
    do 2 (red in STEP1; desc). auto. }

  inversion COMP_BLOCK; subst; simpl in *; red in STEPS; subst; desc.
  all: forward eapply STEPS2_HELPER; vauto.
Qed.

Lemma oseq_continuos st1 st2 tid PO
      (OSEQ: (oseq_step tid) st1 st2)
      (REACH: (step tid)＊ (init (instrs st1)) st1)
      (GOTO_RESTR: goto_addresses_restricted PO)
      (COMP: is_thread_compiled PO (instrs st1)):
  at_compilation_block st2.
Proof.
  red in OSEQ. desc.
  red in COMP. desc.
  assert (exists bst1, st1 = bst2st bst1 /\ binstrs bst1 = BPI /\ bpc bst1 <= length BPI) as [bst1 [BST1 [BINSTRS1 BPC1]]].
  { apply acb_iff_bst; vauto. }
  assert (Some block = nth_error (binstrs bst1) (bpc bst1)) as BLOCK.
  { apply st_bst_prog_blocks; vauto.
    exists PO. red in COMP. desc. auto. }
  forward eapply steps_pc_change as PC2; eauto.
  assert (instrs st2 = instrs st1) as SAME_INSTRS.
  { symmetry. apply steps_same_instrs. exists tid. apply crt_num_steps. eauto. }
  assert ((step tid)＊ (init (instrs st2)) st2) as REACH'.
  { rewrite SAME_INSTRS. eapply rt_trans; eauto. apply crt_num_steps. eauto. }

  assert (forall blc (STEPS: (step tid) ^^ (length blc) st1 st2)
            (BLC: Some blc = nth_error (binstrs bst1) (bpc bst1))
            (PC_PLUS: pc st2 = pc st1 + length blc),
             at_compilation_block st2) as NEXT_BLOCK.
  { ins. forward eapply (@acb_iff_bst st2) as [_ ACB_IF_BST].
    2: { eauto. }
    { rewrite SAME_INSTRS. eauto. }
    apply ACB_IF_BST.
    exists (bst_from_st st2 (binstrs bst1) (bpc bst1 + 1)).
    splits; auto.
    2: { simpl. apply le_lt_or_eq in BPC1. destruct BPC1; [omega |].
         subst.
         pose proof (proj2 (nth_error_None (binstrs bst1) (bpc bst1))).
         forward eapply H0; [omega| ]. ins. congruence. }
    unfold bst2st. simpl.
    replace (flatten (binstrs bst1)) with (instrs st2).
    2: { rewrite <- (@steps_same_instrs st1 st2); [subst; eauto| ].
         exists tid. apply crt_num_steps. eauto. }
    red in OSEQ. desc.
    clear dependent oinstr. (* to avoid confusion with actual initial oinstr *)
    pose proof ll_index_shift. specialize H with (j := (bpc bst1 + 1)). specialize_full H; eauto.
    { eapply COMPILED_NONEMPTY. Unshelve. 2: exact PO.
      red in COMP. desc. vauto. }
    { cut (bpc bst1 < length (binstrs bst1)); [ins; omega|].
      apply nth_error_Some, OPT_VAL. vauto. }
    cdes H. rewrite H1; auto.
    subst st1. unfold bst2st in PC_PLUS. simpl in PC_PLUS.
    rewrite <- PC_PLUS.
    by destruct st2. }

  destruct PC2 as [PC2 | PC2].
  - eapply NEXT_BLOCK; eauto.
  - desc. subst addr. (* subst block. *) simpl in *.
    red in COMP. desc.
    subst BPI.
    red in COMP. desc.
    assert (exists oinstr, Some oinstr = nth_error PO (bpc bst1)) as [oinstr OINSTR].
    { apply OPT_VAL. apply nth_error_Some.
      replace (length PO) with (length (binstrs bst1)).
      { apply nth_error_Some, OPT_VAL. eauto. }
      symmetry. apply compilation_same_length. red; vauto. }
    assert (exists block0, Some block0 = nth_error BPI0 (bpc bst1)) as [block0 BLOCK0].
    { apply OPT_VAL. apply nth_error_Some.
      replace (length BPI0) with (length (binstrs bst1)).
      { apply nth_error_Some, OPT_VAL. eauto. }
      symmetry. eapply Forall2_length. eauto. }
    assert (is_instruction_compiled oinstr block0) as COMP_BLOCK.
    { eapply Forall2_index; eauto. }
    assert (block_corrected BPI0 block0 block) as CORR_BLOCK.
    { eapply Forall2_index; eauto. }
    subst block.
    inversion CORR_BLOCK. inversion H3. subst.
    inversion H2; vauto. subst addr.
    inversion COMP_BLOCK. subst.
    simpl in OSEQ0. apply (same_relation_exp (seq_id_l (step tid))) in OSEQ0.
    do 2 (red in OSEQ0; desc).
    assert (instr = Instr.ifgoto cond (pc st2)).
    { forward eapply (@near_pc (Instr.ifgoto cond (pc st2)) _ 0) as AT_PC; eauto.
      { vauto. }
      { apply nth_error_Some, OPT_VAL. eauto. }
      rewrite Nat.add_0_r in AT_PC. congruence. }
    subst instr.
    inversion ISTEP0.
    all: try discriminate.
    destruct (Const.eq_dec (RegFile.eval_expr (regf (bst2st bst1)) expr) 0).
    + eapply NEXT_BLOCK; eauto. simpl.
      apply (same_relation_exp (seq_id_l (step tid))).
      red. eexists. red. eauto.
    + subst.
      inversion CORR_BLOCK. subst. inversion H4; vauto.
      forward eapply acb_iff_bst as [_ ACB_IF_BST].
      { rewrite <- INSTRS. exists PO. simpl. red. splits; eauto.
        vauto. }
      { eauto.  }
      apply ACB_IF_BST.
      exists (bst_from_st st2 (binstrs bst1) addr0). splits; auto.
      2: { simpl.
           replace (length (binstrs bst1)) with (length PO).
           2: { apply compilation_same_length. vauto. }
           red in GOTO_RESTR. eapply GOTO_RESTR; eauto. }
      unfold bst2st. simpl.
      replace (flatten (binstrs bst1)) with (instrs st2).
      replace (length (flatten (firstn addr0 (binstrs bst1)))) with (length (flatten (firstn addr0 BPI0))).
      2: { apply SAME_STRUCT_PREF. eapply correction_same_struct; eauto. }
      rewrite H5. by destruct st2.
Qed.

(* had to define it separately since otherwise Coq doesn't understand what P is *)
Definition StepProp n := forall st1 st2 tid PO (STEPS: (step tid) ^^ n st1 st2)
                           (REACH: (step tid)＊ (init (instrs st1)) st1)
                           bst1 (BST1: st1 = bst2st bst1)
                           bst2 (BST2: st2 = bst2st bst2)
                           (BOUND1: bpc bst1 <= length (binstrs bst1))
                           (BOUND2: bpc bst2 <= length (binstrs bst2))
                           (COMP: is_thread_block_compiled PO (binstrs bst1))
                           (GOTO_RESTR: goto_addresses_restricted PO)
                           (SAME_BINSTRS: binstrs bst1 = binstrs bst2),
    (omm_block_step_PO PO tid)＊ bst1 bst2.

Lemma oseq_between_acb: forall n, StepProp n.
Proof.
  apply strong_induction.
  unfold StepProp. intros n IH. ins. desc.
  assert (at_compilation_block st1) as ACB1.
  { eapply acb_iff_bst; eauto.
    unfold is_thread_compiled_with. exists PO.
    split; [congruence| ]. rewrite BST1. simpl. congruence. }
  assert (at_compilation_block st2) as ACB2.
  { forward eapply (@acb_iff_bst st2) as [_ ACB_IF_BST]; eauto.
    { exists PO. red. split; eauto. rewrite SAME_BINSTRS. vauto. }
    { exists tid. replace (instrs st2) with (instrs st1).
      2: { subst. simpl. congruence. }
      eapply transitive_rt; eauto.
      apply crt_num_steps. eauto. }
    apply ACB_IF_BST. exists bst2. splits; vauto. congruence. }
  assert (bst2st bst1 = bst2st bst2 -> (omm_block_step_PO PO tid)＊ bst1 bst2) as WHEN_SAME_BST.
  { intros SAME_BST2ST.
    replace bst2 with bst1; [apply rt_refl| ].
    destruct bst2. destruct bst1.
    f_equal; vauto.
    rewrite <- SAME_BINSTRS in BOUND2.
    simpl in *.
    eapply (@NONEMPTY_PREF _ binstrs); vauto.
    eapply COMPILED_NONEMPTY; eauto. }

  unfold at_compilation_block in ACB1. desf.
  2: { destruct n.
       { apply WHEN_SAME_BST. apply steps0 in STEPS. auto. }
       forward eapply (@steps_sub _ (step tid) (S n) _ _ 1) as [st' STEP];
         [omega | eauto |].
       apply (same_relation_exp (pow_1 (step tid))) in STEP.
       do 2 (red in STEP; desc).
       cut (None = nth_error (instrs (bst2st bst1)) (pc (bst2st bst1))); [congruence| ].
       symmetry. apply nth_error_None. red in ACB1. omega. }
  pose proof (le_lt_dec (length block) n) as LEN. destruct LEN.
  { forward eapply (steps_split (step tid) (length block) (n - length block)) as SPLIT.
    { symmetry. apply le_plus_minus. auto. }
    apply SPLIT in STEPS. destruct STEPS as  [st' [PREV_STEPS NEXT_STEPS]]. clear SPLIT.
    assert (oseq_step tid (bst2st bst1) st') as OSEQ.
    { red. eexists. eauto. }
    forward eapply (oseq_continuos OSEQ) as ACB'; vauto.
    assert (exists PO', is_thread_compiled PO' (instrs st')) as COMP'.
    { replace (instrs st') with (instrs (bst2st bst1)); vauto.
      apply steps_same_instrs. exists tid.
      (* remove duplicated proof *)
      red in OSEQ. desc. rewrite crt_num_steps. eexists. eauto. }
    assert (LEN': n - length block < n).
    { red in ACB1. desc. inversion COMP_BLOCK; subst; simpl in *; omega. }
    assert ((step tid)＊ (init (instrs st')) st') as REACH'.
    {  replace (instrs st') with (instrs (bst2st bst1)).
      2: { apply steps_same_instrs. exists tid. apply crt_num_steps. eauto. }
      eapply transitive_rt; eauto.
      apply crt_num_steps. eauto. }
    forward eapply (@acb_iff_bst st' (binstrs bst1)) as [BST_IF_ACB _]; eauto.
    { exists PO. red. split; auto.
      replace (instrs st') with (instrs (bst2st bst1)); auto.
      apply steps_same_instrs; eauto. exists tid. apply crt_num_steps. eauto. }
    specialize (BST_IF_ACB ACB'). destruct BST_IF_ACB as [bst' [BST' [SAME_BINSTRS' BPC']]].
    forward eapply IH as IH_; eauto.
    { red in SAME_BINSTRS'. rewrite SAME_BINSTRS'. auto. }
    { congruence. }
    { congruence. }
    apply clos_trans_in_rt. apply t_step_rt. exists bst'. split; auto.
    red. splits; vauto.
    exists block. red. splits; auto.
    apply st_bst_prog_blocks; eauto. rewrite <- BST'. auto. }
  destruct (NPeano.Nat.eq_0_gt_0_cases n).
  { subst. apply steps0 in STEPS. apply WHEN_SAME_BST. auto. }
  forward eapply no_acb_between; eauto; [omega | vauto].
Qed.

Definition is_block_terminal bst := bpc bst >= length (binstrs bst).

Lemma steps_imply_ommblocks bfin PO tid
      (BPC_LIM: bpc bfin <= length (binstrs bfin))
      (GOTO_RESTR: goto_addresses_restricted PO)
      (COMP: is_thread_block_compiled PO (binstrs bfin)):
  let fin := (bst2st bfin) in
  (step tid)＊ (init (instrs fin)) fin -> (omm_block_step_PO PO tid)＊ (binit (binstrs bfin)) bfin.
Proof.
  intros fin STEPS. apply crt_num_steps in STEPS as [n STEPS].
  eapply oseq_between_acb; eauto.
  2: { simpl. omega. }
  simpl. apply rt_refl.
Qed.

Lemma ommblocks_imply_steps bfin tid PO:
  let fin := (bst2st bfin) in
  (omm_block_step_PO PO tid)＊ (binit (binstrs bfin)) bfin -> (step tid)＊ (init (instrs fin)) fin.
Proof.
  intros fin STEPS. apply crt_num_steps in STEPS as [n STEPS].
  generalize dependent bfin. induction n.
  { ins. red in STEPS. desc. subst. simpl.
    replace (init (flatten (binstrs bfin))) with (bst2st bfin); [apply rt_refl| ].
    rewrite <- STEPS. vauto. }
  ins. apply crt_num_steps.
  red in STEPS. desc.
  assert (binstrs bfin = binstrs z) as BINSTRS_SAME.
  { red in STEPS0. desc. vauto. }
  rewrite BINSTRS_SAME in STEPS. specialize (IHn z STEPS).
  red in STEPS0. desc. red in BLOCK_STEP. desc.
  apply crt_num_steps in IHn. desc.
  exists (n0 + length block). eapply steps_split; eauto.
  eexists. splits; eauto. rewrite BINSTRS_SAME. auto.
Qed.

End Steps.


Require Import CoqlibC Maps Integers Floats Lattice Kildall.
Require Import AST Linking.
Require Import ValuesC Events Memory Globalenvs Smallstep.
Require Compopts Machregs.
Require Import Op Registers RTLC.
Require Import Liveness ValueDomain ValueAOp ValueAnalysisC.
Require Import ConstpropOp ConstpropOpproof Constprop.
(** newly added **)
Require Export Constpropproof.
Require Import Simulation.
Require Import Skeleton Mod ModSem SimMod SimModSem SimSymb SimMem AsmregsC MatchSimModSem.
Require SimMemExt.
Require UnreachC.

Set Implicit Arguments.

Section SIMMODSEM.

Variable skenv_link: SkEnv.t.
Variable sm_link: SimMem.t.
Variables prog tprog: program.
Let md_src: Mod.t := (RTLC.module prog).
Let md_tgt: Mod.t := (RTLC.module tprog).
Hypothesis (INCLSRC: SkEnv.includes skenv_link (Mod.sk md_src)).
Hypothesis (INCLTGT: SkEnv.includes skenv_link (Mod.sk md_tgt)).
Hypothesis (WF: SkEnv.wf skenv_link).
Hypothesis TRANSL: match_prog prog tprog.
Let ge := (SkEnv.revive (SkEnv.project skenv_link (Mod.sk md_src)) prog).
Let tge := (SkEnv.revive (SkEnv.project skenv_link (Mod.sk md_tgt)) tprog).
Definition msp: ModSemPair.t := ModSemPair.mk (md_src skenv_link) (md_tgt skenv_link) (SimSymbId.mk md_src md_tgt) sm_link.

Inductive match_states
          (idx: nat) (st_src0: RTL.state) (st_tgt0: RTL.state) (sm0: SimMem.t): Prop :=
| match_states_intro
    (MATCHST: Constpropproof.match_states prog idx st_src0 st_tgt0)
    (MCOMPATSRC: (get_mem st_src0) = sm0.(SimMem.src))
    (MCOMPATTGT: (get_mem st_tgt0) = sm0.(SimMem.tgt)).

Theorem make_match_genvs :
  SimSymbId.sim_skenv (SkEnv.project skenv_link (Mod.sk md_src))
                      (SkEnv.project skenv_link (Mod.sk md_tgt)) ->
  Genv.match_genvs (match_globdef (fun cu f tf => tf = transf_fundef (romem_for cu) f) eq prog) ge tge.
Proof. subst_locals. eapply SimSymbId.sim_skenv_revive; eauto. Qed.

Theorem sim_modsem:ModSemPair.sim msp.
Proof.
  eapply match_states_sim with (match_states := match_states) (match_states_at := top4);
    eauto; ii; ss.
  - apply lt_wf.
  - eapply Preservation.local_preservation_strong_spec. eapply sound_state_preservation; auto.
  - (* init bsim *)
    destruct sm_arg; ss. clarify. inv INITTGT. inv SIMARGS; ss. clarify.
    exploit make_match_genvs; eauto. { apply SIMSKENV. } intro SIMGE. des.
    eexists. eexists (SimMemExt.mk _ _). esplits; eauto.
    + econs; eauto; ss.
      * inv TYP. rpapply match_states_call; eauto.
        { econs; eauto. }
        { eapply lessdef_list_typify_list; try apply VALS; eauto. rewrite <- LEN.
          symmetry. eapply lessdef_list_length; eauto. }
        folder. inv SAFESRC. inv TYP.
        exploit (Genv.find_funct_match_genv SIMGE); eauto. i; des. folder.
        inv FPTR; ss. clarify.
  - (* init progress *)
    des. inv SAFESRC. inv SIMARGS; ss. inv FPTR; ss.
    exploit make_match_genvs; eauto. { apply SIMSKENV. } intro SIMGE.
    exploit (Genv.find_funct_match_genv SIMGE); eauto. i; des. ss. des_ifs.
    inv TYP. esplits; eauto. econs; swap 1 2; eauto.
    + econs; eauto with congruence.
      erewrite <- lessdef_list_length; eauto.
    + erewrite <- lessdef_list_length; eauto.
  - (* call wf *)
    inv MATCH; ss. destruct sm0; ss. clarify.
    u in CALLSRC. des. inv CALLSRC. inv MATCHST; ss.
  - (* call fsim *)
    inv MATCH; ss. destruct sm0; ss. clarify.
    inv CALLSRC. inv MATCHST; ss; cycle 1. folder. esplits; eauto.
    + econs; eauto.
      * folder. des. r in TRANSL. r in TRANSL.
        exploit (SimSymbId.sim_skenv_revive TRANSL); eauto.
        { apply SIMSKENV. }
        intro GE. apply (fsim_external_funct_id GE); ss.
        folder. inv FPTR; ss.
      * des. esplits; eauto. eapply SimSymb.simskenv_func_fsim; eauto; ss.
    + econs; ss; eauto.
      * instantiate (1:= SimMemExt.mk _ _). ss.
      * ss.
    + ss.
  - (* after fsim *)
    inv AFTERSRC. inv SIMRET; ss. exists sm_ret. destruct sm_ret; ss. clarify.
    inv MATCH; ss. inv MATCHST; ss. esplits; eauto.
    + econs; eauto.
    + econs; ss; eauto. clarify. econs; eauto. eapply lessdef_typify; ss.
  - (* final fsim *)
    inv MATCH. inv FINALSRC; inv MATCHST; ss.
    clarify. inv STACKS. destruct sm0; ss. clarify.
    eexists (SimMemExt.mk _ _). esplits; ss; eauto. econs; eauto.
  - left; i. esplits; eauto.
    { apply RTLC.modsem_receptive; et. }
    inv MATCH. ii. hexploit (@transf_step_correct prog skenv_link skenv_link); eauto.
    { inv SIMSKENV. ss. }
    { apply make_match_genvs; eauto. apply SIMSKENV. }
    { des. esplits; eauto. }
    i; des_safe. folder. des.
    + esplits; eauto.
      * left. apply plus_one. split. { apply modsem_determinate; et. } eauto.
      * instantiate (1:= (SimMemExt.mk _ _)). ss. econs; ss; eauto.
    + clarify. esplits; eauto.
      * right. esplits; eauto. { apply star_refl. }
      * instantiate (1:= (SimMemExt.mk _ _)). ss.
Unshelve.
  all: ss. apply msp.
Qed.

End SIMMODSEM.

Section SIMMOD.

Variable prog tprog: RTL.program.
Hypothesis TRANSL: match_prog prog tprog.

Definition mp: ModPair.t := SimSymbId.mk_mp (RTLC.module prog) (RTLC.module tprog).

Theorem sim_mod: ModPair.sim mp.
Proof.
  econs; ss.
  - r. eapply Sk.match_program_eq; eauto.
    ii. destruct f1; ss.
    + clarify. right. esplits; eauto.
    + clarify. left. esplits; eauto.
  - ii. inv SIMSKENVLINK. eapply sim_modsem; eauto.
Qed.

End SIMMOD.


From aneris.aneris_lang Require Import lang resources.
From stdpp Require Import gmap.
From aneris.prelude Require Import misc.
From aneris.examples.ccddb.spec Require Import base.
From aneris.examples.ccddb.model Require Import events model_lst
     model_update_prelude.

Section Lsec_udpate.
  Context `{!anerisG Mdl Σ, !DB_params}.

  Lemma update_condition_lsec_not_in e i t (s : gset apply_event) j :
    (i < length t) →
    (∀ e, e ∈ s → vector_clock_le e.(ae_time) t) →
    update_condition i e t →
    e ∉ DBM_lsec j s.
  Proof.
    intros Hjt Hst Hcnd Habs.
    apply (update_condition_time _ _ _ Hcnd).
    apply in_lsec_in_lhst in Habs.
      by pose proof  update_condition_lhst_not_in e i t s Hjt Hst Hcnd.
  Qed.

  (* NB: The assumption
    "t !! (ae_orig e) = Some (length (elements (DBM_lsec (ae_orig e) s))) →"
    is important and can be derived either from
    Local state validity or from dynamic check)
 *)
  Lemma DBM_lsec_complete_update e i j t s :
    DBM_lhst_valid i s →
    (∀ e, e ∈ s → vector_clock_le e.(ae_time) t) →
    ae_seqid e = S (size s) →
    update_condition i e t →
    j < length DB_addresses →
    t !! (ae_orig e) = Some (length (elements (DBM_lsec (ae_orig e) s))) →
    DBM_lsec_complete j (s ∪ {[e]}).
  Proof.
    intros His Hs Hseq Hcnd Hj Hte.
    destruct (decide (j = e.(ae_orig))) as [ Heq | Hneq ]; last first.
    - intros k.
      rewrite !DBM_lsec_union !DBM_lsec_singleton_out; last lia.
      rewrite right_id_L.
      intros; eapply DBM_LSV_comp; first apply DBM_LHV_secs_valid; eauto.
    - intro k.
      rewrite !DBM_lsec_union !DBM_lsec_singleton_in; last done.
      pose proof Hcnd as
          (Hi & Htlen & Hetlen & Hkey & Heorig & Het & Het' & Het'').
      destruct (lookup_lt_is_Some_2 (ae_time e) i) as [ti Hti];
        eauto with lia.
      rewrite (comm_L _ _ {[_]}) elements_union_singleton /=; last first.
      { eapply update_condition_lsec_not_in; eauto; lia. }
      pose proof (DBM_LHV_secs_valid His j Hj) as Hij.
      destruct (decide (k ≤ (length (elements (DBM_lsec j s))))).
      + intros [? ?].
        destruct (DBM_LSV_comp Hij k) as [x [Hx1 Hx2]]; first eauto with lia.
        set_solver.
      + intros [Hk1 Hk2].
         assert (k = S (length (elements (DBM_lsec j s))))
           as -> by by simpl in *; lia.
         exists e. split; first set_solver.
          subst j. by rewrite Het Hte.
  Qed.

  Lemma DBM_lsec_locally_causal_refl_update e i t s :
    DBM_lhst_valid i s →
    (∀ e, e ∈ s → vector_clock_le e.(ae_time) t) →
    ae_seqid e = S (size s) →
    update_condition i e t →
    (ae_orig e = i →
     ∀ j, j < length DB_addresses →
          t !! j = Some (length (elements (DBM_lsec j s)))) →
    DBM_lsec_locally_causal_refl i (s ∪ {[e]}).
  Proof.
    intros His Hs Hseq Hcnd Htj.
    intros j' ei Hj' Hij'
           [He'1 [He'2| ->%elem_of_singleton]%elem_of_union]%elem_of_filter.
    pose proof DBM_LHV_bound_at His as Hb.
    pose proof DBM_LHV_secs_valid His i Hb as Hsv.
    - (* i ≠ ae_orig e *)
      assert (ae_time ei !! j' = Some (DBM_lsec_latest_in_frame j' s ei)) as ->.
      { apply (DBM_LSV_caus_refl Hsv j' ei); eauto with lia.
        rewrite -He'1. by apply in_lsec_orig.  }
      rewrite /DBM_lsec_latest_in_frame. f_equal.
      apply nat_sup_equiv. intros k.
      rewrite !elem_of_list_omap.
      setoid_rewrite elem_of_list_filter.
      setoid_rewrite elem_of_elements.
      assert ( ae_seqid ei < ae_seqid e) as Hseqi.
      { pose proof DBM_LHV_seqids His ei He'2. lia. }
      split.
      + intros (x&[Hx1 Hxin]&Hx2).
        exists x; split_and!; [done| set_solver | done].
      + intros (x&[Hx1 Hxin]&Hx2).
            exists x; split_and!; [done|  | done].
            assert ( ae_seqid x < ae_seqid e) by lia.
            rewrite (DBM_lsec_union j' s {[e]})in Hxin.
            apply elem_of_union in Hxin as [Hx | Hx]; first done.
            rewrite /DBM_lsec in Hx.
            apply elem_of_filter in Hx as [? <-%elem_of_singleton].
            eauto with lia.
    - (* i = ae_orig e *)
      pose proof Hcnd as
          (Hi & Htlen & Hetlen & Hkey & Heorig & Het & Het' & Het'').
      specialize (Het'' He'1).
      specialize (Htj He'1).
      assert (ae_time e !! j' = t !! j') as Hetj'.
      { rewrite Het''. eapply incr_time_proj_neq; lia. }
      rewrite (Htj j' Hj') in Hetj'.
      rewrite Hetj'. f_equal.
      rewrite (lsec_lsup_length i); eauto.
      rewrite /DBM_lsec_latest_in_frame /lsec_sup.
       apply nat_sup_equiv.
      intros k.
      rewrite !elem_of_list_omap.
      setoid_rewrite elem_of_list_filter.
      setoid_rewrite elem_of_elements.
      split.
      + intros (x&Hxin&Hx2).
        exists x; split_and!; [| set_solver | done].
        eapply in_lsec_in_lhst in Hxin.
        pose proof DBM_LHV_seqids His x Hxin. lia.
      + intros (x&[Hx1 Hxin]&Hx2).
        exists x; split_and!; [  | done].
        assert ( ae_seqid x < ae_seqid e) by lia.
        rewrite (DBM_lsec_union j' s {[e]})in Hxin.
        apply elem_of_union in Hxin as [Hx | Hx]; first done.
        rewrite /DBM_lsec in Hx.
        apply elem_of_filter in Hx as [? <-%elem_of_singleton].
        eauto with lia.
  Qed.

  Lemma DBM_lsec_locally_causal_update e i j t s :
    DBM_lhst_valid i s →
    (∀ e, e ∈ s → vector_clock_le e.(ae_time) t) →
    ae_seqid e = S (size s) →
    update_condition i e t →
    j < length DB_addresses →
    (ae_orig e = i →
     ∀ j, j < length DB_addresses →
          t !! j = Some (length (elements (DBM_lsec j s)))) →
    (∀ j, j < length DB_addresses →
          default O (t !! j) <= (length (elements (DBM_lsec j s)))) →
    DBM_lsec_locally_causal j (s ∪ {[e]}).
  Proof.
    intros His Hs Hseq Hcnd Hj Htj Htj2.
     pose proof Hcnd as
        (Hi & Htlen & Hetlen & Hkey & Heorig & Het & Het' & Het'').
    destruct (decide (j = i)) as [->|].
    - assert (DBM_lsec_locally_causal_refl i (s ∪ {[e]})) as Hvlrefl.
      { eapply DBM_lsec_locally_causal_refl_update; eauto. }
      rewrite /DBM_lsec_locally_causal_refl in Hvlrefl.
      rewrite /DBM_lsec_locally_causal.
      intros j' x Hj' Hneq Hxin.
      destruct (lookup_lt_is_Some_2 (ae_time x) j') as [k Hk].
      {  rewrite DBM_lsec_union in Hxin.
         apply elem_of_union in Hxin as
             [[? Hx]%elem_of_filter |
              [? ->%elem_of_singleton ]%elem_of_filter].
         + pose proof DBM_LHV_times His x Hx. lia.
         + lia. }
      rewrite Hk.
      assert (ae_time x !! j' =
              Some (DBM_lsec_latest_in_frame j' (s ∪ {[e]}) x)) as Hx'.
        by eauto. rewrite -Hk Hx'. simpl. done.
    -  pose proof DBM_LHV_bound_at His as Hb.
       intros j' ei Hj' Hij'
              [He'1 [He'2| ->%elem_of_singleton]%elem_of_union]%elem_of_filter.
       + pose proof DBM_LHV_secs_valid His j Hj as Hvs.
         assert (from_option
                   (λ a : nat, a ≤ DBM_lsec_latest_in_frame j' s ei) False
                   (ae_time ei !! j')) as Hle.
         { apply (DBM_LSV_caus Hvs j' ei); eauto with lia.
           subst j. by apply in_lsec_orig. }
         destruct (lookup_lt_is_Some_2 (ae_time ei) j') as [k Hk].
          pose proof DBM_LHV_times His ei He'2. lia.
          rewrite Hk. rewrite Hk in Hle. simpl in *.
          trans (DBM_lsec_latest_in_frame j' s ei); first done.
          rewrite /DBM_lsec_latest_in_frame.
          apply nat_sup_mono.
         intros r Hr.
          rewrite !elem_of_list_omap.
          setoid_rewrite elem_of_list_filter.
          setoid_rewrite elem_of_elements.
          erewrite elem_of_list_omap in Hr.
          destruct Hr as (ej & Hej1 & Hej2).
          setoid_rewrite elem_of_list_filter in Hej1.
          destruct Hej1 as [? ?].
          exists ej. split_and!; [ |  | done]; eauto with lia.
          set_solver.
       +  assert (j' ≠ ae_orig e) as Hj'e by lia.
          specialize (Het' j' Hj' Hj'e).
          destruct (lookup_lt_is_Some_2 (ae_time e) j') as [k Hk];
            first eauto with lia.
          rewrite Hk in Het'. rewrite Hk. simpl in *.
          specialize (Htj2 j' Hj').
          trans (length (elements (DBM_lsec j' s))).
          * trans (default 0 (t !! j')); eauto with lia.
          *  erewrite (lsec_lsup_length i); eauto.
             rewrite /DBM_lsec_latest_in_frame /lsec_sup.
             apply nat_sup_mono.
             intros r Hr.
             rewrite !elem_of_list_omap.
             setoid_rewrite elem_of_list_filter.
             setoid_rewrite elem_of_elements.
             erewrite elem_of_list_omap in Hr.
             destruct Hr as (ej & Hej1 & Hej2).
             exists ej; split_and!; [| set_solver | done].
             rewrite /DBM_lsec in Hej1.
             erewrite elem_of_elements in Hej1.
             apply elem_of_filter in Hej1 as [? Hej1].
             pose proof DBM_LHV_seqids His ej Hej1.
             rewrite Hseq. by apply le_lt_n_Sm.
  Qed.

  Lemma DBM_lhst_lsec_update e i t s :
    DBM_lhst_valid i s →
    (∀ e, e ∈ s → vector_clock_le e.(ae_time) t) →
    e.(ae_seqid) = (S (size s)) →
    update_condition i e t →
    t !! ae_orig e = Some (length (elements (DBM_lsec (ae_orig e) s))) →
    (ae_orig e = i
     → ∀ j, j < strings.length DB_addresses
            → t !! j = Some (length (elements (DBM_lsec j s)))) →
     (∀ j, j < length DB_addresses →
          default O (t !! j) <= (length (elements (DBM_lsec j s)))) →
    DBM_lhst_lsec_valid i (s ∪ {[ e ]}).
  Proof.
    intros.
    split.
    - eapply DBM_LHV_bound_at; eauto.
    - done.
    - eapply DBM_lsec_complete_update; eauto.
    - eapply DBM_lsec_locally_causal_refl_update; eauto.
    - eapply DBM_lsec_locally_causal_update; eauto.
  Qed.

End Lsec_udpate.