Require Import Coq.Bool.Bool.

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

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

Require Import VST.msl.Axioms.

Require Import VST.sepcomp.mem_lemmas.
Require Import VST.sepcomp.semantics.
Require Import VST.sepcomp.effect_semantics.
Require Import VST.sepcomp.structured_injections.
Require Import VST.sepcomp.reach.

Module SM_simulation. Section SharedMemory_simulation_inject.

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

Record SM_simulation_inject :=
{ core_data : Type
; match_state : core_data -> SM_Injection -> C1 -> mem -> C2 -> mem -> Prop
; core_ord : core_data -> core_data -> Prop
; core_ord_wf : well_founded core_ord

; match_sm_wd :
    forall d mu c1 m1 c2 m2,
    match_state d mu c1 m1 c2 m2 -> SM_wd mu

; genvs_dom_eq : genvs_domain_eq ge1 ge2

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

; match_visible :
    forall d mu c1 m1 c2 m2,
    match_state d mu c1 m1 c2 m2 ->
    REACH_closed m1 (vis mu)

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

; match_validblocks :
    forall d mu c1 m1 c2 m2,
    match_state d mu c1 m1 c2 m2 ->
    sm_valid mu m1 m2

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

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

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

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

; effcore_diagram :
    forall st1 m1 st1' m1' U1,
    effstep Sem1 ge1 U1 st1 m1 st1' m1' ->
    forall cd st2 mu m2,
    match_state cd mu st1 m1 st2 m2 ->
    exists st2', exists m2', exists cd', exists mu',
      intern_incr mu mu'
      /\ sm_inject_separated mu mu' m1 m2
      /\ sm_locally_allocated mu mu' m1 m2 m1' m2'
      /\ match_state cd' mu' st1' m1' st2' m2'
      /\ exists U2,
          ((effstep_plus Sem2 ge2 U2 st2 m2 st2' m2' \/
            (effstep_star Sem2 ge2 U2 st2 m2 st2' m2' /\
             core_ord cd' cd)) /\
         forall
           (UHyp: forall b1 z, U1 b1 z = true -> vis mu b1 = true)
           b ofs (Ub: U2 b ofs = true),
           visTgt mu b = true
           /\ (locBlocksTgt mu b = false ->
               exists b1 delta1,
                 foreign_of mu b1 = Some(b,delta1)
                 /\ U1 b1 (ofs-delta1) = true
                 /\ Mem.perm m1 b1 (ofs-delta1) Max Nonempty))

; core_halted :
    forall cd mu c1 m1 c2 m2 v1,
    match_state cd mu c1 m1 c2 m2 ->
    halted Sem1 c1 = Some v1 ->
    exists v2,
    Mem.inject (as_inj mu) m1 m2
    /\ val_inject (restrict (as_inj mu) (vis mu)) v1 v2
    /\ halted Sem2 c2 = Some v2

; core_at_external :
    forall cd mu c1 m1 c2 m2 e vals1,
    match_state cd mu c1 m1 c2 m2 ->
    at_external Sem1 c1 = Some (e,vals1) ->
    Mem.inject (as_inj mu) m1 m2
    /\ exists vals2,
       Forall2 (val_inject (restrict (as_inj mu) (vis mu))) vals1 vals2
       /\ at_external Sem2 c2 = Some (e,vals2)

    /\ forall
       (pubSrc' pubTgt' : block -> bool)
       (pubSrcHyp : pubSrc' =
                  (fun b : block =>
                  locBlocksSrc mu b && REACH m1 (exportedSrc mu vals1) b))
       (pubTgtHyp: pubTgt' =
                  (fun b : block =>
                  locBlocksTgt mu b && REACH m2 (exportedTgt mu vals2) b))
       nu (Hnu: nu = (replace_locals mu pubSrc' pubTgt')),
       match_state cd nu c1 m1 c2 m2
       /\ Mem.inject (shared_of nu) m1 m2

; eff_after_external:
    forall cd mu st1 st2 m1 e vals1 m2 vals2 e'
      (MemInjMu: Mem.inject (as_inj mu) m1 m2)
      (MatchMu: match_state cd mu st1 m1 st2 m2)
      (AtExtSrc: at_external Sem1 st1 = Some (e,vals1))

        (* We include the clause AtExtTgt to ensure that vals2 is
         uniquely determined. We have e=e' and ef_sig=ef_sig' by the
         at_external clause, but omitting the hypothesis AtExtTgt
         would result in in 2 not necesssarily equal target argument
         lists in language 3 in the transitivity, as val_inject is not
         functional in the case where the left value is Vundef. (And
         we need to keep ValInjMu since vals2 occurs in pubTgtHyp) *)

      (AtExtTgt: at_external Sem2 st2 = Some (e',vals2))
      (ValInjMu: Forall2 (val_inject (restrict (as_inj mu) (vis mu))) vals1 vals2)

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

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

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

      forall nu' ret1 m1' ret2 m2'
        (HasTy1: Val.has_type ret1 (proj_sig_res (AST.ef_sig e)))
        (HasTy2: Val.has_type ret2 (proj_sig_res (AST.ef_sig e')))
        (INC: extern_incr nu nu')
        (SEP: sm_inject_separated nu nu' m1 m2)

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

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

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

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

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

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

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

         (UnchLOOR: Mem.unchanged_on (local_out_of_reach nu m1) m2 m2'),

        exists cd', exists st1', exists st2',
          after_external Sem1 (Some ret1) st1 = Some st1' /\
          after_external Sem2 (Some ret2) st2 = Some st2' /\
          match_state cd' mu' st1' m1' st2' m2' }.

Require Import VST.sepcomp.semantics_lemmas.

Lemma core_diagram (SMI: SM_simulation_inject):
      forall st1 m1 st1' m1',
        corestep Sem1 ge1 st1 m1 st1' m1' ->
      forall cd st2 mu m2,
        match_state SMI cd mu st1 m1 st2 m2 ->
        exists st2', exists m2', exists cd', exists mu',
          intern_incr mu mu' /\
          sm_inject_separated mu mu' m1 m2 /\
          sm_locally_allocated mu mu' m1 m2 m1' m2' /\
          match_state SMI cd' mu' st1' m1' st2' m2' /\
          ((corestep_plus Sem2 ge2 st2 m2 st2' m2') \/
            corestep_star Sem2 ge2 st2 m2 st2' m2' /\
            core_ord SMI cd' cd).
Proof. intros.
apply effax2 in H. destruct H as [U1 H].
exploit (effcore_diagram SMI); eauto.
intros [st2' [m2' [cd' [mu' [INC [SEP [LOCALLOC
  [MST [U2 [STEP _]]]]]]]]]].
exists st2', m2', cd', mu'.
split; try assumption.
split; try assumption.
split; try assumption.
split; try assumption.
destruct STEP as [[n STEP] | [[n STEP] CO]];
  apply effstepN_corestepN in STEP.
left. exists n. assumption.
right; split; trivial. exists n. assumption.
Qed.

End SharedMemory_simulation_inject.

End SM_simulation.


(* *********************************************************************)
(*                                                                     *)
(*            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.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of VMM                                          *)
(*                                                                     *)
(*          Refinement Proof for PProc                                 *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import Errors.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Asm.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Values.
Require Import Memory.
Require Import Maps.
Require Import CommonTactic.
Require Import AuxLemma.
Require Import FlatMemory.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import RealParams.
Require Import LoadStoreSem2.
Require Import AsmImplLemma.
Require Import GenSem.
Require Import RefinementTactic.
Require Import PrimSemantics.
Require Import XOmega.

Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compcertx.MakeProgram.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.
Require Import compcert.cfrontend.Ctypes.

Require Import LAsmModuleSemAux.
Require Import LayerCalculusLemma.
Require Import AbstractDataType.

Require Import PUCtxtIntro.
Require Import PProc.

Require Import ProcGenSpec.

(** * Definition of the refinement relation*)
Section Refinement.

  Local Open Scope string_scope.
  Local Open Scope error_monad_scope.
  Local Open Scope Z_scope.

  Context `{real_params: RealParams}.

  Notation HDATA := RData.
  Notation LDATA := RData.

  Notation HDATAOps := (cdata (cdata_ops := pproc_data_ops) HDATA).
  Notation LDATAOps := (cdata (cdata_ops := pipc_data_ops) LDATA).

  Section WITHMEM.

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

    (** Relation between raw data at two layers*)
    Record relate_RData (f: meminj) (hadt: HDATA) (ladt: LDATA) :=
      mkrelate_RData {
          flatmem_re: FlatMem.flatmem_inj (HP hadt) (HP ladt);
          vmxinfo_re: vmxinfo hadt = vmxinfo ladt;
          devout_re: devout hadt = devout ladt;
          CR3_re:  CR3 hadt = CR3 ladt;
          ikern_re: ikern hadt = ikern ladt;
          pg_re: pg hadt = pg ladt;
          ihost_re: ihost hadt = ihost ladt;
          AC_re: AC hadt = AC ladt;
          ti_fst_re: (fst (ti hadt)) = (fst (ti ladt));
          ti_snd_re: val_inject f (snd (ti hadt)) (snd (ti ladt));
          LAT_re: LAT hadt = LAT ladt;
          nps_re: nps hadt = nps ladt;
          init_re: init hadt = init ladt;

          pperm_re: pperm hadt = pperm ladt;
          PT_re:  PT hadt = PT ladt;
          ptp_re: ptpool hadt = ptpool ladt;
          idpde_re: idpde hadt = idpde ladt;
          ipt_re: ipt hadt = ipt ladt;
          smspool_re: smspool hadt = smspool ladt;

          kctxt_re: kctxt_inj f num_proc (kctxt hadt) (kctxt ladt);
          abtcb_re:  abtcb hadt = abtcb ladt;
          abq_re:  abq hadt = abq ladt;
          cid_re:  cid hadt = cid ladt;
          chpool_re:  syncchpool hadt = syncchpool ladt;
          uctxt_re: uctxt_inj f (uctxt hadt) (uctxt ladt)
        }.

    Inductive match_RData: stencil -> HDATA -> mem -> meminj -> Prop :=
    | MATCH_RDATA: forall habd m f s, match_RData s habd m f.

    Local Hint Resolve MATCH_RDATA.

    Global Instance rel_ops: CompatRelOps HDATAOps LDATAOps :=
      {
        relate_AbData s f d1 d2 := relate_RData f d1 d2;
        match_AbData s d1 m f := match_RData s d1 m f;
        new_glbl := nil
      }.

    (** ** Properties of relations*)
    Section Rel_Property.

      (** Prove that after taking one step, the refinement relation still holds*)
      Lemma relate_incr:
        forall abd abd' f f',
          relate_RData f abd abd'
          -> inject_incr f f'
          -> relate_RData f' abd abd'.
      Proof.
        inversion 1; subst; intros; inv H; constructor; eauto.
        - eapply kctxt_inj_incr; eauto.
        - eapply uctxt_inj_incr; eauto.
      Qed.

      Lemma relate_kernel_mode:
        forall abd abd' f,
          relate_RData f abd abd'
          -> (kernel_mode abd <-> kernel_mode abd').
      Proof.
        inversion 1; simpl; split; congruence.
      Qed.

      Lemma relate_observe:
        forall p abd abd' f,
          relate_RData f abd abd' ->
          observe p abd = observe p abd'.
      Proof.
        inversion 1; simpl; unfold ObservationImpl.observe; congruence.
      Qed.

      Global Instance rel_prf: CompatRel HDATAOps LDATAOps.
      Proof.
        constructor; intros; simpl; trivial.
        eapply relate_incr; eauto.
        eapply relate_kernel_mode; eauto.
        eapply relate_observe; eauto.
      Qed.

    End Rel_Property.

    (** * Proofs the one-step forward simulations for the low level specifications*)
    Section OneStep_Forward_Relation.

      Section FRESH_PRIM.

        Lemma proc_start_user_spec_ref:
          compatsim (crel HDATA LDATA)
                    (primcall_start_user_compatsem proc_start_user_spec)
                    proc_start_user_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          intros.
          inv match_extcall_states.
          exploit proc_start_user_exist; eauto 1.
          eapply valid_curid; eauto.
          intros (d2' & rs2' & HM & HR & HReg & He & Hrange').
          subst.
          refine_split; try econstructor; eauto.
          eapply reg_symbol_inject; eassumption.
          econstructor; eauto.
          constructor.
          val_inject_simpl; try (eapply HReg; omega).
        Qed.

        Lemma proc_exit_user_spec_ref:
          compatsim (crel HDATA LDATA)
                    (primcall_exit_user_compatsem proc_exit_user_spec)
                    proc_exit_user_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          intros.
          inv H4. inv match_extcall_states.
          exploit proc_exit_user_exist; eauto 1.
          - subst uctx4 uctx3 uctx2 uctx1.
            intros. inv_proc. rewrite ZMap.gi. constructor.
          - intros [d2'[HM HR]].
            refine_split; try econstructor; eauto.
            eapply reg_symbol_inject; eassumption.
            + exploit (extcall_args_inject (D1:= HDATAOps) (D2:= LDATAOps)); eauto.
              instantiate (3:= d1').
              apply extcall_args_with_data; eauto.
              instantiate (1:= d2).
              intros [?[? Hinv]]. inv_val_inject.
              apply extcall_args_without_data in H; eauto.
            + specialize (match_reg ESP); unfold Pregmap.get in match_reg.
              inv match_reg; congruence.
            + intros.
              specialize (match_reg ESP); unfold Pregmap.get in match_reg.
              inv match_reg; try congruence.
              specialize (HESP_STACK _ _ (eq_sym H1)).
              replace b1 with b2 by congruence.
              split.
              * apply Ple_trans with b0;
                [ apply HESP_STACK | apply (match_inject_forward _ _ _ H3) ].
              * apply (Mem.valid_block_inject_2 _ _ _ _ _ _ H3 match_inject).
            + econstructor; eauto. constructor.
            + val_inject_simpl.
        Qed.

        Lemma proc_create_kernel_mode:
          forall d2 d2' b b' b2 ofs_uc q,
            proc_create_spec d2 b b' b2 ofs_uc q = Some d2'
            -> kernel_mode d2.
        Proof.
          unfold proc_create_spec; intros.
          simpl; subdestruct. auto.
        Qed.

        Lemma proc_create_spec_ref:
          compatsim (crel HDATA LDATA) (proc_create_compatsem proc_create_spec) proc_create_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit proc_create_exist; eauto 1.
          intros (labd' & HP  & HM).
          destruct H9 as [fun_id Hsymbol].
          exploit (stencil_find_symbol_inject' s ι fun_id buc); eauto.
          intros HFB.
          destruct H10 as [elf_id Hsymbol'].
          exploit (stencil_find_symbol_inject' s ι elf_id be); eauto.
          intros HFB'.
          refine_split; try econstructor; eauto.
          - eapply proc_create_kernel_mode; eauto.
          - constructor.
        Qed.

      End FRESH_PRIM.

      Section PASSTHROUGH_PRIM.

        Global Instance: (LoadStoreProp (hflatmem_store:= flatmem_store) (lflatmem_store:= flatmem_store)).
        Proof.
          accessor_prop_tac.
          - eapply flatmem_store_exists; eauto.
        Qed.

        Lemma passthrough_correct:
          sim (crel HDATA LDATA) pproc_passthrough puctxtintro.
        Proof.
          sim_oplus.
          - apply fload_sim.
          - apply fstore_sim.
          - apply vmxinfo_get_sim.
          - apply device_output_sim.
          (*- apply pfree_sim.*)
          - apply ptRead_sim.
          - apply ptResv_sim.
          - apply shared_mem_status_sim.
          - apply offer_shared_mem_sim.
          - apply get_curid_sim.
          - apply thread_wakeup_sim.
          (*- apply is_chan_ready_sim.
          - apply sendto_chan_sim.
          - apply receive_chan_sim.*)
          - apply syncreceive_chan_sim.
          - apply syncsendto_chan_pre_sim.
          - apply syncsendto_chan_post_sim.
          - apply proc_init_sim.
          - apply uctx_get_sim.
          - apply uctx_set_sim.
          - apply container_get_nchildren_sim.
          - apply container_get_quota_sim.
          - apply container_get_usage_sim.
          - apply container_can_consume_sim.
          - apply alloc_sim.
          - apply hostin_sim.
          - apply hostout_sim.
          - apply trap_info_get_sim.
          - apply trap_info_ret_sim.
          - apply thread_yield_sim.
          - apply thread_sleep_sim.
          - layer_sim_simpl.
            + eapply load_correct2.
            + eapply store_correct2.
        Qed.

      End PASSTHROUGH_PRIM.

    End OneStep_Forward_Relation.

  End WITHMEM.

End Refinement.


From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From fcsl
Require Import prelude pred pcm unionmap heap.
From HTT
Require Import stmod stsep stlog stlogR.
From SSL
Require Import core.
From Hammer Require Import Hammer.
(* Configure Hammer *)
Set Hammer ATPLimit 60.
Unset Hammer Eprover.
Unset Hammer Vampire.
Add Search Blacklist "fcsl.".
Add Search Blacklist "HTT.".
Add Search Blacklist "Coq.ssr.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.bigop".
Add Search Blacklist "mathcomp.ssreflect.choice".
Add Search Blacklist "mathcomp.ssreflect.div".
Add Search Blacklist "mathcomp.ssreflect.finfun".
Add Search Blacklist "mathcomp.ssreflect.fintype".
Add Search Blacklist "mathcomp.ssreflect.path".
Add Search Blacklist "mathcomp.ssreflect.tuple".

Require Import common.

Lemma pure1 (x : nat) (y : nat) : (y) <= (x) -> (x) <= (x). intros; hammer. Qed.
Hint Resolve pure1: ssl_pure.
Lemma pure2 (x : nat) (y : nat) : ~~ ((y) <= (x)) -> (x) <= (y). intros; hammer. Qed.
Hint Resolve pure2: ssl_pure.
Lemma pure3 (y : nat) (x : nat) : ~~ ((y) <= (x)) -> (y) <= (y). intros; hammer. Qed.
Hint Resolve pure3: ssl_pure.

Definition max_type :=
  forall (vprogs : ptr * nat * nat),
  STsep (
    fun h =>
      let: (r, x, y) := vprogs in
      h = r :-> (0),
    [vfun (_: unit) h =>
      let: (r, x, y) := vprogs in
      exists m,
      (x) <= (m) /\ (y) <= (m) /\ h = r :-> (m)
    ]).

Program Definition max : max_type :=
  Fix (fun (max : max_type) vprogs =>
    let: (r, x, y) := vprogs in
    Do (
      if (y) <= (x)
      then
        r ::= x;;
        ret tt
      else
        r ::= y;;
        ret tt
    )).
Obligation Tactic := intro; move=>[[r x] y]; ssl_program_simpl.
Next Obligation.
ssl_ghostelim_pre.
move=>[sigma_self].
subst h_self.
ssl_ghostelim_post.
ssl_branch ((y) <= (x)).
ssl_write r.
ssl_write_post r.
ssl_emp;
exists (x);
sslauto.
ssl_write r.
ssl_write_post r.
ssl_emp;
exists (y);
sslauto.
Qed.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RealmExitHandler.Layer.
Require Import RunAux.Code.emulate_mmio_read.

Require Import RunAux.LowSpecs.emulate_mmio_read.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _access_mask ↦ gensem access_mask_spec
      ⊕ _get_rec_run_emulated_read_val ↦ gensem get_rec_run_emulated_read_val_spec
      ⊕ _esr_sign_extend ↦ gensem esr_sign_extend_spec
      ⊕ _access_len ↦ gensem access_len_spec
      ⊕ _shiftl ↦ gensem shiftl_spec
      ⊕ _esr_sixty_four ↦ gensem esr_sixty_four_spec
      ⊕ _set_rec_regs ↦ gensem set_rec_regs_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_access_mask: block.
    Hypothesis h_access_mask_s : Genv.find_symbol ge _access_mask = Some b_access_mask.
    Hypothesis h_access_mask_p : Genv.find_funct_ptr ge b_access_mask
                                 = Some (External (EF_external _access_mask
                                                  (signature_of_type (Tcons tulong Tnil) tulong cc_default))
                                        (Tcons tulong Tnil) tulong cc_default).
    Local Opaque access_mask_spec.

    Variable b_get_rec_run_emulated_read_val: block.
    Hypothesis h_get_rec_run_emulated_read_val_s : Genv.find_symbol ge _get_rec_run_emulated_read_val = Some b_get_rec_run_emulated_read_val.
    Hypothesis h_get_rec_run_emulated_read_val_p : Genv.find_funct_ptr ge b_get_rec_run_emulated_read_val
                                                   = Some (External (EF_external _get_rec_run_emulated_read_val
                                                                    (signature_of_type Tnil tulong cc_default))
                                                          Tnil tulong cc_default).
    Local Opaque get_rec_run_emulated_read_val_spec.

    Variable b_esr_sign_extend: block.
    Hypothesis h_esr_sign_extend_s : Genv.find_symbol ge _esr_sign_extend = Some b_esr_sign_extend.
    Hypothesis h_esr_sign_extend_p : Genv.find_funct_ptr ge b_esr_sign_extend
                                     = Some (External (EF_external _esr_sign_extend
                                                      (signature_of_type (Tcons tulong Tnil) tuint cc_default))
                                            (Tcons tulong Tnil) tuint cc_default).
    Local Opaque esr_sign_extend_spec.

    Variable b_access_len: block.
    Hypothesis h_access_len_s : Genv.find_symbol ge _access_len = Some b_access_len.
    Hypothesis h_access_len_p : Genv.find_funct_ptr ge b_access_len
                                = Some (External (EF_external _access_len
                                                 (signature_of_type (Tcons tulong Tnil) tuint cc_default))
                                       (Tcons tulong Tnil) tuint cc_default).
    Local Opaque access_len_spec.

    Variable b_shiftl: block.
    Hypothesis h_shiftl_s : Genv.find_symbol ge _shiftl = Some b_shiftl.
    Hypothesis h_shiftl_p : Genv.find_funct_ptr ge b_shiftl
                            = Some (External (EF_external _shiftl
                                             (signature_of_type (Tcons tulong (Tcons tulong Tnil)) tulong cc_default))
                                   (Tcons tulong (Tcons tulong Tnil)) tulong cc_default).
    Local Opaque shiftl_spec.

    Variable b_esr_sixty_four: block.
    Hypothesis h_esr_sixty_four_s : Genv.find_symbol ge _esr_sixty_four = Some b_esr_sixty_four.
    Hypothesis h_esr_sixty_four_p : Genv.find_funct_ptr ge b_esr_sixty_four
                                    = Some (External (EF_external _esr_sixty_four
                                                     (signature_of_type (Tcons tulong Tnil) tuint cc_default))
                                           (Tcons tulong Tnil) tuint cc_default).
    Local Opaque esr_sixty_four_spec.

    Variable b_set_rec_regs: block.
    Hypothesis h_set_rec_regs_s : Genv.find_symbol ge _set_rec_regs = Some b_set_rec_regs.
    Hypothesis h_set_rec_regs_p : Genv.find_funct_ptr ge b_set_rec_regs
                                  = Some (External (EF_external _set_rec_regs
                                                   (signature_of_type (Tcons Tptr (Tcons tuint (Tcons tulong Tnil))) tvoid cc_default))
                                         (Tcons Tptr (Tcons tuint (Tcons tulong Tnil))) tvoid cc_default).
    Local Opaque set_rec_regs_spec.

    Lemma emulate_mmio_read_body_correct:
      forall m d d' env le esr rt rec_base rec_offset
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTesr: PTree.get _esr le = Some (Vlong esr))
             (HPTrt: PTree.get _rt le = Some (Vint rt))
             (HPTrec: PTree.get _rec le = Some (Vptr rec_base (Int.repr rec_offset)))
             (Hspec: emulate_mmio_read_spec0 (VZ64 (Int64.unsigned esr)) (Int.unsigned rt) (rec_base, rec_offset) d = Some d'),
           exists le', (exec_stmt ge env le ((m, d): mem) emulate_mmio_read_body E0 le' (m, d') Out_normal).
    Proof.
      solve_code_proof Hspec emulate_mmio_read_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.


From Coq Require Import String Arith ZArith PropExtensionality Lia.

From Vyper Require Import Config Calldag.
From Vyper.L10 Require Import Base.
From Vyper.L40 Require Import AST Descend Callset Descend Expr Stmt.
From Vyper.L40Metered Require Import Interpret Expr.

Lemma small_stmt_metering_ok
           {C: VyperConfig}
           {bigger_call_depth_bound smaller_call_depth_bound: nat}
           (Ebound: bigger_call_depth_bound = S smaller_call_depth_bound)
           {cd: calldag}
           (fc: fun_ctx cd bigger_call_depth_bound)
           (do_call: forall
                         (fc': fun_ctx cd smaller_call_depth_bound)
                         (world: world_state)
                         (arg_values: list uint256),
                       world_state * expr_result uint256)
           (do_call_metered: forall
                               (decl: L40.AST.decl)
                               (world: world_state)
                               (arg_values: list uint256),
                             world_state * option (expr_result uint256))
           (DoCallOk: forall (fc': fun_ctx cd smaller_call_depth_bound)
                             (world: world_state)
                             (arg_values: list uint256),
                        let '(world', result) := do_call fc' world arg_values in
                          do_call_metered (fun_decl fc') world arg_values
                           =
                          (world', Some result))
           (builtins: string -> option builtin)
           (world: world_state)
           (loc: memory)
           (loops: list loop_ctx)
           (ss: small_stmt)
           (CallOk: let _ := string_set_impl in
                      FSet.is_subset (small_stmt_callset ss)
                                     (decl_callset (fun_decl fc))
                      = true):
  let '(world', result) := interpret_small_stmt Ebound fc do_call builtins
                                                world loc loops ss CallOk
   in interpret_small_stmt_metered (cd_decls cd) do_call_metered builtins
                                   world loc loops ss
       =
      (world', Some result).
Proof.
destruct ss.
{ (* abort *) easy. }
{ (* return *)
  cbn.
  assert (M := expr_metering_ok Ebound fc do_call do_call_metered DoCallOk
                                builtins world loc loops e
                                (callset_descend_return eq_refl CallOk)).
  destruct interpret_expr as (world', result).
  rewrite M.
  now destruct result.
}
{ (* raise *)
  cbn.
  assert (M := expr_metering_ok Ebound fc do_call do_call_metered DoCallOk
                                builtins world loc loops e
                                (callset_descend_raise eq_refl CallOk)).
  destruct interpret_expr as (world', result).
  rewrite M.
  now destruct result.
}
{ (* assign *)
  cbn.
  assert (M := expr_metering_ok Ebound fc do_call do_call_metered DoCallOk
                                builtins world loc loops rhs
                                (callset_descend_assign_rhs eq_refl CallOk)).
  destruct interpret_expr as (world', result).
  rewrite M.
  now destruct result.
}
(* ExprStmt *)
cbn.
assert (M := expr_metering_ok Ebound fc do_call do_call_metered DoCallOk
                              builtins world loc loops e
                              (callset_descend_expr_stmt eq_refl CallOk)).
destruct interpret_expr as (world', result).
rewrite M.
now destruct result.
Qed.

Local Lemma weak_block_metering_ok
           {C: VyperConfig}
           {bigger_call_depth_bound smaller_call_depth_bound: nat}
           (Ebound: bigger_call_depth_bound = S smaller_call_depth_bound)
           {cd: calldag}
           (fc: fun_ctx cd bigger_call_depth_bound)
           (do_call: forall
                         (fc': fun_ctx cd smaller_call_depth_bound)
                         (world: world_state)
                         (arg_values: list uint256),
                       world_state * expr_result uint256)
           (do_call_metered: forall
                               (decl: L40.AST.decl)
                               (world: world_state)
                               (arg_values: list uint256),
                             world_state * option (expr_result uint256))
           (DoCallOk: forall (fc': fun_ctx cd smaller_call_depth_bound)
                             (world: world_state)
                             (arg_values: list uint256),
                        let '(world', result) := do_call fc' world arg_values in
                          do_call_metered (fun_decl fc') world arg_values
                           =
                          (world', Some result))
           (builtins: string -> option builtin)
           (b: block)
           (StmtOk: (* this condition is what makes this lemma weak,
                       later we can prove a stronger lemma without this *)
              match b with
              | Block body =>
                 List.Forall
                   (fun s : stmt =>
                    forall (CallOk : FSet.is_subset (stmt_callset s) (decl_callset (fun_decl fc)) = true)
                      (world : world_state) (loc : memory) (loops : list loop_ctx),
                    let '(world', result) := interpret_stmt Ebound fc do_call builtins
                                                            world loc loops s CallOk
                    in
                     interpret_stmt_metered (cd_decls cd) do_call_metered builtins
                                                           world loc loops s
                      =
                    (world', Some result))
                   body
              end)
           (world: world_state)
           (loc: memory)
           (loops: list loop_ctx)
           (CallOk: let _ := string_set_impl in
                      FSet.is_subset (block_callset b)
                                     (decl_callset (fun_decl fc))
                      = true):
  let '(world', result) := interpret_block Ebound fc do_call builtins
                                           world loc loops b CallOk
   in interpret_block_metered (cd_decls cd) do_call_metered builtins
                              world loc loops b
       =
      (world', Some result).
Proof.
destruct b as [body]. cbn.
remember (callset_descend_block eq_refl CallOk) as COk. clear HeqCOk CallOk.
revert world loc COk. induction body. { easy. }
intros. cbn.
assert (HeadOk := List.Forall_inv StmtOk (callset_descend_stmts_head eq_refl COk)
                                  world loc loops).
cbn in HeadOk.
fold (interpret_stmt Ebound fc do_call builtins world loc loops a).
destruct interpret_stmt as ((world', loc'), result).
rewrite HeadOk.
destruct result; trivial.
apply (IHbody (List.Forall_inv_tail StmtOk) world' loc'
              (callset_descend_stmts_tail eq_refl COk)).
Qed.

Lemma stmt_metering_ok
           {C: VyperConfig}
           {bigger_call_depth_bound smaller_call_depth_bound: nat}
           (Ebound: bigger_call_depth_bound = S smaller_call_depth_bound)
           {cd: calldag}
           (fc: fun_ctx cd bigger_call_depth_bound)
           (do_call: forall
                         (fc': fun_ctx cd smaller_call_depth_bound)
                         (world: world_state)
                         (arg_values: list uint256),
                       world_state * expr_result uint256)
           (do_call_metered: forall
                               (decl: L40.AST.decl)
                               (world: world_state)
                               (arg_values: list uint256),
                             world_state * option (expr_result uint256))
           (DoCallOk: forall (fc': fun_ctx cd smaller_call_depth_bound)
                             (world: world_state)
                             (arg_values: list uint256),
                        let '(world', result) := do_call fc' world arg_values in
                          do_call_metered (fun_decl fc') world arg_values
                           =
                          (world', Some result))
           (builtins: string -> option builtin)
           (world: world_state)
           (loc: memory)
           (loops: list loop_ctx)
           (s: stmt)
           (CallOk: let _ := string_set_impl in
                      FSet.is_subset (stmt_callset s)
                                     (decl_callset (fun_decl fc))
                      = true):
  let '(world', result) := interpret_stmt Ebound fc do_call builtins
                                                world loc loops s CallOk
   in interpret_stmt_metered (cd_decls cd) do_call_metered builtins
                                   world loc loops s
       =
      (world', Some result).
Proof.
revert world loc loops.
induction s using stmt_ind'; intros.
{ (* small *)
  apply small_stmt_metering_ok.
  apply DoCallOk.
}
{ (* switch without default *)
  cbn.
  assert (M := expr_metering_ok Ebound fc do_call do_call_metered DoCallOk
                                builtins world loc loops e
                                (callset_descend_switch_expr eq_refl CallOk)).
  destruct interpret_expr as (world', result).
  rewrite M. clear M.
  destruct result as [value|]. 2:reflexivity.
  remember (callset_descend_cases eq_refl CallOk) as COk. clear HeqCOk CallOk.
  cbn in COk. revert COk.
  induction cases as [|h]. { easy. }
  intro COk.
  destruct h as [h_guard].
  fold (interpret_block Ebound fc do_call builtins).
  destruct (Z_of_uint256 value =? Z_of_uint256 h_guard)%Z.
  { (* match found *)
    assert (Hh := List.Forall_inv H). cbn in Hh.
    apply (weak_block_metering_ok Ebound fc do_call do_call_metered DoCallOk
                                         builtins body Hh world' loc loops
                                         (callset_descend_cases_head eq_refl COk)).
  }
  (* no match *)
  apply (IHcases (List.Forall_inv_tail H) (callset_descend_cases_tail eq_refl COk)).
}
{
  (* switch with default *)
  cbn.
  assert (M := expr_metering_ok Ebound fc do_call do_call_metered DoCallOk
                                builtins world loc loops e
                                (callset_descend_switch_expr eq_refl CallOk)).
  destruct interpret_expr as (world', result).
  rewrite M. clear M.
  destruct result as [value|]. 2:reflexivity.
  remember (callset_descend_cases eq_refl CallOk) as COk. clear HeqCOk.
  remember (callset_descend_cases_default eq_refl CallOk) as DOk. clear HeqDOk CallOk.
  cbn in COk. revert COk.
  induction cases as [|h].
  {
    intro Foo.
    apply (weak_block_metering_ok Ebound fc do_call do_call_metered DoCallOk
                                  builtins (Block default) H0 world' loc loops
                                  DOk).
  }
  intro COk.
  destruct h as [h_guard].
  fold (interpret_block Ebound fc do_call builtins).
  destruct (Z_of_uint256 value =? Z_of_uint256 h_guard)%Z.
  { (* match found *)
    assert (Hh := List.Forall_inv H). cbn in Hh.
    apply (weak_block_metering_ok Ebound fc do_call do_call_metered DoCallOk
                                         builtins body Hh world' loc loops
                                         (callset_descend_cases_head eq_refl COk)).
  }
  (* no match *)
  apply (IHcases (List.Forall_inv_tail H) (callset_descend_cases_tail eq_refl COk)).
}
(* loop *)
remember (Block body) as loop_body.
cbn. fold (interpret_block Ebound fc do_call builtins).
subst loop_body.
remember (Z.to_nat (Z_of_uint256 count)) as n. clear Heqn.
remember (OpenArray.get loc var) as offset. clear Heqoffset.
revert world loc.
induction n. { trivial. }
intros.
assert (W := let _ := memory_impl in
             weak_block_metering_ok Ebound fc do_call do_call_metered DoCallOk
                                    builtins (Block body) H world loc
                                    ({|
                                       loop_offset := offset;
                                       loop_count := count;
                                       loop_countdown := n
                                    |} :: loops)
                                    (callset_descend_loop_body eq_refl CallOk)).
destruct interpret_block as ((world', loc'), result). rewrite W. clear W.
destruct result. 3:trivial.
{ apply IHn. }
destruct a; trivial.
apply IHn.
Qed.

Lemma block_metering_ok
           {C: VyperConfig}
           {bigger_call_depth_bound smaller_call_depth_bound: nat}
           (Ebound: bigger_call_depth_bound = S smaller_call_depth_bound)
           {cd: calldag}
           (fc: fun_ctx cd bigger_call_depth_bound)
           (do_call: forall
                         (fc': fun_ctx cd smaller_call_depth_bound)
                         (world: world_state)
                         (arg_values: list uint256),
                       world_state * expr_result uint256)
           (do_call_metered: forall
                               (decl: L40.AST.decl)
                               (world: world_state)
                               (arg_values: list uint256),
                             world_state * option (expr_result uint256))
           (DoCallOk: forall (fc': fun_ctx cd smaller_call_depth_bound)
                             (world: world_state)
                             (arg_values: list uint256),
                        let '(world', result) := do_call fc' world arg_values in
                          do_call_metered (fun_decl fc') world arg_values
                           =
                          (world', Some result))
           (builtins: string -> option builtin)
           (world: world_state)
           (loc: memory)
           (loops: list loop_ctx)
           (b: block)
           (CallOk: let _ := string_set_impl in
                      FSet.is_subset (block_callset b)
                                     (decl_callset (fun_decl fc))
                      = true):
  let '(world_and_loc', result) := interpret_block Ebound fc do_call builtins
                                           world loc loops b CallOk
   in interpret_block_metered (cd_decls cd) do_call_metered builtins
                              world loc loops b
       =
      (world_and_loc', Some result).
Proof.
refine (weak_block_metering_ok Ebound fc do_call do_call_metered DoCallOk
                               builtins b _ world loc loops CallOk).
clear CallOk world loc loops.
destruct b as [body].
rewrite List.Forall_forall.
intros s H CallOk world loc loops. clear H.
apply (stmt_metering_ok Ebound fc do_call do_call_metered DoCallOk
                        builtins world loc loops).
Qed.

(****************************************************************************)
(* DEPRECATED *)
Lemma small_stmt_respects_var_cap
           {C: VyperConfig}
           {bigger_call_depth_bound smaller_call_depth_bound: nat}
           (Ebound: bigger_call_depth_bound = S smaller_call_depth_bound)
           {cd: calldag}
           (fc: fun_ctx cd bigger_call_depth_bound)
           (do_call: forall
                         (fc': fun_ctx cd smaller_call_depth_bound)
                         (world: world_state)
                         (arg_values: list uint256),
                       world_state * expr_result uint256)
           (do_call_metered: forall
                               (decl: L40.AST.decl)
                               (world: world_state)
                               (arg_values: list uint256),
                             world_state * option (expr_result uint256))
           (DoCallOk: forall (fc': fun_ctx cd smaller_call_depth_bound)
                             (world: world_state)
                             (arg_values: list uint256),
                        let '(world', result) := do_call fc' world arg_values in
                          do_call_metered (fun_decl fc') world arg_values
                           =
                          (world', Some result))
           (builtins: string -> option builtin)
           (world: world_state)
           (loc: memory)
           (loops: list loop_ctx)
           (ss: small_stmt)
           (CallOk: let _ := string_set_impl in
                      FSet.is_subset (small_stmt_callset ss)
                                     (decl_callset (fun_decl fc))
                      = true):
  let '(world, loc', result) :=
      interpret_small_stmt_metered (cd_decls cd) do_call_metered builtins
                                   world loc loops ss
  in forall k,
       (var_cap_small_stmt ss <= k)%N
        ->
       let _ := memory_impl in
       OpenArray.get loc k = OpenArray.get loc' k.
Proof.
remember (interpret_small_stmt_metered (cd_decls cd) do_call_metered builtins world loc loops ss) as output.
destruct output as ((world', loc'), result).
intros k L. cbn.
destruct ss; cbn in L; cbn in Heqoutput.
{ (* abort *) inversion Heqoutput. now subst. }
{ (* return *)
  destruct interpret_expr_metered as (w, r).
  destruct r as [r|]; [destruct r as [|r]|]; inversion Heqoutput; now subst.
}
{ (* raise *)
  destruct interpret_expr_metered as (w, r).
  destruct r as [r|]; [destruct r as [|r]|]; inversion Heqoutput; now subst.
}
{ (* assign *)
  destruct interpret_expr_metered as (w, r).
  destruct r as [r|]; [destruct r as [|r]|]; inversion Heqoutput; subst; try easy.
  rewrite OpenArray.put_ok.
  assert (B: (lhs <> k)%N) by lia.
  apply N.eqb_neq in B. now rewrite B.
}
(* expr *)
destruct interpret_expr_metered as (w, r).
destruct r as [r|]; [destruct r as [|r]|]; inversion Heqoutput; now subst.
Qed.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.
From fcsl
Require Import pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Freshness State EqTypeX Protocols.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module WorldGetters.
Section WorldGetters.

(* It's okay to have duplicating nodes in this list *)

(* World is a dependent partial map of protocols *)

Definition context := union_map Label protocol.

(*
The hooks are dependencies between:

1. a hook's unique id
2. a core protocol
3. a client protocol
4. a send-transition (represented by its tag) of a client protocol

*)
Definition hook_domain := [ordType of ((nat * Label) * (Label * nat))%type].

(*

A hook is a constraint from the local state wrt. core protocol (1st
heap argument), relating the local state wrt. the client protocol (2ns
heap argument), message to be sent, and the destination node id.

*)
Definition hook_type := heap -> heap -> seq nat -> nid -> Prop.

Definition hooks := union_map hook_domain hook_type.
Definition world := (context * hooks)%type.

Definition getc (w: world) : context := fst w.
Coercion getc : world >-> context.

Definition geth (w: world) : hooks := snd w.
Coercion geth : world >-> hooks.

Variable w : world.

Variables (p : protocol).

(* The function is, in fact, partially defined and returns Empty
   Protocol for a non-present label. *)
Definition getProtocol i : protocol:=
  match find i (getc w) with
  | Some p => p
  | None => EmptyProt i
  end.

End WorldGetters.
End WorldGetters.

Export WorldGetters.

(* Defining coherence of a state with respect to the world *)

Module Worlds.

Module Core.
Section Core.

(* The following definition ties together worlds and states *)

Definition hooks_consistent (c : context) (h : hooks) : Prop :=
  forall z lc ls t, ((z, lc), (ls, t)) \in dom h ->
  (lc \in dom c) && (ls \in dom c).

Definition hook_complete w := hooks_consistent (getc w) (geth w).

Lemma hook_complete0 c : hook_complete (c, Unit).
Proof. by move=>????; rewrite dom0. Qed.

Definition Coh (w : world) : Pred state := fun s =>
  let: c := fst w in
  let: h := snd w in
  [/\ valid w, valid s, hook_complete w,
      dom c =i dom s &
      forall l, coh (getProtocol w l) (getStatelet s l)].

Lemma cohW w s : Coh w s -> valid w.
Proof. by case w=>[c h]; case. Qed.

Lemma cohS w s : Coh w s -> valid s.
Proof. by case w=>[c h]; case. Qed.

Lemma cohH w s : Coh w s -> hook_complete w.
Proof. by case w=>[c h]; case. Qed.

Lemma cohD w s : Coh w s -> dom (getc w) =i dom s.
Proof. by case w=>[c h]; case. Qed.

Lemma coh_coh w s l : Coh w s -> coh (getProtocol w l) (getStatelet s l).
Proof. by case w=>[c h]; case. Qed.

(* Now we need to establish a bunch of natural properties with respect
   to coherence of worlds and states. *)

Lemma unit_coh w s :
  Coh w s -> w = Unit <-> s = Unit.
Proof.
case: (w)=>[c h].
case=>V V' Hc E H; split.
case=>Z1 Z2; subst c h; rewrite dom0 in E; last by rewrite (dom0E V').
move=>Z; subst s; move/andP: V=>/=[V1 V2].
have Z: c = Unit by apply: (dom0E V1); move=>z; rewrite E dom0.
subst c; suff Z: (h = Unit) by subst h.
simpl in Hc; clear E H V1 V'.
apply: (dom0E V2); move=> x; case X: (x \in dom h)=>//.
by move: x X=>[[z lc] [ls t]]/Hc/andP[]; rewrite !dom0.
Qed.

Lemma Coh0 (w : world) (s : state) :
  w = Unit -> s = Unit -> Coh w s.
Proof.
move=>->->{w s}; split; rewrite ?dom0=>//=; last first.
- by move=>l; rewrite /getProtocol /getStatelet !find0E.
by move=>z lc ls t; rewrite dom0.
Qed.

Lemma CohUn (w1 w2 : world) (s1 s2 : state) :
  Coh w1 s1 -> Coh w2 s2 ->
  valid (w1 \+ w2) -> Coh (w1 \+ w2) (s1 \+ s2).
Proof.
case: w1=>[c1 h1]; case: w2=>[c2 h2]; move=>C1 C2 V.
case: (C1)=>_ G1 K1 J1 H1; case: (C2)=>_ G2 K2 J2 H2.
case/andP: V=>V V'; simpl in V, V'.
have X: valid (s1 \+ s2).
- case: validUn=>//; [by rewrite G1|by rewrite G2|move=>l; rewrite -J1 -J2=>D1 D2].
  by case: validUn V=>//=V1 V2; move/(_ _ D1); rewrite D2.
have Y: dom (c1 \+ c2) =i dom (s1 \+ s2).
- by move=>z; rewrite !domUn !inE/=;rewrite V X/= J1 J2.
have Z1:  valid ((c1, h1) \+ (c2, h2)) by rewrite /valid/= V V'.
split=>//[|l]; last first.
- rewrite /getProtocol /getStatelet.
  case: (dom_find l (s1 \+ s2))=>[|v]Z.
  - by move/find_none: (Z); rewrite -Y; case: dom_find=>//->_; rewrite Z.
  move/find_some: (Z)=>D; rewrite Z; rewrite -Y in D=> E.
  case: dom_find D=>// p Z' _ _; rewrite Z'.
  rewrite findUnL // in Z; rewrite findUnL // J1 in Z'.
  by case: ifP Z Z'=>_ F1 F2; [move: (H1 l)|move: (H2 l)];
     rewrite /getProtocol /getStatelet F1 F2.
by move=>z lc ls t/=; rewrite domUn inE=>/andP[_]/orP[];[move/K1|move/K2];
   move/andP=>[A1 A2]; rewrite !domUn !inE A1 A2 V -?(orbC true).
Qed.

(* Coherence is trivially precise wrt. statelets *)
Lemma coh_prec w: precise (Coh w).
Proof.
move=>s1 s2 t1 t2 V C1 C2.
case: C1 => H1 G1 K1 D1 _.
case: C2 => H2 G2 K2 D2 _ H.
by apply: (@dom_prec _ _ _  s1 s2 t1 t2)=>//z; rewrite -D1 -D2.
Qed.

Lemma locE i n k x y :
  k \in dom i -> valid i -> valid (dstate (getStatelet i k)) ->
  getLocal n (getStatelet (upd k
       {| dstate := upd n x (dstate (getStatelet i k));
          dsoup := y |} i) k) = x.
Proof.
move=>D V; rewrite /getStatelet; case:dom_find (D) =>//d->_ _.
by rewrite findU eqxx/= V /getLocal/= findU eqxx/==>->.
Qed.

Lemma locE' d n x y :
  valid (dstate d) ->
  getLocal n {| dstate := upd n x (dstate d);
                dsoup := y |} = x.
Proof. by move=>V; rewrite /getLocal findU eqxx/= V. Qed.

Lemma locU n n' x st s :
  n != n' ->
  valid st ->
  getLocal n {| dstate := upd n' x st; dsoup := s |} =
  getLocal n {| dstate := st; dsoup := s |}.
Proof.
  move=> /negbTE N V.
  by rewrite /getLocal findU/= N.
Qed.

Section MakeWorld.

Variable p : protocol.
Notation l := (plab p).

Definition mkWorld : world := (l \\-> p, Unit).

Lemma prEq : (getProtocol mkWorld l) = p.
Proof. by rewrite /getProtocol findPt. Qed.

(*

Here's an incomplete list of procedures and facts, which might be
useful eventually:

- Define getters for particular transitions of worlds;

 *)

End MakeWorld.

(* TODO: try_recv should be restricted by a set of labels and a set of
   protocols *)
End Core.
End Core.

End Worlds.

Export Worlds.Core.