(* *********************************************************************)
(*                                                                     *)
(*            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: MPTKern                                 *)
(*                                                                     *)
(*          initialize the page map of the kernel thread               *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file defines the abstract data and the primitives for the MPTKern layer, which will initialize kernel's page table ([0th page table])*)
Require Import Coqlib.
Require Import Maps.
Require Import ASTExtra.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Stacklayout.
Require Import Globalenvs.
Require Import AsmX.
Require Import Smallstep.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import FlatMemory.
Require Import CommonTactic.
Require Import AuxLemma.
Require Import RealParams.
Require Import PrimSemantics.
Require Import LAsm.
Require Import LoadStoreSem2.
Require Import XOmega.

Require Import CalRealPTPool.
Require Import CalRealPT.
Require Import INVLemmaContainer.
Require Import INVLemmaMemory.
Require Import CalRealIDPDE.
Require Import CalRealInitPTE.

Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.

Require Import AbstractDataType.
Require Export MPTCommon.

Section WITHMEM.

  Local Open Scope Z_scope.

  Context `{real_params: RealParams}.

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

  (** * Proofs that the primitives satisfies the invariants at this layer *)
  Section INV.

    Section PTINSERT.

      Section PTINSERT_PTE.

        Lemma ptInsertPTE_high_level_inv:
          forall d d' n vadr padr p,
            ptInsertPTE_spec n vadr padr p d = Some d' ->
            high_level_invariant d ->
            high_level_invariant d'.
        Proof.
          intros. functional inversion H; subst; eauto.
          inv H0; constructor_gso_simpl_tac.
          - intros; eapply AT_kern_norm; eauto.
          - intros; eapply AT_usr_norm; eauto.
          - apply ptInsertPTE_quota_bounded_AT in H; auto.
          - eapply consistent_ppage_norm; eassumption.
          - intros. congruence.
        Qed.

        Lemma ptInsertPTE_low_level_inv:
          forall d d' n vadr padr p n',
            ptInsertPTE_spec n vadr padr p d = Some d' ->
            low_level_invariant n' d ->
            low_level_invariant n' d'.
        Proof.
          intros. functional inversion H; subst; eauto.
          inv H0. constructor; eauto.
        Qed.

        Lemma ptInsertPTE_kernel_mode:
          forall d d' n vadr padr p,
            ptInsertPTE_spec n vadr padr p d = Some d' ->
            kernel_mode d ->
            kernel_mode d'.
        Proof.
          intros. functional inversion H; subst; eauto.
        Qed.

      End PTINSERT_PTE.

      Lemma ptInsert_high_level_inv:
        forall d d' n vadr padr p v,
          ptInsert_spec n vadr padr p d = Some (d', v) ->
          high_level_invariant d ->
          high_level_invariant d'.
      Proof.
        intros. functional inversion H; subst; eauto.
        - eapply ptInsertPTE_high_level_inv; eassumption.
        - eapply ptAllocPDE_high_level_inv; eassumption.
        - eapply ptInsertPTE_high_level_inv; try eassumption.
          eapply ptAllocPDE_high_level_inv; eassumption.
      Qed.

      Lemma ptInsert_low_level_inv:
        forall d d' n vadr padr p n' v,
          ptInsert_spec n vadr padr p d = Some (d', v) ->
          low_level_invariant n' d ->
          low_level_invariant n' d'.
      Proof.
        intros. functional inversion H; subst; eauto.
        - eapply ptInsertPTE_low_level_inv; eassumption.
        - eapply ptAllocPDE_low_level_inv; eassumption.
        - eapply ptInsertPTE_low_level_inv; try eassumption.
          eapply ptAllocPDE_low_level_inv; eassumption.
      Qed.

      Lemma ptInsert_kernel_mode:
        forall d d' n vadr padr p v,
          ptInsert_spec n vadr padr p d = Some (d', v) ->
          kernel_mode d ->
          kernel_mode d'.
      Proof.
        intros. functional inversion H; subst; eauto.
        - eapply ptInsertPTE_kernel_mode; eassumption.
        - eapply ptAllocPDE_kernel_mode; eassumption.
        - eapply ptInsertPTE_kernel_mode; try eassumption.
          eapply ptAllocPDE_kernel_mode; eassumption.
      Qed.

      Global Instance ptInsert_inv: PreservesInvariants ptInsert_spec.
      Proof.
        preserves_invariants_simpl'.
        - eapply ptInsert_low_level_inv; eassumption.
        - eapply ptInsert_high_level_inv; eassumption.
        - eapply ptInsert_kernel_mode; eassumption.
      Qed.

    End PTINSERT.

    Global Instance ptRmv_inv: PreservesInvariants ptRmv_spec.
    Proof.
      preserves_invariants_simpl low_level_invariant high_level_invariant; eauto;
      try (rewrite ZMap.gso; eauto; fail).
      - intros; eapply AT_kern_norm; eauto.
      - intros; eapply AT_usr_norm; eauto.
      - apply ptRmv_quota_bounded_AT in H2; auto.
      - eapply consistent_ppage_norm; eassumption.
    Qed.

    Global Instance pt_init_kern_inv: PreservesInvariants pt_init_kern_spec.
    Proof.
      preserves_invariants_simpl low_level_invariant high_level_invariant; auto.
      - apply real_nps_range.
      - apply real_at_kern_valid.
      - apply real_at_usr_valid.
      - apply real_container_valid.
      - apply real_quota_bounded_AT.
      - rewrite init_pperm; try assumption.
        apply real_pperm_valid.
    Qed.

  End INV.

  (** * Layer Definition *)
  (** ** Layer Definition newly introduced  *)
  Definition mptkern_fresh : compatlayer (cdata RData) :=
    pt_insert ↦ gensem ptInsert_spec
              ⊕ pt_rmv ↦ gensem ptRmv_spec
              ⊕ pt_init_kern ↦ gensem pt_init_kern_spec.

  (** ** Layer Definition passthrough  *)
  Definition mptkern_passthrough : compatlayer (cdata RData) :=
    fload ↦ gensem fload_spec
          ⊕ fstore ↦ gensem fstore_spec
          ⊕ flatmem_copy ↦ gensem flatmem_copy_spec
          ⊕ vmxinfo_get ↦ gensem vmxinfo_get_spec
          ⊕ device_output ↦ gensem device_output_spec
          ⊕ set_pg ↦ gensem setPG1_spec
          ⊕ at_get_c ↦ gensem get_at_c_spec
          ⊕ at_set_c ↦ gensem set_at_c0_spec
          ⊕ pfree ↦ gensem pfree'_spec
          ⊕ set_pt ↦ gensem setPT'_spec

          ⊕ pt_read ↦ gensem ptRead_spec
          ⊕ pt_read_pde ↦ gensem ptReadPDE_spec
          ⊕ pt_free_pde ↦ gensem ptFreePDE_spec

          ⊕ pt_in ↦ primcall_general_compatsem' ptin'_spec (prim_ident:= pt_in)
          ⊕ pt_out ↦ primcall_general_compatsem' ptout_spec (prim_ident:= pt_out)
          ⊕ clear_cr2 ↦ gensem clearCR2_spec
          ⊕ container_get_parent ↦ gensem container_get_parent_spec
          ⊕ container_get_nchildren ↦ gensem container_get_nchildren_spec
          ⊕ container_get_quota ↦ gensem container_get_quota_spec
          ⊕ container_get_usage ↦ gensem container_get_usage_spec
          ⊕ container_can_consume ↦ gensem container_can_consume_spec
          ⊕ container_split ↦ gensem container_split_spec
          ⊕ container_alloc ↦ gensem container_alloc_spec
          ⊕ trap_in ↦ primcall_general_compatsem trapin_spec
          ⊕ trap_out ↦ primcall_general_compatsem trapout_spec
          ⊕ host_in ↦ primcall_general_compatsem hostin_spec
          ⊕ host_out ↦ primcall_general_compatsem hostout_spec
          ⊕ trap_get ↦ primcall_trap_info_get_compatsem trap_info_get_spec
          ⊕ trap_set ↦ primcall_trap_info_ret_compatsem trap_info_ret_spec
          ⊕ accessors ↦ {| exec_load := (@exec_loadex _ _ Hmwd);
                           exec_store := (@exec_storeex _ _ Hmwd) |}.

  (** * Layer Definition *)
  Definition mptkern : compatlayer (cdata RData) := mptkern_fresh ⊕ mptkern_passthrough.

  (*Definition semantics := LAsm.Lsemantics mptintro.*)

End WITHMEM.

Section WITHPARAM.

  Context `{real_params: RealParams}.

  Local Open Scope Z_scope.

  Section Impl.

  Function pt_init_spec (mbi_adr:Z) (adt: RData): option RData :=
    match (init adt, pg adt, ikern adt, ihost adt, ipt adt) with
      | (false, false, true, true, true) =>
        Some adt {vmxinfo: real_vmxinfo} {pg: true} {AT: real_AT (AT adt)} {nps: real_nps}
             {AC: real_AC} {init: true} {PT: 0} {ptpool: real_pt (ptpool adt)}
             {idpde: real_idpde (idpde adt)}
      | _ => None
    end.

  End Impl.

End WITHPARAM.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef1.Spec.
Require Import TableDataOpsRef1.Layer.
Require Import TableDataOpsRef2.Code.table_create2.

Require Import TableDataOpsRef2.LowSpecs.table_create2.

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) :=
    _table_create ↦ gensem table_create_spec
      ⊕ _table_create1 ↦ gensem table_create1_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_table_create: block.
    Hypothesis h_table_create_s : Genv.find_symbol ge _table_create = Some b_table_create.
    Hypothesis h_table_create_p : Genv.find_funct_ptr ge b_table_create
                                  = Some (External (EF_external _table_create
                                                   (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr (Tcons tulong Tnil))))) tulong cc_default))
                                         (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr (Tcons tulong Tnil))))) tulong cc_default).
    Local Opaque table_create_spec.

    Variable b_table_create1: block.
    Hypothesis h_table_create1_s : Genv.find_symbol ge _table_create1 = Some b_table_create1.
    Hypothesis h_table_create1_p : Genv.find_funct_ptr ge b_table_create1
                                   = Some (External (EF_external _table_create1
                                                    (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr (Tcons tulong Tnil))))) tulong cc_default))
                                          (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr (Tcons tulong Tnil))))) tulong cc_default).
    Local Opaque table_create1_spec.

    Lemma table_create2_body_correct:
      forall m d d' env le g_rd_base g_rd_offset map_addr level g_rtt_base g_rtt_offset rtt_addr res
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTg_rd: PTree.get _g_rd le = Some (Vptr g_rd_base (Int.repr g_rd_offset)))
             (HPTmap_addr: PTree.get _map_addr le = Some (Vlong map_addr))
             (HPTlevel: PTree.get _level le = Some (Vlong level))
             (HPTg_rtt: PTree.get _g_rtt le = Some (Vptr g_rtt_base (Int.repr g_rtt_offset)))
             (HPTrtt_addr: PTree.get _rtt_addr le = Some (Vlong rtt_addr))
             (Hspec: table_create2_spec0 (g_rd_base, g_rd_offset) (VZ64 (Int64.unsigned map_addr)) (VZ64 (Int64.unsigned level)) (g_rtt_base, g_rtt_offset) (VZ64 (Int64.unsigned rtt_addr)) d = Some (d', VZ64 (Int64.unsigned res))),
           exists le', (exec_stmt ge env le ((m, d): mem) table_create2_body E0 le' (m, d') (Out_return (Some (Vlong res, tulong)))).
    Proof.
      solve_code_proof Hspec table_create2_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

   Lemmas about static semantics of heap objects.

*)

Require Export LanguageModuleDef.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export DynamicSemanticsTypeSubstitution.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemanticsKindingAndContextWellFormednessLemmas.
Require Export StaticSemantics.
Require Export TypeSafety.
Require Export CpdtTactics.
Require Export TacticNotations.
Require Export Tacticals.

Lemma gettype_weakening:
  forall (u : Upsilon) (x : EV.T) (tau' tau : Tau) (p : Path),
    WFU u ->
    gettype u x [] tau' p tau ->
    forall (u' : Upsilon),
      U.extends u u' = true ->
      WFU u' ->
      gettype u' x [] tau' p tau.
Proof.
  intros u x tau' tau p WFUder gettypeder.
  gettype_ind_cases(induction gettypeder) Case.
  Case "gettype u x p tau [] tau".
   constructor.
  Case "gettype u x p (cross t0 t1) (i_pe zero_pe :: p') tau".
   intros.
   apply IHgettypeder with (u':=u') in WFUder; try assumption.
   constructor; try assumption.
  Case "gettype u x p (cross t0 t1) (i_pe one_pe :: p') tau".
   intros.
   apply IHgettypeder with (u':=u') in WFUder; try assumption.
   constructor; try assumption.
  Case "gettype u x p (etype aliases alpha k tau') (u_pe :: p') tau)".
   intros.
   pose proof WFUder as WFUder'.
   apply IHgettypeder with (u':=u') in WFUder; try assumption.
   apply gettype_etype with (tau'':= tau''); try assumption.
   apply U.map_extends_some_agreement with (c:= u); try assumption.
   apply WFU_implies_nodup; try assumption.
   apply WFU_implies_nodup; try assumption.
Qed.

Lemma refp_weakening:
  forall (h : Heap) (u : Upsilon),
    H.nodup h = true ->
    refp h u ->
    forall (h' : Heap),
      H.nodup h' = true ->
      H.extends h h' = true ->
      refp h' u.
Proof.
  intros h u noduph refpder.
  (* h, h' or refp. *)
  induction refpder.
  Case "u = []".
   intros.
   constructor.
  Case "refp_pack".
   intros.
   apply refp_pack with (tau:= tau) (alpha:= alpha) (k:= k) (v:= v) (v':= v');
     try assumption.
   apply H.map_extends_some_agreement with (c:= h); try assumption.
   apply IHrefpder; try assumption.
   (* Scotch Whiskey society wierd but wonderful. *)
Qed.


Require Import Bool String List.
Require Import Lib.CommonTactics Lib.ilist Lib.Word Lib.Indexer.
Require Import Kami.Syntax Kami.Notations Kami.Semantics Kami.Specialize Kami.Duplicate.
Require Import Kami.Wf Kami.Tactics.
Require Import Kami.PrimFifo.
Require Import Ex.MemTypes Ex.SC Ex.MemAsync Ex.ProcDec.

Set Implicit Arguments.

Section D2eInst.
  Variables addrSize iaddrSize instBytes dataBytes rfIdx: nat.

  Definition d2eEltI :=
    STRUCT { "opType" :: Bit 2;
             "dst" :: Bit rfIdx;
             "addr" :: Bit addrSize;
             "byteEn" :: Array Bool dataBytes;
             "val1" :: Data dataBytes;
             "val2" :: Data dataBytes;
             "rawInst" :: Data instBytes;
             "curPc" :: Pc iaddrSize;
             "nextPc" :: Pc iaddrSize;
             "epoch" :: Bool }.

  Definition d2ePackI ty
             (opTy: Expr ty (SyntaxKind (Bit 2)))
             (dst: Expr ty (SyntaxKind (Bit rfIdx)))
             (addr: Expr ty (SyntaxKind (Bit addrSize)))
             (byteEn: Expr ty (SyntaxKind (Array Bool dataBytes)))
             (val1 val2: Expr ty (SyntaxKind (Data dataBytes)))
             (rawInst: Expr ty (SyntaxKind (Data instBytes)))
             (curPc: Expr ty (SyntaxKind (Pc iaddrSize)))
             (nextPc: Expr ty (SyntaxKind (Pc iaddrSize)))
             (epoch: Expr ty (SyntaxKind Bool)): Expr ty (SyntaxKind (Struct d2eEltI)) :=
    STRUCT { "opType" ::= opTy;
             "dst" ::= dst;
             "addr" ::= addr;
             "byteEn" ::= byteEn;
             "val1" ::= val1;
             "val2" ::= val2;
             "rawInst" ::= rawInst;
             "curPc" ::= curPc;
             "nextPc" ::= nextPc;
             "epoch" ::= epoch }%kami_expr.

  Definition d2eOpTypeI ty (d2e: fullType ty (SyntaxKind (Struct d2eEltI)))
    : Expr ty (SyntaxKind (Bit 2)) := (#d2e!d2eEltI@."opType")%kami_expr.
  Definition d2eDstI ty (d2e: fullType ty (SyntaxKind (Struct d2eEltI)))
    : Expr ty (SyntaxKind (Bit rfIdx)) := (#d2e!d2eEltI@."dst")%kami_expr.
  Definition d2eAddrI ty (d2e: fullType ty (SyntaxKind (Struct d2eEltI)))
    : Expr ty (SyntaxKind (Bit addrSize)) := (#d2e!d2eEltI@."addr")%kami_expr.
  Definition d2eByteEnI ty (d2e: fullType ty (SyntaxKind (Struct d2eEltI)))
    : Expr ty (SyntaxKind (Array Bool dataBytes)) := (#d2e!d2eEltI@."byteEn")%kami_expr.
  Definition d2eVal1I ty (d2e: fullType ty (SyntaxKind (Struct d2eEltI)))
    : Expr ty (SyntaxKind (Data dataBytes)) := (#d2e!d2eEltI@."val1")%kami_expr.
  Definition d2eVal2I ty (d2e: fullType ty (SyntaxKind (Struct d2eEltI)))
    : Expr ty (SyntaxKind (Data dataBytes)) := (#d2e!d2eEltI@."val2")%kami_expr.
  Definition d2eRawInstI ty (d2e: fullType ty (SyntaxKind (Struct d2eEltI)))
    : Expr ty (SyntaxKind (Data instBytes)) := (#d2e!d2eEltI@."rawInst")%kami_expr.
  Definition d2eCurPcI ty (d2e: fullType ty (SyntaxKind (Struct d2eEltI)))
    : Expr ty (SyntaxKind (Pc iaddrSize)) := (#d2e!d2eEltI@."curPc")%kami_expr.
  Definition d2eNextPcI ty (d2e: fullType ty (SyntaxKind (Struct d2eEltI)))
    : Expr ty (SyntaxKind (Pc iaddrSize)) := (#d2e!d2eEltI@."nextPc")%kami_expr.
  Definition d2eEpochI ty (d2e: fullType ty (SyntaxKind (Struct d2eEltI)))
    : Expr ty (SyntaxKind Bool) := (#d2e!d2eEltI@."epoch")%kami_expr.

End D2eInst.

Section E2wInst.
  Variables addrSize iaddrSize instBytes dataBytes rfIdx: nat.

  Definition e2wEltI :=
    STRUCT { "decInst" :: Struct (d2eEltI addrSize iaddrSize instBytes dataBytes rfIdx);
             "val" :: Data dataBytes }.

  Definition e2wPackI ty
             (decInst: Expr ty (SyntaxKind (Struct (d2eEltI addrSize iaddrSize instBytes dataBytes rfIdx))))
             (val: Expr ty (SyntaxKind (Data dataBytes))) : Expr ty (SyntaxKind (Struct e2wEltI))
    := STRUCT { "decInst" ::= decInst;
                "val" ::= val }%kami_expr.

  Definition e2wDecInstI ty (e2w: fullType ty (SyntaxKind (Struct e2wEltI)))
    : Expr ty (SyntaxKind (Struct (d2eEltI addrSize iaddrSize instBytes dataBytes rfIdx))) :=
    (#e2w!e2wEltI@."decInst")%kami_expr.
  Definition e2wValI ty (e2w: fullType ty (SyntaxKind (Struct e2wEltI)))
    : Expr ty (SyntaxKind (Data dataBytes)) := (#e2w!e2wEltI@."val")%kami_expr.

End E2wInst.

(* A three-staged processor, where three sets -- {fetch, decode}, {execute}, and
 * {mem, write-back} -- are modularly separated to form each stage. "epoch" registers are
 * used to handle incorrect branch prediction. Like a decoupled processor, memory operations are
 * stalled until getting the response.
 *)
Section ProcThreeStage.
  Variables addrSize iaddrSize instBytes dataBytes rfIdx: nat.

  Variables (fetch: AbsFetch addrSize iaddrSize instBytes dataBytes)
            (dec: AbsDec addrSize instBytes dataBytes rfIdx)
            (exec: AbsExec addrSize instBytes dataBytes rfIdx).

  Definition RqFromProc := MemTypes.RqFromProc dataBytes (Bit addrSize).
  Definition RsToProc := MemTypes.RsToProc dataBytes.

  Definition memReq := memReq addrSize dataBytes.
  Definition memRep := memRep dataBytes.

  (* Abstract d2eElt *)
  Variable (d2eElt: Kind).
  Variable (d2ePack:
              forall ty,
                Expr ty (SyntaxKind (Bit 2)) -> (* opTy *)
                Expr ty (SyntaxKind (Bit rfIdx)) -> (* dst *)
                Expr ty (SyntaxKind (Bit addrSize)) -> (* addr *)
                Expr ty (SyntaxKind (Array Bool dataBytes)) -> (* byteEn *)
                Expr ty (SyntaxKind (Data dataBytes)) -> (* val1 *)
                Expr ty (SyntaxKind (Data dataBytes)) -> (* val2 *)
                Expr ty (SyntaxKind (Data instBytes)) -> (* rawInst *)
                Expr ty (SyntaxKind (Pc addrSize)) -> (* curPc *)
                Expr ty (SyntaxKind (Pc addrSize)) -> (* nextPc *)
                Expr ty (SyntaxKind Bool) -> (* epoch *)
                Expr ty (SyntaxKind d2eElt)).
  Variables
    (d2eOpType: forall ty, fullType ty (SyntaxKind d2eElt) ->
                           Expr ty (SyntaxKind (Bit 2)))
    (d2eDst: forall ty, fullType ty (SyntaxKind d2eElt) ->
                        Expr ty (SyntaxKind (Bit rfIdx)))
    (d2eAddr: forall ty, fullType ty (SyntaxKind d2eElt) ->
                         Expr ty (SyntaxKind (Bit addrSize)))
    (d2eByteEn: forall ty, fullType ty (SyntaxKind d2eElt) ->
                           Expr ty (SyntaxKind (Array Bool dataBytes)))
    (d2eVal1 d2eVal2: forall ty, fullType ty (SyntaxKind d2eElt) ->
                                 Expr ty (SyntaxKind (Data dataBytes)))
    (d2eRawInst: forall ty, fullType ty (SyntaxKind d2eElt) ->
                            Expr ty (SyntaxKind (Data instBytes)))
    (d2eCurPc: forall ty, fullType ty (SyntaxKind d2eElt) ->
                          Expr ty (SyntaxKind (Pc addrSize)))
    (d2eNextPc: forall ty, fullType ty (SyntaxKind d2eElt) ->
                           Expr ty (SyntaxKind (Pc addrSize)))
    (d2eEpoch: forall ty, fullType ty (SyntaxKind d2eElt) ->
                          Expr ty (SyntaxKind Bool)).

  (* Abstract e2wElt *)
  Variable (e2wElt: Kind).
  Variable (e2wPack:
              forall ty,
                Expr ty (SyntaxKind d2eElt) -> (* decInst *)
                Expr ty (SyntaxKind (Data dataBytes)) -> (* execVal *)
                Expr ty (SyntaxKind e2wElt)).
  Variables
    (e2wDecInst: forall ty, fullType ty (SyntaxKind e2wElt) ->
                            Expr ty (SyntaxKind d2eElt))
    (e2wVal: forall ty, fullType ty (SyntaxKind e2wElt) ->
                        Expr ty (SyntaxKind (Data dataBytes))).

  Definition d2eFifoName := "d2e"%string.
  Definition d2eEnq := MethodSig (d2eFifoName -- "enq")(d2eElt) : Void.
  Definition d2eDeq := MethodSig (d2eFifoName -- "deq")() : d2eElt.

  (** For redirecting a correct pc: a previous pc is sent as well to train
   * the branch predictor. *)
  Definition W2DStr := STRUCT { "prevPc" :: Pc addrSize; "nextPc" :: Pc addrSize }.
  Definition w2dElt := Struct W2DStr.
  Definition w2dFifoName := "w2d"%string.
  Definition w2dEnq := MethodSig (w2dFifoName -- "enq")(w2dElt) : Void.
  Definition w2dDeq := MethodSig (w2dFifoName -- "deq")() : w2dElt.
  Definition w2dFull := MethodSig (w2dFifoName -- "isFull")() : Bool.

  Definition e2wFifoName := "e2w"%string.
  Definition e2wEnq := MethodSig (e2wFifoName -- "enq")(e2wElt) : Void.
  Definition e2wDeq := MethodSig (e2wFifoName -- "deq")() : e2wElt.

  Section RegFile.
    Variable rfInit: ConstT (Vector (Data dataBytes) rfIdx).

    Definition regFile := MODULE {
      Register "rf" : Vector (Data dataBytes) rfIdx <- rfInit

      with Method "getRf1" () : Vector (Data dataBytes) rfIdx :=
        Read rf <- "rf";
        Ret #rf

      with Method "getRf2" () : Vector (Data dataBytes) rfIdx :=
        Read rf <- "rf";
        Ret #rf

      with Method "setRf" (rf: Vector (Data dataBytes) rfIdx) : Void :=
        Write "rf" <- #rf;
        Retv
    }.

    Definition getRf1 := MethodSig "getRf1"() : Vector (Data dataBytes) rfIdx.
    Definition getRf2 := MethodSig "getRf2"() : Vector (Data dataBytes) rfIdx.
    Definition setRf := MethodSig "setRf"(Vector (Data dataBytes) rfIdx) : Void.

  End RegFile.

  Section Epoch.

    Definition epoch := MODULE {
      Register "eEpoch" : Bool <- false

      with Method "getEpoch" () : Bool :=
        Read epoch <- "eEpoch";
        Ret #epoch

      with Method "toggleEpoch" () : Void :=
        Read epoch <- "eEpoch";
        Write "eEpoch" <- !#epoch;
        Retv
    }.

    Definition getEpoch := MethodSig "getEpoch"() : Bool.
    Definition toggleEpoch := MethodSig "toggleEpoch"() : Void.

  End Epoch.

  Section ScoreBoard.

    Definition scoreBoard := MODULE {
      Register "sbFlags" : Vector Bool rfIdx <- Default

      with Method "sbSearch1_Ld" (sidx: Bit rfIdx) : Bool :=
        Read flags <- "sbFlags";
        Ret #flags@[#sidx]

      with Method "sbSearch2_Ld" (sidx: Bit rfIdx) : Bool :=
        Read flags <- "sbFlags";
        Ret #flags@[#sidx]

      with Method "sbSearch1_St" (sidx: Bit rfIdx) : Bool :=
        Read flags <- "sbFlags";
        Ret #flags@[#sidx]

      with Method "sbSearch2_St" (sidx: Bit rfIdx) : Bool :=
        Read flags <- "sbFlags";
        Ret #flags@[#sidx]

      with Method "sbSearch1_Nm" (sidx: Bit rfIdx) : Bool :=
        Read flags <- "sbFlags";
        Ret #flags@[#sidx]

      with Method "sbSearch2_Nm" (sidx: Bit rfIdx) : Bool :=
        Read flags <- "sbFlags";
        Ret #flags@[#sidx]

      with Method "sbSearch3_Nm" (sidx: Bit rfIdx) : Bool :=
        Read flags <- "sbFlags";
        Ret #flags@[#sidx]

      with Method "sbInsert" (nidx: Bit rfIdx) : Void :=
        Read flags <- "sbFlags";
        Write "sbFlags" <- #flags@[#nidx <- $$true];
        Retv

      with Method "sbRemove" (nidx: Bit rfIdx) : Void :=
        Read flags <- "sbFlags";
        Write "sbFlags" <- #flags@[#nidx <- $$false];
        Retv
    }.

    Definition sbSearch1_Ld := MethodSig "sbSearch1_Ld"(Bit rfIdx) : Bool.
    Definition sbSearch2_Ld := MethodSig "sbSearch2_Ld"(Bit rfIdx) : Bool.
    Definition sbSearch1_St := MethodSig "sbSearch1_St"(Bit rfIdx) : Bool.
    Definition sbSearch2_St := MethodSig "sbSearch2_St"(Bit rfIdx) : Bool.
    Definition sbSearch1_Nm := MethodSig "sbSearch1_Nm"(Bit rfIdx) : Bool.
    Definition sbSearch2_Nm := MethodSig "sbSearch2_Nm"(Bit rfIdx) : Bool.
    Definition sbSearch3_Nm := MethodSig "sbSearch3_Nm"(Bit rfIdx) : Bool.
    Definition sbInsert := MethodSig "sbInsert"(Bit rfIdx) : Void.
    Definition sbRemove := MethodSig "sbRemove"(Bit rfIdx) : Void.

  End ScoreBoard.

  Section FetchDecode.
    Variable (pcInit : ConstT (Pc addrSize)).

    Definition fetchDecode := MODULE {
      Register "pc" : Pc addrSize <- pcInit
      with Register "pinit" : Bool <- Default
      with Register "pinitRq" : Bool <- Default
      with Register "pinitRqOfs" : Bit iaddrSize <- Default
      with Register "pinitRsOfs" : Bit iaddrSize <- Default
      with Register "pgm" : Vector (Data instBytes) iaddrSize <- Default
      with Register "fEpoch" : Bool <- false

      (** Phase 1: initialize the program [pinit == false] *)

      with Rule "pgmInitRq" :=
        Read pinit <- "pinit";
        Assert !#pinit;
        Read pinitRq <- "pinitRq";
        Assert !#pinitRq;
        Read pinitRqOfs : Bit iaddrSize <- "pinitRqOfs";
        Assert ((UniBit (Inv _) #pinitRqOfs) != $0);

        Call memReq(STRUCT { "addr" ::= toAddr _ pinitRqOfs;
                             "op" ::= $$false;
                             "byteEn" ::= $$Default;
                             "data" ::= $$Default });
        Write "pinitRqOfs" <- #pinitRqOfs + $1;
        Retv

      with Rule "pgmInitRqEnd" :=
        Read pinit <- "pinit";
        Assert !#pinit;
        Read pinitRq <- "pinitRq";
        Assert !#pinitRq;
        Read pinitRqOfs : Bit iaddrSize <- "pinitRqOfs";
        Assert ((UniBit (Inv _) #pinitRqOfs) == $0);
        Call memReq(STRUCT { "addr" ::= toAddr _ pinitRqOfs;
                             "op" ::= $$false;
                             "byteEn" ::= $$Default;
                             "data" ::= $$Default });
        Write "pinitRq" <- $$true;
        Write "pinitRqOfs" : Bit iaddrSize <- $0;
        Retv

      with Rule "pgmInitRs" :=
        Read pinit <- "pinit";
        Assert !#pinit;
        Read pinitRsOfs : Bit iaddrSize <- "pinitRsOfs";
        Assert ((UniBit (Inv _) #pinitRsOfs) != $0);

        Call ldData <- memRep();
        LET ldVal <- #ldData!RsToProc@."data";
        LET inst <- alignInst _ ldVal;
        Read pgm <- "pgm";
        Write "pgm" <- #pgm@[#pinitRsOfs <- #inst];
        Write "pinitRsOfs" <- #pinitRsOfs + $1;
        Retv

      with Rule "pgmInitRsEnd" :=
        Read pinit <- "pinit";
        Assert !#pinit;
        Read pinitRsOfs : Bit iaddrSize <- "pinitRsOfs";
        Assert ((UniBit (Inv _) #pinitRsOfs) == $0);

        Call ldData <- memRep();
        LET ldVal <- #ldData!RsToProc@."data";
        LET inst <- alignInst _ ldVal;
        Read pgm <- "pgm";
        Write "pgm" <- #pgm@[#pinitRsOfs <- #inst];
        Write "pinit" <- !#pinit;
        Write "pinitRsOfs" : Bit iaddrSize <- $0;
        Retv

      (** Phase 2: fetch/decode the program [pinit == true] *)

      with Rule "modifyPc" :=
        Read pinit <- "pinit";
        Assert #pinit;
        Call correctPc <- w2dDeq();
        Write "pc" <- #correctPc!W2DStr@."nextPc";
        Read pEpoch <- "fEpoch";
        Write "fEpoch" <- !#pEpoch;
        Retv

      with Rule "instFetchLd" :=
        Read pinit <- "pinit";
        Call w2dFull <- w2dFull();
        Assert !#w2dFull;
        Read ppc : Pc addrSize <- "pc";
        Read pgm : Vector (Data instBytes) iaddrSize <- "pgm";
        Assert #pinit;
        LET rawInst <- #pgm@[toIAddr _ ppc];
        Call rf <- getRf1();

        Nondet npc : SyntaxKind (Pc addrSize);
        Read epoch <- "fEpoch";
        Write "pc" <- #npc;

        LET opType <- getOptype _ rawInst;
        Assert (#opType == $$opLd);

        LET srcIdx <- getLdSrc _ rawInst;
        LET dst <- getLdDst _ rawInst;
        Call stall1 <- sbSearch1_Ld(#srcIdx);
        Call stall2 <- sbSearch2_Ld(#dst);
        Assert !(#stall1 || #stall2);
        LET addr <- getLdAddr _ rawInst;
        LET srcVal <- #rf@[#srcIdx];
        LET laddr <- calcLdAddr _ addr srcVal;
        Call d2eEnq(d2ePack #opType #dst #laddr $$Default $$Default $$Default
                            #rawInst #ppc #npc #epoch);
        Call sbInsert(#dst);
        Retv

      with Rule "instFetchSt" :=
        Read pinit <- "pinit";
        Call w2dFull <- w2dFull();
        Assert !#w2dFull;
        Read ppc : Pc addrSize <- "pc";
        Read pgm : Vector (Data instBytes) iaddrSize <- "pgm";
        Assert #pinit;
        LET rawInst <- #pgm@[toIAddr _ ppc];
        Call rf <- getRf1();

        Nondet npc: SyntaxKind (Pc addrSize);
        Read epoch <- "fEpoch";
        Write "pc" <- #npc;

        LET opType <- getOptype _ rawInst;
        Assert (#opType == $$opSt);

        LET srcIdx <- getStSrc _ rawInst;
        LET vsrcIdx <- getStVSrc _ rawInst;
        Call stall1 <- sbSearch1_St(#srcIdx);
        Call stall2 <- sbSearch2_St(#vsrcIdx);
        Assert !(#stall1 || #stall2);

        LET addr <- getStAddr _ rawInst;
        LET srcVal <- #rf@[#srcIdx];
        LET stVal <- #rf@[#vsrcIdx];
        LET saddr <- calcStAddr _ addr srcVal;
        LET byteEn <- calcStByteEn _ rawInst;
        Call d2eEnq(d2ePack #opType $$Default #saddr #byteEn #stVal $$Default
                            #rawInst #ppc #npc #epoch);
        Retv

      with Rule "instFetchNm" :=
        Read pinit <- "pinit";
        Call w2dFull <- w2dFull();
        Assert !#w2dFull;
        Read ppc : Pc addrSize <- "pc";
        Read pgm : Vector (Data instBytes) iaddrSize <- "pgm";
        Assert #pinit;
        LET rawInst <- #pgm@[toIAddr _ ppc];
        Call rf <- getRf1();

        Nondet npc: SyntaxKind (Pc addrSize);
        Read epoch <- "fEpoch";
        Write "pc" <- #npc;

        LET opType <- getOptype _ rawInst;
        Assert (#opType == $$opNm);

        LET dst <- getDst _ rawInst;
        LET idx1 <- getSrc1 _ rawInst;
        LET idx2 <- getSrc2 _ rawInst;
        Call stall1 <- sbSearch1_Nm(#idx1);
        Call stall2 <- sbSearch2_Nm(#idx2);
        Call stall3 <- sbSearch3_Nm(#dst);
        Assert !(#stall1 || #stall2 || #stall3);

        LET val1 <- #rf@[#idx1];
        LET val2 <- #rf@[#idx2];

        Call d2eEnq(d2ePack #opType #dst $$Default $$Default #val1 #val2
                            #rawInst #ppc #npc #epoch);
        Call sbInsert(#dst);
        Retv
    }.

  End FetchDecode.

  Section Execute.

    Definition executer := MODULE {
      Rule "execNm" :=
        Call rf <- getRf2();
        Call d2e <- d2eDeq();
        LET ppc <- d2eCurPc _ d2e;
        Assert d2eOpType _ d2e == $$opNm;

        LET rawInst <- d2eRawInst _ d2e;
        LET val1 <- d2eVal1 _ d2e;
        LET val2 <- d2eVal2 _ d2e;
        LET execVal <- doExec _ val1 val2 ppc rawInst;
        Call e2wEnq (e2wPack #d2e #execVal);
        Retv

      with Rule "execBypass" :=
        Call rf <- getRf2();
        Call d2e <- d2eDeq();
        Assert d2eOpType _ d2e != $$opNm;
        Call e2wEnq (e2wPack #d2e $$Default);
        Retv
    }.

  End Execute.

  Section WriteBack.

    Definition commitPc {ty} ppc npcp st rawInst :=
      (Write "lastPc" <- #ppc;
       LET npc <- getNextPc ty st ppc rawInst;
       If (#npc != #npcp)
       then
         Call toggleEpoch();
         Call w2dEnq(STRUCT { "prevPc" ::= #ppc;
                              "nextPc" ::= #npc });
         Retv
       else
         Retv
        as _;
         Retv)%kami_action.

    Definition wb := MODULE {
      Register "stall" : Bool <- false
      with Register "stalled" : d2eElt <- Default
      with Register "lastPc" : Pc addrSize <- Default

      with Rule "wrongEpoch" :=
        Read stall <- "stall";
        Assert !#stall;
        Call e2w <- e2wDeq();
        LET d2e <- e2wDecInst _ e2w;
        LET fEpoch <- d2eEpoch _ d2e;
        Call eEpoch <- getEpoch();
        Assert (#fEpoch != #eEpoch);

        If (d2eOpType _ d2e == $$opLd || d2eOpType _ d2e == $$opNm)
        then
          LET dst <- d2eDst _ d2e;
          Call sbRemove(#dst);
          Retv
        else
          Retv
        as _;
        Retv

      with Rule "reqLd" :=
        Read stall <- "stall";
        Assert !#stall;
        Call e2w <- e2wDeq();
        LET d2e <- e2wDecInst _ e2w;

        LET fEpoch <- d2eEpoch _ d2e;
        Call eEpoch <- getEpoch();
        Assert (#fEpoch == #eEpoch);

        Assert d2eOpType _ d2e == $$opLd;
        LET laddr <- d2eAddr _ d2e;
        Call memReq(STRUCT { "addr" ::= #laddr;
                             "op" ::= $$false;
                             "byteEn" ::= $$Default;
                             "data" ::= $$Default });
        Write "stall" <- $$true;
        Write "stalled" <- #d2e;
        Retv

      with Rule "reqSt" :=
        Read stall <- "stall";
        Assert !#stall;
        Call e2w <- e2wDeq();
        LET d2e <- e2wDecInst _ e2w;

        LET fEpoch <- d2eEpoch _ d2e;
        Call eEpoch <- getEpoch();
        Assert (#fEpoch == #eEpoch);

        Assert d2eOpType _ d2e == $$opSt;
        LET saddr <- d2eAddr _ d2e;
        LET byteEn <- d2eByteEn _ d2e;
        Call memReq(STRUCT { "addr" ::= #saddr;
                             "op" ::= $$true;
                             "byteEn" ::= #byteEn;
                             "data" ::= d2eVal1 _ d2e });
        Write "stall" <- $$true;
        Write "stalled" <- #d2e;
        Retv

      with Rule "repLd" :=
        Read stall <- "stall";
        Assert #stall;
        Call val <- memRep();
        Call rf <- getRf2();
        Read stalled : d2eElt <- "stalled";
        Assert d2eOpType _ stalled == $$opLd;
        LET dst <- d2eDst _ stalled;
        Assert (#dst != $0);

        LET rawInst <- d2eRawInst _ stalled;
        LET laddr <- d2eAddr _ stalled;
        LET ldValWord <- #val!RsToProc@."data";
        LET ldType <- getLdType _ rawInst;
        LET ldVal <- calcLdVal _ laddr ldValWord ldType;
        Call setRf (#rf@[#dst <- #ldVal]);

        Call sbRemove(#dst);
        Write "stall" <- $$false;
        LET ppc <- d2eCurPc _ stalled;
        LET npcp <- d2eNextPc _ stalled;
        LET rawInst <- d2eRawInst _ stalled;
        commitPc ppc npcp rf rawInst

      with Rule "repLdZ" :=
        Read stall <- "stall";
        Assert #stall;
        Call val <- memRep();
        Call rf <- getRf2();
        Read stalled : d2eElt <- "stalled";
        Assert d2eOpType _ stalled == $$opLd;
        LET dst <- d2eDst _ stalled;
        Assert (#dst == $0);
        Call sbRemove(#dst);
        Write "stall" <- $$false;
        LET ppc <- d2eCurPc _ stalled;
        LET npcp <- d2eNextPc _ stalled;
        LET rawInst <- d2eRawInst _ stalled;
        commitPc ppc npcp rf rawInst

      with Rule "repSt" :=
        Read stall <- "stall";
        Assert #stall;
        Call val <- memRep();
        Call rf <- getRf2();
        Read stalled : d2eElt <- "stalled";
        Assert d2eOpType _ stalled == $$opSt;
        Write "stall" <- $$false;
        LET ppc <- d2eCurPc _ stalled;
        LET npcp <- d2eNextPc _ stalled;
        LET rawInst <- d2eRawInst _ stalled;
        commitPc ppc npcp rf rawInst

      with Rule "wbNm" :=
        Read stall <- "stall";
        Assert !#stall;
        Call rf <- getRf2();
        Call e2w <- e2wDeq();
        LET d2e <- e2wDecInst _ e2w;

        LET fEpoch <- d2eEpoch _ d2e;
        Call eEpoch <- getEpoch();
        Assert (#fEpoch == #eEpoch);

        Assert d2eOpType _ d2e == $$opNm;
        LET dst <- d2eDst _ d2e;
        Assert (#dst != $0);
        LET val <- e2wVal _ e2w;
        Call setRf(#rf@[#dst <- #val]);
        Call sbRemove(#dst);
        LET ppc <- d2eCurPc _ d2e;
        LET npcp <- d2eNextPc _ d2e;
        LET rawInst <- d2eRawInst _ d2e;
        commitPc ppc npcp rf rawInst

      with Rule "wbNmZ" :=
        Read stall <- "stall";
        Assert !#stall;
        Call rf <- getRf2();
        Call e2w <- e2wDeq();
        LET d2e <- e2wDecInst _ e2w;

        LET fEpoch <- d2eEpoch _ d2e;
        Call eEpoch <- getEpoch();
        Assert (#fEpoch == #eEpoch);

        Assert d2eOpType _ d2e == $$opNm;
        LET dst <- d2eDst _ d2e;
        Assert (#dst == $0);
        Call sbRemove(#dst);
        LET ppc <- d2eCurPc _ d2e;
        LET npcp <- d2eNextPc _ d2e;
        LET rawInst <- d2eRawInst _ d2e;
        commitPc ppc npcp rf rawInst
    }.

  End WriteBack.

  Definition procThreeStage (init: ProcInit addrSize dataBytes rfIdx) :=
    ((fetchDecode (pcInit init))
       ++ regFile (rfInit init)
       ++ scoreBoard
       ++ PrimFifo.fifo PrimFifo.primPipelineFifoName d2eFifoName d2eElt
       ++ PrimFifo.fifoF PrimFifo.primBypassFifoName w2dFifoName w2dElt
       ++ executer
       ++ epoch
       ++ PrimFifo.fifo PrimFifo.primPipelineFifoName e2wFifoName e2wElt
       ++ wb)%kami.

End ProcThreeStage.

#[global] Hint Unfold regFile scoreBoard fetchDecode executer epoch wb procThreeStage : ModuleDefs.
#[global] Hint Unfold RqFromProc RsToProc memReq memRep
     d2eFifoName d2eEnq d2eDeq
     W2DStr w2dElt w2dFifoName w2dEnq w2dDeq w2dFull
     getRf1 getRf2 setRf getEpoch toggleEpoch
     e2wFifoName e2wEnq e2wDeq
     sbSearch1_Ld sbSearch2_Ld sbSearch1_St sbSearch2_St
     sbSearch1_Nm sbSearch2_Nm sbSearch3_Nm
     sbInsert sbRemove
     commitPc : MethDefs.

Section ProcThreeStageM.
  Variables addrSize iaddrSize instBytes dataBytes rfIdx: nat.

  Variables (fetch: AbsFetch addrSize iaddrSize instBytes dataBytes)
            (dec: AbsDec addrSize instBytes dataBytes rfIdx)
            (exec: AbsExec addrSize instBytes dataBytes rfIdx).

  Variable (d2eElt: Kind).
  Variable (d2ePack:
              forall ty,
                Expr ty (SyntaxKind (Bit 2)) -> (* opTy *)
                Expr ty (SyntaxKind (Bit rfIdx)) -> (* dst *)
                Expr ty (SyntaxKind (Bit addrSize)) -> (* addr *)
                Expr ty (SyntaxKind (Array Bool dataBytes)) -> (* byteEn *)
                Expr ty (SyntaxKind (Data dataBytes)) -> (* val1 *)
                Expr ty (SyntaxKind (Data dataBytes)) -> (* val2 *)
                Expr ty (SyntaxKind (Data instBytes)) -> (* rawInst *)
                Expr ty (SyntaxKind (Pc addrSize)) -> (* curPc *)
                Expr ty (SyntaxKind (Pc addrSize)) -> (* nextPc *)
                Expr ty (SyntaxKind Bool) -> (* epoch *)
                Expr ty (SyntaxKind d2eElt)).
  Variables
    (d2eOpType: forall ty, fullType ty (SyntaxKind d2eElt) ->
                           Expr ty (SyntaxKind (Bit 2)))
    (d2eDst: forall ty, fullType ty (SyntaxKind d2eElt) ->
                        Expr ty (SyntaxKind (Bit rfIdx)))
    (d2eAddr: forall ty, fullType ty (SyntaxKind d2eElt) ->
                         Expr ty (SyntaxKind (Bit addrSize)))
    (d2eByteEn: forall ty, fullType ty (SyntaxKind d2eElt) ->
                           Expr ty (SyntaxKind (Array Bool dataBytes)))
    (d2eVal1 d2eVal2: forall ty, fullType ty (SyntaxKind d2eElt) ->
                                 Expr ty (SyntaxKind (Data dataBytes)))
    (d2eRawInst: forall ty, fullType ty (SyntaxKind d2eElt) ->
                            Expr ty (SyntaxKind (Data instBytes)))
    (d2eCurPc: forall ty, fullType ty (SyntaxKind d2eElt) ->
                          Expr ty (SyntaxKind (Pc addrSize)))
    (d2eNextPc: forall ty, fullType ty (SyntaxKind d2eElt) ->
                           Expr ty (SyntaxKind (Pc addrSize)))
    (d2eEpoch: forall ty, fullType ty (SyntaxKind d2eElt) ->
                          Expr ty (SyntaxKind Bool)).

  Variable (e2wElt: Kind).
  Variable (e2wPack:
              forall ty,
                Expr ty (SyntaxKind d2eElt) -> (* decInst *)
                Expr ty (SyntaxKind (Data dataBytes)) -> (* execVal *)
                Expr ty (SyntaxKind e2wElt)).
  Variables
    (e2wDecInst: forall ty, fullType ty (SyntaxKind e2wElt) ->
                            Expr ty (SyntaxKind d2eElt))
    (e2wVal: forall ty, fullType ty (SyntaxKind e2wElt) ->
                        Expr ty (SyntaxKind (Data dataBytes))).

  Definition p3st init :=
    procThreeStage fetch dec exec
                   d2ePack d2eOpType d2eDst d2eAddr d2eByteEn d2eVal1 d2eVal2
                   d2eRawInst d2eCurPc d2eNextPc d2eEpoch
                   e2wPack e2wDecInst e2wVal
                   init.

End ProcThreeStageM.

#[global] Hint Unfold p3st : ModuleDefs.

Section Facts.
  Variable inName outName: string.
  Variables addrSize iaddrSize instBytes dataBytes rfIdx: nat.

  Variables (fetch: AbsFetch addrSize iaddrSize instBytes dataBytes)
            (dec: AbsDec addrSize instBytes dataBytes rfIdx)
            (exec: AbsExec addrSize instBytes dataBytes rfIdx).

  Variable (d2eElt: Kind).
  Variable (d2ePack:
              forall ty,
                Expr ty (SyntaxKind (Bit 2)) -> (* opTy *)
                Expr ty (SyntaxKind (Bit rfIdx)) -> (* dst *)
                Expr ty (SyntaxKind (Bit addrSize)) -> (* addr *)
                Expr ty (SyntaxKind (Array Bool dataBytes)) -> (* byteEn *)
                Expr ty (SyntaxKind (Data dataBytes)) -> (* val1 *)
                Expr ty (SyntaxKind (Data dataBytes)) -> (* val2 *)
                Expr ty (SyntaxKind (Data instBytes)) -> (* rawInst *)
                Expr ty (SyntaxKind (Pc addrSize)) -> (* curPc *)
                Expr ty (SyntaxKind (Pc addrSize)) -> (* nextPc *)
                Expr ty (SyntaxKind Bool) -> (* epoch *)
                Expr ty (SyntaxKind d2eElt)).
  Variables
    (d2eOpType: forall ty, fullType ty (SyntaxKind d2eElt) ->
                           Expr ty (SyntaxKind (Bit 2)))
    (d2eDst: forall ty, fullType ty (SyntaxKind d2eElt) ->
                        Expr ty (SyntaxKind (Bit rfIdx)))
    (d2eAddr: forall ty, fullType ty (SyntaxKind d2eElt) ->
                         Expr ty (SyntaxKind (Bit addrSize)))
    (d2eByteEn: forall ty, fullType ty (SyntaxKind d2eElt) ->
                           Expr ty (SyntaxKind (Array Bool dataBytes)))
    (d2eVal1 d2eVal2: forall ty, fullType ty (SyntaxKind d2eElt) ->
                                 Expr ty (SyntaxKind (Data dataBytes)))
    (d2eRawInst: forall ty, fullType ty (SyntaxKind d2eElt) ->
                            Expr ty (SyntaxKind (Data instBytes)))
    (d2eCurPc: forall ty, fullType ty (SyntaxKind d2eElt) ->
                          Expr ty (SyntaxKind (Pc addrSize)))
    (d2eNextPc: forall ty, fullType ty (SyntaxKind d2eElt) ->
                           Expr ty (SyntaxKind (Pc addrSize)))
    (d2eEpoch: forall ty, fullType ty (SyntaxKind d2eElt) ->
                          Expr ty (SyntaxKind Bool)).

  Variable (e2wElt: Kind).
  Variable (e2wPack:
              forall ty,
                Expr ty (SyntaxKind d2eElt) -> (* decInst *)
                Expr ty (SyntaxKind (Data dataBytes)) -> (* execVal *)
                Expr ty (SyntaxKind e2wElt)).
  Variables
    (e2wDecInst: forall ty, fullType ty (SyntaxKind e2wElt) ->
                            Expr ty (SyntaxKind d2eElt))
    (e2wDst: forall ty, fullType ty (SyntaxKind e2wElt) ->
                        Expr ty (SyntaxKind (Bit rfIdx)))
    (e2wVal: forall ty, fullType ty (SyntaxKind e2wElt) ->
                        Expr ty (SyntaxKind (Data dataBytes))).

  Lemma regFile_ModEquiv:
    forall init, ModPhoasWf (@regFile dataBytes rfIdx init).
  Proof. kequiv. Qed.
  #[local] Hint Resolve regFile_ModEquiv.

  Lemma scoreBoard_ModEquiv:
    ModPhoasWf (scoreBoard rfIdx).
  Proof. kequiv. Qed.
  #[local] Hint Resolve scoreBoard_ModEquiv.

  Lemma fetchDecode_ModEquiv:
    forall pcInit,
      ModPhoasWf (fetchDecode fetch dec d2ePack pcInit).
  Proof.
    kequiv.
  Qed.
  #[local] Hint Resolve fetchDecode_ModEquiv.

  Lemma executer_ModEquiv:
    ModPhoasWf (executer exec d2eOpType d2eVal1 d2eVal2 d2eRawInst d2eCurPc e2wPack).
  Proof.
    kequiv.
  Qed.
  #[local] Hint Resolve executer_ModEquiv.

  Lemma epoch_ModEquiv:
    ModPhoasWf epoch.
  Proof. kequiv. Qed.
  #[local] Hint Resolve epoch_ModEquiv.

  Lemma wb_ModEquiv:
    ModPhoasWf (wb dec exec
                   d2eOpType d2eDst d2eAddr d2eByteEn d2eVal1
                   d2eRawInst d2eCurPc d2eNextPc d2eEpoch
                   e2wDecInst e2wVal).
  Proof.
    kequiv.
  Qed.
  #[local] Hint Resolve wb_ModEquiv.

  Lemma procThreeStage_ModEquiv:
    forall init,
      ModPhoasWf (p3st fetch dec exec
                       d2ePack d2eOpType d2eDst d2eAddr d2eByteEn d2eVal1 d2eVal2
                       d2eRawInst d2eCurPc d2eNextPc d2eEpoch
                       e2wPack e2wDecInst e2wVal init).
  Proof.
    kequiv.
  Qed.

End Facts.

#[global] Hint Resolve regFile_ModEquiv
     scoreBoard_ModEquiv
     fetchDecode_ModEquiv
     executer_ModEquiv
     epoch_ModEquiv
     wb_ModEquiv
     procThreeStage_ModEquiv.


From Paco Require Import paco.

From CTree Require Import
	   CTree Eq Interp.Internalize Interp.FoldCTree.

(* Universe issue, TO FIX *)
Unset Universe Checking.
Unset Auto Template Polymorphism.

From ITree Require Import
	   ITree Eq Interp InterpFacts.

From Coq Require Import
	   Morphisms Program.
Open Scope ctree.

Set Implicit Arguments.
Set Contextual Implicit.

Definition h_embed {E C} : E ~> ctree E C :=
  fun _ e => CTree.trigger e.
Definition embed' {E} : itree E ~> ctree E (B01) := interp h_embed.
Definition embed {E C} : itree (C +' E) ~> ctree E (B01 +' C) :=
  fun _ t => internalize (embed' t).

Notation "t '-' l '→' u" := (trans l t u)
                              (at level 50, only printing,
                                format "t  '-' l '→'  u").

Notation "t '-' l '→' u" := (transR l t u)
                              (at level 50, only printing,
                                format "t  '-' l '→'  u").

#[local] Notation iobserve  := observe.
#[local] Notation _iobserve := _observe.
#[local] Notation cobserve  := CTreeDefinitions.observe.
#[local] Notation _cobserve := CTreeDefinitions._observe.
#[local] Notation iRet x    := (Ret x).
#[local] Notation iVis e k  := (Vis e k).
#[local] Notation iTau t    := (Tau t).
#[local] Notation cRet x    := (CTreeDefinitions.Ret x).
#[local] Notation cGuard t   := (CTreeDefinitions.Guard t).
#[local] Notation cVis e k  := (CTreeDefinitions.Vis e k).

(** Unfolding of [interp]. *)
Definition _interp {E F C R} `{B1 -< C} (f : E ~> ctree F C) (ot : itreeF E R _)
  : ctree F C R :=
  match ot with
  | RetF r => CTreeDefinitions.Ret r
  | TauF t => cGuard (interp f t)
  | VisF e k => CTree.bind (f _ e) (fun x => cGuard (interp f (k x)))
  end.

Lemma unfold_interp_ctree {E F C X} `{B1 -< C} (h: E ~> ctree F C) (t : itree E X):
  (interp h t ≅ _interp h (iobserve t))%ctree.
Proof.
  revert t.
  coinduction R CIH.
  intros; cbn*.
  Opaque CTree.bind.
  unfold cobserve; cbn.
  destruct (iobserve t) eqn:ot; try now cbn; auto.
  match goal with
    |- equb _ _ (_cobserve ?t) (_cobserve ?u) =>
      fold (cobserve t);
      fold (cobserve u)
  end.
  Transparent CTree.bind.
  cbn.
  rewrite Equ.bind_map.
  apply (fbt_bt (@bind_ctx_equ_t F _ X0 X0 X X eq eq) R), in_bind_ctx.
  reflexivity.
  intros ? ? <-.
  constructor; intros ?.
  reflexivity.
Qed.

#[global] Instance embed_eq {E C X}:
	Proper (eq_itree eq ==> equ eq) (@embed E C X).
Proof.
	unfold Proper, respectful.
	coinduction r CIH.
	intros t u bisim. unfold embed, embed', internalize.
  rewrite 2 unfold_interp_ctree.
  rewrite 2 FoldCTree.unfold_interp.
	punfold bisim.
	inv bisim; pclearbot; try easy.
	- cbn*.
    constructor; intros ?.
    step.
    cbn*.
    constructor; intros ?.
    now apply CIH.
	- cbn.
    upto_bind_eq.
    constructor; intros ?.
    rewrite 2 FoldCTree.unfold_interp.
    cbn.
    step; cbn*.
    constructor; intros ?.
    step; cbn*.
    constructor; intros ?.
    apply CIH, REL.
Qed.

From Coq Require Import Datatypes.

(* This is actually not trivial.
   There are two ways to encode itrees' taus:
   - If we use tauI, then I believe we have eutt mapping to sbisim I believe.
   Proving so however is tricky: [eutt] has a weird behavior that consists of
   being allowed to either look at taus (tau/tau rule) or ignore them (asymmetric rules).
   In contrast, [sbisim] can only ignore [tauI]. In the Tau/Tau case, it's therefore quite
   unclear how the proof should proceed: fundamentally, the rule is useful in [eutt] if and
   only if the computations are both [spin] from now on --- in all other cases it can be
   replaced by two asymmetric rules.
   And as it turns out, if it is indeed [spin] against [spin], then [sbisim] relate [spinI]
   against itself as well.
   But how do we turn this into a proof?
   - If we use tauV, then [eutt] certainly does not map against sbisim --- actually, it maps
   against [equ] as well in this case. However, I think it should map against [wbisim], but
   that remains to be proved.

 *)

Notation embed_ t :=
  match iobserve t with
  | RetF r => CTreeDefinitions.Ret r
  | TauF t => cGuard (cGuard (embed t))
  | VisF (inl1 e) k =>
      match e,k with
      | c, k => brS c (fun x => cGuard (cGuard (cGuard (embed (k x)))))
      end
  | VisF (inr1 e) k => CTreeDefinitions.vis e (fun x => cGuard (cGuard (cGuard (embed (k x)))))
  end.

Lemma unfold_embed {E C X} (t : itree (C +' E) X) : (embed t ≅ embed_ t)%ctree.
Proof.
  unfold embed, embed', internalize at 1.
  rewrite unfold_interp_ctree, FoldCTree.unfold_interp.
  cbn.
  destruct (iobserve t) eqn:EQ; cbn; auto.
  - step; cbn.
    constructor; intros ?.
    step; cbn.
    reflexivity.
  - destruct e.
    + cbn.
      rewrite Equ.unfold_bind at 1.
      cbn.
      step; cbn; constructor; intros ?.
      rewrite Equ.bind_ret_l.
      step; cbn; constructor; intros ?.
      rewrite FoldCTree.unfold_interp; cbn.
      rewrite Equ.unfold_bind at 1.
      step; cbn; constructor; intros ?.
      rewrite Equ.bind_ret_l.
      step; cbn; constructor; intros ?.
      auto.
    + cbn.
      rewrite Equ.unfold_bind at 1.
      cbn.
      step; cbn; constructor; intros ?.
      rewrite Equ.bind_ret_l.
      step; cbn; constructor; intros ?.
      rewrite FoldCTree.unfold_interp; cbn.
      rewrite Equ.unfold_bind at 1.
      step; cbn; constructor; intros ?.
      rewrite Equ.bind_ret_l.
      step; cbn; constructor; intros ?.
      auto.
Qed.

Lemma trans_embed_inv E C X : forall (t1 : itree (C +' E) X) l t2',
    trans l (embed t1) t2' ->
    (exists r : X, (t2' ≅ stuckD)%ctree /\ l = val r)
    \/ exists t2, (t2' ~ @embed E C X t2)%ctree.
Proof.
  unfold trans.
  intros * TR.
  cbn in TR; red in TR.
  remember (embed t1) as et1.
  cut (
      ((et1 ≅ embed t1)%ctree \/ (et1 ≅ cGuard (embed t1))%ctree) ->
      (exists r : X, (t2' ≅ stuckD)%ctree /\ l = val r)
      \/ exists t2 : itree (C +' E) X, t2' ~ embed t2).

  intros H; eapply H; eauto; left; subst; auto.
  clear Heqet1.
  revert t1.
  dependent induction TR.
  - intros ? EQ.
    destruct EQ as [EQ | EQ].
    + rewrite (unfold_embed t1) in EQ.
      step in EQ.
      rewrite <- x in EQ.
      destruct (iobserve t1) eqn:EQ1; try now inv EQ.
      * dependent induction EQ.
        specialize (REL x0).
        specialize (IHTR _ t2' (k x0) eq_refl).
        edestruct IHTR; eauto.
      * destruct e.
        inv EQ.
        inv EQ.
    + step in EQ.
      rewrite <- x in EQ.
      clear x et1.
      dependent induction EQ.
      specialize (REL x0).
      specialize (IHTR _ t2' (k x0) eq_refl).
      edestruct IHTR; eauto.
  - intros * EQ.
    assert (t2' ≅ t)%ctree by (step; now rewrite x).
    setoid_rewrite H0.
    clear t2' x H0.
    setoid_rewrite <- H.
    clear t H.
    destruct EQ as [EQ | EQ].
    + rewrite (ctree_eta et1), <- x1 in EQ;
        clear et1 x1.
      rewrite unfold_embed in EQ.
      destruct (iobserve t1) eqn:EQ1; try now step in EQ; inv EQ.
      destruct e; [| step in EQ; inv EQ].
      step in EQ; dependent induction EQ.
      setoid_rewrite (REL x0).
      right.
      eexists; rewrite !sb_guard.
      reflexivity.
    + rewrite (ctree_eta et1), <- x1 in EQ;
        clear et1 x1.
      step in EQ; inv EQ.

  - intros * EQ.
    assert (t2' ≅ t)%ctree by (step; now rewrite x).
    setoid_rewrite H0.
    clear t2' x H0.
    setoid_rewrite <- H.
    clear t H.
    destruct EQ as [EQ | EQ].
    + rewrite (ctree_eta et1), <- x1 in EQ;
        clear et1 x1.
      rewrite unfold_embed in EQ.
      destruct (iobserve t1) eqn:EQ1; try now step in EQ; inv EQ.
      destruct e0.
      step in EQ; inv EQ.
      step in EQ; dependent induction EQ.
      setoid_rewrite (REL x0).
      right; eexists.
      rewrite !sb_guard.
      reflexivity.
    + rewrite (ctree_eta et1), <- x1 in EQ;
        clear et1 x1.
      step in EQ; inv EQ.
  - intros * EQ.
    assert (t2' ≅ br false branch0 k)%ctree by (step; now rewrite x).
    setoid_rewrite H.
    clear t2' x H.
    destruct EQ as [EQ | EQ].
    + rewrite (ctree_eta et1), <- x0 in EQ.
      clear et1 x0.
      rewrite unfold_embed in EQ.
      destruct (iobserve t1) eqn:EQ1; try now step in EQ; inv EQ.
      * dependent induction EQ.
        left; eexists; split; eauto.

        rewrite brD0_always_stuck; reflexivity.
      * destruct e; step in EQ; inv EQ.
    + step in EQ; rewrite <- x0 in EQ; inv EQ.
Qed.

(* TODO THIS IS REDUNDANT WITH THE DEF IN FOLDCTREE! *)
Inductive productive {E X} : itree E X -> Prop :=
| prod_ret {r t} (EQ: eq_itree eq t (Ret r)) : productive t
| prod_vis {Y} {e : E Y} {k t} (EQ: eq_itree eq t (Vis e k)) : productive t
| prod_tau {u t} (EQ: eq_itree eq t (Tau u)) (PROD : productive u) : productive t.

#[global] Instance eq_itree_productive {E X} : Proper (eq_itree eq ==> flip impl) (@productive E X).
Proof.
  intros t u EQ PR.
  revert t EQ.
  induction PR; intros.
  - eapply prod_ret.
    rewrite EQ0; eauto.
  - eapply prod_vis.
    rewrite EQ0; eauto.
  - eapply prod_tau.
    rewrite EQ0; eauto.
    apply IHPR.
    reflexivity.
Qed.

Lemma embed_trans_productive_aux E C X : forall l t (T u : ctree E (B01 +' C) X),
    trans l T u ->
    (equ eq T (embed t) \/ equ eq T (cGuard (embed t))) ->
    productive t.
Proof.
  intros * TR EQ.
  unfold trans in TR.
  cbn in TR; red in TR.
  CTreeDefinitions.genobs T oT.
  CTreeDefinitions.genobs u ou.
  revert T HeqoT u Heqou t EQ.
  induction TR; intros.
  - subst.
    destruct EQ as [EQ | EQ].
    + rewrite ctree_eta, <- HeqoT in EQ.
      rewrite itree_eta.
      rewrite unfold_embed in EQ.
      destruct (iobserve t0); try now step in EQ; inv EQ.
      * eapply prod_tau; [reflexivity|].
        eapply IHTR.
        reflexivity.
        reflexivity.
        step in EQ; dependent induction EQ.
        specialize (REL x).
        auto.
      * destruct e; step in EQ; inv EQ.
    + specialize (IHTR _ eq_refl _ eq_refl).
      rewrite ctree_eta, <- HeqoT in EQ.
      step in EQ; dependent induction EQ.
      specialize (REL x).
      apply IHTR.
      auto.
  - destruct EQ as [EQ | EQ].
    + rewrite itree_eta.
      rewrite ctree_eta, <- HeqoT in EQ.
      rewrite unfold_embed in EQ.
      destruct (iobserve t0); try now step in EQ; inv EQ.
      destruct e; eapply prod_vis; eauto.
    + rewrite itree_eta.
      rewrite ctree_eta, <- HeqoT in EQ.
      step in EQ; inv EQ.
  - destruct EQ as [EQ | EQ].
    + rewrite itree_eta.
      rewrite ctree_eta, <- HeqoT in EQ.
      rewrite unfold_embed in EQ.
      destruct (iobserve t0); try now step in EQ; inv EQ.
      destruct e0; eapply prod_vis; eauto.
    + rewrite itree_eta.
      rewrite ctree_eta, <- HeqoT in EQ.
      step in EQ; inv EQ.
  - destruct EQ as [EQ | EQ].
    + rewrite itree_eta.
      rewrite ctree_eta, <- HeqoT in EQ.
      rewrite unfold_embed in EQ.
      destruct (iobserve t); try now step in EQ; inv EQ.
      eapply prod_ret; eauto.
      eapply prod_vis; eauto.
    + rewrite itree_eta.
      rewrite ctree_eta, <- HeqoT in EQ.
      step in EQ; inv EQ.
Qed.

Lemma embed_trans_productive E C X : forall l t (u : ctree E (B01 +' C) X),
    trans l (embed t) u ->
    productive t.
Proof.
  intros * TR.
  eapply embed_trans_productive_aux; eauto.
Qed.

Lemma embed_eutt {E C X}:
  Proper (eutt eq ==> sbisim eq) (@embed E C X).
Proof.
  unfold Proper,respectful.
  coinduction ? CIH.
  symmetric using idtac.
  - intros * HR * EQ.
    apply HR; symmetry; assumption.
  - intros t u EUTT.
    cbn; intros * TR.
    pose proof embed_trans_productive TR as PROD.
    revert u TR EUTT.
    induction PROD.
    + intros.
      rewrite EQ in EUTT,TR.
      rewrite unfold_embed in TR; cbn in TR.
      pose proof trans_ret_inv TR as (EQ' & ->).
      punfold EUTT; cbn in EUTT; red in EUTT.
      remember (iobserve (iRet r)) as ot;
        remember (iobserve u) as ou.
      revert u Heqou.
      induction EUTT; subst; pclearbot; try now inv Heqot.
      * intros.
        inv Heqot.
        do 2 eexists; split; [|split].
        rewrite unfold_embed, <- Heqou.
        etrans.
        all: reflexivity.
      * intros.
        edestruct IHEUTT; try reflexivity.
        destruct H as (? & ? & ? & ->).
        do 2 eexists; split; [|split].
        rewrite unfold_embed, <- Heqou.
        apply trans_guard, trans_guard; eauto.
        assumption.
        reflexivity.
    + intros.
      rewrite EQ in EUTT,TR.
      rewrite unfold_embed in TR; cbn in TR.
      destruct e.
      * apply trans_brS_inv in TR; destruct TR as (? & EQ' & ->).
        punfold EUTT; cbn in EUTT; red in EUTT.
        remember (iobserve (iVis (inl1 c) k)) as ot;
          remember (iobserve u) as ou.
        revert u Heqou.
        induction EUTT; subst; try now inv Heqot.
        ** intros.
           dependent induction Heqot.
           do 2 eexists; split; [|split].
           rewrite unfold_embed, <- Heqou.
           etrans.
           rewrite EQ'.
           rewrite !sb_guard.
           apply CIH.
           pclearbot; apply REL.
           reflexivity.
        ** intros.
           edestruct IHEUTT; try reflexivity.
           destruct H as (? & ? & ? & ->).
           do 2 eexists; split; [|split].
           rewrite unfold_embed, <- Heqou.
           apply trans_guard, trans_guard.
           eauto.
           assumption.
           reflexivity.
      * apply trans_vis_inv in TR; destruct TR as (? & EQ' & ->).
        punfold EUTT; cbn in EUTT; red in EUTT.
        remember (iobserve (iVis (inr1 e) k)) as ot;
          remember (iobserve u) as ou.
        revert u Heqou.
        induction EUTT; subst; try now inv Heqot.
        ** intros.
           dependent induction Heqot.
           do 2 eexists; split; [|split].
           rewrite unfold_embed, <- Heqou.
           etrans.
           rewrite EQ'.
           rewrite !sb_guard.
           apply CIH.
           pclearbot; apply REL.
           reflexivity.
        ** intros.
           edestruct IHEUTT; try reflexivity.
           destruct H as (? & ? & ? & ->).
           do 2 eexists; split; [|split].
           rewrite unfold_embed, <- Heqou.
           apply trans_guard, trans_guard.
           eauto.
           assumption.
           reflexivity.
    + intros.
      rewrite EQ in EUTT,TR.
      rewrite unfold_embed in TR; cbn in TR.
      do 2 apply trans_guard_inv in TR.
      apply IHPROD.
      auto.
      rewrite tau_eutt in EUTT; auto.
Qed.

(* Other things to consider if time permitted:
   - partial inverse
   - embedded itrees are internally deterministic
 *)

(* Maybe simpler to just write a coinductive relation *)
(*Definition partial_inject {E X} : ctree E X -> itree E (option X) :=
	cofix _inject t :=
	 match CTreeDefinitions.observe t with
	| CTreeDefinitions.RetF x => Ret (Some x)
	| @BrF _ _ _ _ n t =>
		(match n as x return n = x -> itree E (option X) with
					 | O => fun _ => Ret None
					 | 1 => fun pf => eq_rect_r
	 													(fun n1 : nat => (Fin.t n1 -> ctree E X) -> itree E (option X))
	 													(fun t2 : Fin.t 1 -> ctree E X => Tau (_inject (t2 Fin.F1)))
	 													pf t
					 | _ => fun _ => Ret None
		 end eq_refl)
	| CTreeDefinitions.VisF e k => Vis e (fun x => _inject (k x))
	 end.

Definition option_rel {A B : Type} (R : A -> B -> Prop) : option A -> option B -> Prop :=
	fun x y => match x, y with
	|	Some x, Some y => R x y
	| _, _ => False
	end.

(* This is probably false: no reason for the embedding to succeed. *)
Lemma partial_inject_eq {E X} :
	Proper (equ eq ==> eq_itree (option_rel eq)) (@partial_inject E X).
Admitted.*)

Variant is_detF {E C X} `{B1 -< C} (is_det : ctree E C X -> Prop) : ctree E C X -> Prop :=
| Ret_det : forall x, is_detF is_det (CTreeDefinitions.Ret x)
| Vis_det : forall {Y} (e : E Y) k,
	(forall y, is_det (k y)) ->
	is_detF is_det (CTreeDefinitions.Vis e k)
| Tau_det : forall t,
	(is_det t) ->
	is_detF is_det (CTreeDefinitions.Guard t).

Definition is_det {E C X} `{B1 -< C} := paco1 (@is_detF E C X _) bot1.


Require Import Lia IndefiniteDescription Arith.
From hahn Require Import Hahn.
Require Import AuxRel.
Require Import Labels.
Require Import Events.
Require Import Execution.
Require Import View.

Set Implicit Arguments.

Section SCOHDeclarative.

Variable G: execution.

Definition scoh_consistent :=
  SCpL G  /\
  irreflexive ((rf G)⁻¹ ⨾ (co G ⨾ (co G))) /\
  ⟪ PORF : irreflexive (hb G) ⟫.

Lemma hb_irr (CONS : scoh_consistent) : irreflexive (hb G).
Proof using. apply CONS. Qed.

Lemma scoh_rmw_atomicity (WF: Wf G) (CONS : scoh_consistent) :
  rmw_atomicity G.
Proof using.
  unfold scoh_consistent, rmw_atomicity in *; desc.
  rewrite wf_rfE, wf_rfD; ins; unfolder in *; ins; desf.
  destruct (classic (x = y)) as [|NEQ]; desf.
  { edestruct (CONS y). apply ct_step.
    basic_solver. }
  eapply (wf_co_total WF) in NEQ; ins; desf; ins.
  { splits; ins; intro; desf; eauto 10. }
  { edestruct (CONS x). apply ct_ct.
    exists y; split; apply t_step; basic_solver. }
  unfolder. splits; auto.
  apply wf_rfl in H0; ins.
Qed.

Lemma scoh_rf_irr (CONS : scoh_consistent) : irreflexive (rf G).
Proof using. rewrite rf_in_hb. by apply hb_irr. Qed.

Lemma rf_w_in_co (WF: Wf G) (CONS : scoh_consistent) :
  (rf G) ⨾ ⦗is_w⦘ ⊆ (co G).
Proof using.
  unfolder. intros x y [RF WY].
  destruct (classic (x = y)) as [|NEQ]; subst.
  { exfalso. eapply scoh_rf_irr; eauto. }
  apply (wf_rfE WF) in RF. unfolder in RF. desf.
  apply (wf_rfD WF) in RF0. unfolder in RF0. desf.
  edestruct (wf_co_total WF) with (a:=x) (b:=y) as [|HH]; eauto.
  1,2: unfolder; splits; eauto.
  { symmetry. by apply (wf_rfl WF). }
  exfalso.
  cdes CONS. eapply CONS0.
  apply ct_ct. eexists. split; apply ct_step.
  all: basic_solver.
Qed.

(* TODO: move to more appropriate place or replace with co_ninit. *)
Lemma co_init_r (WF: Wf G)
      x y (CO : co G x y) (INITY : is_init y) :
  False.
Proof.
  apply co_ninit in CO; auto. unfolder in CO. desf.
Qed.

End SCOHDeclarative.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University
  Copyright 2018 Luxembourg University

  This file is part of Velisarios.

  Velisarios is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  Velisarios is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export PBFTexecute4.
Require Export PBFTsame_states.

Section PBFTagreement.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { pbft_context : PBFTcontext      }.
  Context { pbft_auth    : PBFTauth         }.
  Context { pbft_keys    : PBFTinitial_keys }.
  Context { pbft_hash    : PBFThash         }.
  Context { pbft_hash_axioms : PBFThash_axioms  }.

  Lemma agreement :
    forall (eo : EventOrdering) (e1 e2 : Event) v1 v2 ts c j1 j2 r1 r2 a1 a2 i1 i2,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> exists_at_most_f_faulty [e1,e2] F
      -> loc e1 = PBFTreplica i1
      -> loc e2 = PBFTreplica i2
      -> In (send_reply (mk_reply v1 ts c j1 r1 a1)) (output_system_on_event_ldata PBFTsys e1)
      -> In (send_reply (mk_reply v2 ts c j2 r2 a2)) (output_system_on_event_ldata PBFTsys e2)
      -> r1 = r2.
  Proof.
    introv sendbyz ckeys atmost eqloc1 eqloc2 out1 out2.

    applydup @output_system_on_event_ldata_implies_state_sm_on_event in out1 as h;
      [|introv; simpl in *; unfold PBFTsys, PBFTnstate; remember (loc e1); destruct n; ginv; eauto 3 with pbft; try apply replicas_never_stop].
    revert h; unfold PBFTnstate; rewrite eqloc1; introv h; exrepnd.

    applydup @output_system_on_event_ldata_implies_state_sm_on_event in out2 as z;
      [|introv; simpl in *; unfold PBFTsys, PBFTnstate; remember (loc e2); destruct n; ginv; eauto 3 with pbft; try apply replicas_never_stop].
    revert z; unfold PBFTnstate; rewrite eqloc2; introv z; exrepnd.

    pose proof (state_sm_before_event_some_between3 e1 e1 (PBFTreplicaSM i1) st) as q.
    repeat (autodimp q hyp); eauto 3 with eo; exrepnd.

    pose proof (state_sm_before_event_some_between3 e2 e2 (PBFTreplicaSM i2) st0) as w.
    repeat (autodimp w hyp); eauto 3 with eo; exrepnd.

    rename st into st1.
    rename st0 into st.
    rename s' into st2.
    rename s'0 into st0.

    eapply replies_from in out1; eauto.
    eapply replies_from in out2; eauto.
    exrepnd.

    subst.

    match goal with
    | [ H1 : committed_log _ _ = _, H2 : committed_log _ _ = _ |- _ ] =>
      rename H1 into com1; rename H2 into com2; dup com1 as com
    end.

    match goal with
    | [ H1 : find_first_reply _ _ _ = _, H2 : find_first_reply _ _ _ = _ |- _ ] =>
      rename H1 into ffr1; rename H2 into ffr2
    end.

    match goal with
    | [ H1 : find_last_reply_entry_corresponding_to_client _ _ = _,
             H2 : find_last_reply_entry_corresponding_to_client _ _ = _,
                  H3 : find_last_reply_entry_corresponding_to_client _ _ = _,
                       H4 : find_last_reply_entry_corresponding_to_client _ _ = _ |- _ ] =>
      rename H1 into fl1; rename H2 into fl2; rename H3 into fl3; rename H4 into fl4
    end.

    match goal with
    | [ H1 : reply2requests _ _ _ _ _ _ = _, H2 : reply2requests _ _ _ _ _ _ = _ |- _ ] =>
      rename H1 into r2rs1; rename H2 into r2rs2
    end.

    match goal with
    | [ H1 : request2info _ = _, H2 : request2info _ = _ |- _ ] =>
      rename H1 into r2i1; rename H2 into r2i2
    end.

    destruct (SeqNumDeq (next_to_execute st0) (next_to_execute st2)) as [d|d].

    {
      rewrite d in *.

      eapply PBFT_A_1_11_before in com;
        try exact com2; try (exact q0); try (exact w0); auto; eauto 3 with pbft eo;[].
      apply eq_digests_implies_eq_requests in com; subst.

      rewrite ffr1 in ffr2; ginv.

      pose proof (next_to_execute_from_before eo e1 e2 j1 j2 st2 st0) as u.
      repeat (autodimp u hyp);[].
      repnd.
      rewrite u0 in *.
      rewrite u in *.

      pose proof (same_states_if_same_next_to_execute eo e1 e2 j1 j2 st1 st) as v.
      repeat (autodimp v hyp); try (complete (allrw; tcsp));[].
      repnd.
      try rewrite v0 in *.
      try rewrite v in *.

      eapply matching_reply2requests_implies in r2rs1; try (exact r2rs2).
      repnd; subst.

      rewrite fl1 in *; ginv.
      rewrite fl2 in *; ginv.

      rewrite r2i1 in *; ginv.
      smash_pbft.
    }

    assert (seqnum2nat (next_to_execute st0) <> seqnum2nat (next_to_execute st2)) as d'.
    { intro xx; destruct d.
      destruct (next_to_execute st0), (next_to_execute st2); simpl in *; tcsp. }

    apply not_eq in d'; repndors;[|].

    {
      assert (next_to_execute st <= next_to_execute st2) as lenext by (allrw; simpl; omega).
      applydup next_to_execute_is_greater_than_one in z0; auto;[].

      rewrite <- ite_first_state_sm_on_event_as_before in q0.
      unfold ite_first in *.
      destruct (dec_isFirst e1) as [d1|d1]; ginv; subst; simpl in *;[].
      pose proof (last_reply_state_increases
                    eo (local_pred e1) j1 st2
                    (next_to_execute st)) as u.
      repeat (autodimp u hyp); autorewrite with eo; auto;
        try omega; eauto 3 with pbft eo;[].
      exrepnd.

      pose proof (same_states_if_same_next_to_execute eo e' e2 j j2 st' st) as v.
      repeat (autodimp v hyp); try (complete (allrw; auto)); eauto 4 with pbft eo;[].
      repnd.
      rewrite v in u0.

      applydup u0 in fl4.
      exrepnd.

      match goal with
      | [ H : context[reply2requests j1] |- _ ] => rename H into rep2req
      end.
      applydup reply2requests_implies_last_reply_state_extends in rep2req as ext.
      applydup ext in fl0.
      exrepnd.
      rewrite fl8 in *; ginv.

      assert (ts <= lre_timestamp e4) as lets by omega.

      autodimp fl5 hyp;[apply eq_nats_implies_eq_timestamps; omega|].
      autodimp fl9 hyp;[apply eq_nats_implies_eq_timestamps; omega|].
      autodimp out0 hyp;[apply eq_nats_implies_eq_timestamps; omega|].

      assert (lre_reply e4 = Some r1) as eqr1 by (pbft_dest_all x; try omega).

      assert (Some r1 = Some r2) as eqrs by congruence.
      ginv.
    }

    {
      assert (next_to_execute st1 <= next_to_execute st0) as lenext by (allrw; simpl; omega).
      applydup next_to_execute_is_greater_than_one in h0; auto;[].

      rewrite <- ite_first_state_sm_on_event_as_before in w0.
      unfold ite_first in *.
      destruct (dec_isFirst e2) as [d1|d1]; ginv; subst; simpl in *;[].
      pose proof (last_reply_state_increases
                    eo (local_pred e2) j2 st0
                    (next_to_execute st1)) as u.
      repeat (autodimp u hyp); autorewrite with eo; auto; try omega; eauto 3 with pbft eo;[].
      exrepnd.

      pose proof (same_states_if_same_next_to_execute eo e' e1 j j1 st' st1) as v.
      repeat (autodimp v hyp); try (complete (allrw; auto)); eauto 5 with pbft eo;[].
      repnd.
      rewrite v in u0.

      applydup u0 in fl2.
      exrepnd.

      match goal with
      | [ H : context[reply2requests j2] |- _ ] => rename H into rep2req
      end.
      applydup reply2requests_implies_last_reply_state_extends in rep2req as ext.
      applydup ext in fl0.
      exrepnd.
      rewrite fl8 in *; ginv.

      assert (ts <= lre_timestamp e0) as lets by omega.

      autodimp fl5 hyp;[apply eq_nats_implies_eq_timestamps; omega|].
      autodimp fl9 hyp;[apply eq_nats_implies_eq_timestamps; omega|].
      autodimp out14 hyp;[apply eq_nats_implies_eq_timestamps; omega|].

      assert (lre_reply e0 = Some r2) as eqr2 by (pbft_dest_all x; try omega).

      assert (Some r1 = Some r2) as eqrs by congruence.
      ginv.
    }
  Qed.

(*  Definition mk_reply
             (v : View)
             (t : Timestamp)
             (c : Client)
             (i : Rep)
             (r : PBFTresult)
             (a : Tokens) : Reply :=
    reply (bare_reply v t c i r) a.

  Lemma sent_replies_are_committed :
    forall (eo : EventOrdering) (e : Event) p dst st i,
      loc e = PBFTreplica i
      -> In (send_reply v t c i r) (output_system_on_event_ldata PBFTsys eo e)
      -> state_sm_on_event (PBFTreplicaSM i) eo e = Some st
      -> prepare_in_log p (log st) = true
      -> exists n,
          committed_log (request_data ) (log e).
  Proof.
  Qed.*)

(*
  Lemma in_check_send_replies_implies :
    forall i v ks
           (giop : option GeneratedInfo)
           (msgs : DirectedMsgs)
           (sn   : SeqNum)
           (m    : DirectedMsg)
           (st1 st2 : PBFTstate),
      check_send_replies i v ks giop st1 sn = (msgs, st2)
      -> In m msgs
      -> exists (prepop : option Prepare)
                (commop : option Commit)
                (entry : PBFTlogEntry),
          giop = Some (MkGeneratedInfo prepop commop entry)
          /\ is_committed_entry entry = true
          /\ m = send_check_ready check_ready (PBFTreplica i)
          /\ st2 = add_to_ready st1 sn.
  Proof.
    introv h j.
    unfold check_send_replies in h.
    destruct giop; simpl in *; tcsp.
    - destruct g.
      dest_cases x; ginv; simpl in *; tcsp.
      + inversion h; subst; clear h; simpl in *; repndors; subst; tcsp.
        eexists; eexists; eexists; dands; eauto.
      + inversion h; subst; clear h; simpl in *; tcsp.
    - inversion h; subst; simpl in *; tcsp.
  Qed.

  Lemma add_prepares_to_log_from_new_view_pre_prepares_returns_prep_comm_rep :
    forall (slf  : Rep)
           (pps  : list (Pre_prepare * PBFTdigest))
           (st1 st2 : PBFTstate)
           (msgs : DirectedMsgs)
           (m    : DirectedMsg),
      add_prepares_to_log_from_new_view_pre_prepares slf st1 pps = (st2, msgs)
      -> In m msgs
      -> (exists i p, m = MkDMsg i (PBFTprepare p))
         \/
         (exists i c, m = MkDMsg i (PBFTcommit c))
         \/
         (exists i r, m = MkDMsg i (PBFTcheck_ready r)).
  Proof.
    induction pps; introv e i; simpl in *; ginv.

    - inversion e; clear e; subst; simpl in *; tcsp.

    - dest_cases w; symmetry in Heqw.
      dest_cases x; symmetry in Heqx.
      inversion e; clear e; subst.
      apply in_app_iff in i; repndors.

      + unfold add_prepare_to_log_from_new_view_pre_prepare in Heqw.
        repnd; simpl in *.
        dest_cases y; symmetry in Heqy; simpl in *; tcsp;[|].

        * dest_cases u; symmetry in Hequ; simpl in *; tcsp;[].
          dest_cases v; symmetry in Heqv; simpl in *; tcsp;[].
          inversion Heqw; subst; clear Heqw.
          apply in_app_iff in i; repndors.

          { unfold check_broadcast_prepare in i.
            dest_cases q; subst; simpl in *.
            destruct q; simpl in *.
            dest_cases p; symmetry in Heqp; simpl in *; tcsp;[|].

            - inversion Heqv; subst; clear Heqv; simpl in *.
              dest_cases k; symmetry in Heqk; simpl in *; tcsp;[].
              dest_cases r; subst; simpl in *;tcsp;[|].

              + apply in_broadcast2others in i; exrepnd; subst; simpl in *.
                left.
                eexists; eexists; reflexivity.

              + apply in_broadcast2others in i; exrepnd; subst; simpl in *.
                left.
                eexists; eexists; reflexivity.

            - inversion Heqv; clear Heqv; subst; simpl in *.
              dest_cases k; symmetry in Heqk; simpl in *; tcsp.
              dest_cases r; symmetry in Heqr; simpl in *; tcsp;[|].

              + apply in_broadcast2others in i; exrepnd; subst; simpl in *.
                left.
                eexists; eexists; reflexivity.

              + apply in_broadcast2others in i; exrepnd; subst; simpl in *.
                left.
                eexists; eexists; reflexivity. }

          { unfold check_broadcast_commit in i.
            dest_cases q; symmetry in Heqq; subst; simpl in *; tcsp;[|].

            - destruct q; simpl in *.
              dest_cases k; symmetry in Heqk; simpl in *; tcsp;[|].

              + inversion Heqv; clear Heqv; subst; simpl in *.
                apply in_app_iff in i; simpl in *; repndors; tcsp.

                * dest_cases r; symmetry in Heqr; simpl in *; tcsp;[].
                  dest_cases p; subst; simpl in *; tcsp;[|].

                  { apply in_broadcast2others in i; exrepnd; subst.
                    right; left.
                    eexists; eexists; reflexivity. }

                  { apply in_broadcast2others in i; exrepnd; subst.
                    right; left.
                    eexists; eexists; reflexivity. }

                * subst; simpl in *.
                  right; right.
                  eexists; eexists; reflexivity.

              + inversion Heqv; clear Heqv; subst; simpl in *; tcsp.
                allrw app_nil_r.
                dest_cases q; symmetry in Heqq.
                dest_cases r; subst; simpl in *; tcsp;[|].

                * apply in_broadcast2others in i; exrepnd; subst; simpl in *.
                  right; left.
                  eexists; eexists; reflexivity.

                * apply in_broadcast2others in i; exrepnd; subst; simpl in *.
                  right; left.
                  eexists; eexists; reflexivity.

            - inversion Heqv; clear Heqv; subst; simpl in *; tcsp. }

        * inversion Heqw; clear Heqw; subst; simpl in *.
          apply in_broadcast2others in i; exrepnd; subst.
          left.
          eexists; eexists; reflexivity.

      + eapply IHpps in Heqx;[|eauto]; auto.
  Qed.

  Lemma update_state_new_view_returns_checkpoint :
    forall (slf  : Rep)
           (nv   : NewView)
           (st1 st2 : PBFTstate)
           (msgs : DirectedMsgs)
           (m    : DirectedMsg),
      update_state_new_view slf st1 nv = (st2, msgs)
      -> In m msgs
      -> (exists i c, m = MkDMsg i (PBFTcheckpoint c)).
  Proof.
    introv h i.
    unfold update_state_new_view in h.
    dest_cases w; symmetry in Heqw;[].
    dest_cases y; symmetry in Heqy;[|].

    - dest_cases z; subst; simpl in *;[|].

      + dest_cases x; symmetry in Heqx.
        inversion h; subst; clear h.
        unfold broadcast_checkpoint_op in i.
        dest_cases q; subst; simpl in *.
        apply in_broadcast2others in i; exrepnd; subst; simpl in *.
        exists o q; auto.

      + inversion h; subst; clear h; simpl in *; tcsp.

    - inversion h; subst; clear h; simpl in *; tcsp.
  Qed.

  (* replies are sent on receipt of check_ready messages *)
  Lemma send_reply_iff :
    forall (eo : EventOrdering) (e : Event) v t c i r a,
      In (send_reply (mk_reply v t c i r a)) (output_system_on_event_ldata PBFTsys eo e)
      <->
      (
        exists (n      : Rep)
               (cr     : CheckReady)
               (st st' : PBFTstate)
               (sns    : list SeqNum)
               (entry  : PBFTlogEntry)
               (reps   : list (option Reply))
               (smst   : PBFTsm_state)
               (lastr  : LastReplyState)
               (msgs   : DirectedMsgs),
          loc e = PBFTreplica n
          /\ trigger e = PBFTcheck_ready cr
          /\ state_sm_before_event (PBFTreplicaSM n) eo e = Some st
          /\ find_entry (log st) (next_to_execute st) = Some entry
          /\ reply2requests
               n
               (current_view st)
               (local_keys st)
               (log_entry2requests entry)
               (sm_state st)
               (last_reply_state st) = (reps, smst, lastr)
          /\ check_broadcast_checkpoint
               n
               (next_to_execute st)
               (current_view st)
               (local_keys st)
               (change_log_entry
                  (change_last_reply_state
                     (change_sm_state (increment_next_to_execute st) smst) lastr)
                  (add_replies2entry entry reps)) = (st', msgs)
          /\ ready st = next_to_execute st :: sns
          /\ In (mk_reply v t c i r a) (list_option2list reps)

      ).
  Proof.
    introv.
    rewrite in_output_system_on_event_ldata.
    split; intro h.

    - unfold PBFTsys in h.
      remember (loc e) as n; destruct n; simpl in *;
        unfold MStateMachine in *; ginv;
          [|apply MhaltedSM_output in h; tcsp];[].

      rw @loutput_sm_on_event_unroll2 in h; simpl in h.

      unfold PBFTreplica_update in h at 1; simpl in h.

      remember (trigger e) as trig; symmetry in Heqtrig.
      match goal with
      | [ H : context[option_map _ ?s] |- _ ] =>
        remember s as sop; symmetry in Heqsop; destruct sop; simpl in *; tcsp
      end.

      destruct trig; simpl in *; tcsp.

      + unfold PBFThandle_request in h; simpl in h.
        dest_all w.
        repndors; tcsp; ginv.

      + unfold PBFThandle_pre_prepare in h; simpl in *.
        dest_all w;[].

        apply in_app_iff in h; repndors;[|].

        * unfold check_broadcast_prepare in h.
          dest_all x.
          destruct x; simpl in *.
          fold DirectedMsgs in *.
          dest_all x.

        * apply in_app_iff in h;repndors;[|].

          { unfold check_broadcast_commit in h.
            dest_all x.
            destruct x; simpl in *.
            fold DirectedMsgs in *.
            dest_all x. }

          { match goal with
            | [ H : check_send_replies _ _ _ _ _ _ = _ |- _ ] =>
              eapply in_check_send_replies_implies in H;[|exact h]
            end.
            exrepnd; subst; simpl in *; ginv. }

      + unfold PBFThandle_prepare in h; simpl in *.
        dest_cases x; symmetry in Heqx; simpl in *;[].
        dest_cases y;[].
        dest_cases y; symmetry in Heqy; simpl in *;[].
        dest_cases z;[].
        dest_cases z; symmetry in Heqz; simpl in *;[].
        dest_cases w; symmetry in Heqw; simpl in *;[].
        dest_cases u; symmetry in Hequ; simpl in *;[].

        apply in_app_iff in h; repndors.

        { unfold check_broadcast_commit in h.
          destruct w0; simpl in *; tcsp;[].
          destruct g; simpl in *; tcsp;[].
          dest_cases d; symmetry in Heqd;[].
          dest_cases q; symmetry in Heqq; ginv;[|].

          { dest_cases t; simpl in *;[|].
            - apply in_broadcast2others in h; exrepnd; ginv.
            - apply in_broadcast2others in h; exrepnd; ginv. }

          { dest_cases t; simpl in *;[|].
            - apply in_broadcast2others in h; exrepnd; ginv.
            - apply in_broadcast2others in h; exrepnd; ginv. }
        }

        { eapply in_check_send_replies_implies in Hequ;[|exact h].
          exrepnd; subst; simpl in *; ginv. }

      + unfold PBFThandle_commit in h; simpl in *.
        dest_cases x; symmetry in Heqx; simpl in *;[].
        dest_cases y;[].
        dest_cases y; symmetry in Heqy; simpl in *;[].
        dest_cases z;[].
        dest_cases z; symmetry in Heqz; simpl in *;[].
        dest_cases w; symmetry in Heqw; simpl in *;[].
        dest_cases u; symmetry in Hequ; simpl in *;[].

        eapply in_check_send_replies_implies in Hequ;[|exact h].
        exrepnd; subst; simpl in *; ginv.

      + unfold PBFThandle_checkpoint in h.
        dest_cases x;[].
        dest_cases x; symmetry in Heqx; simpl in *;[].
        dest_cases y; symmetry in Heqy; simpl in *;[].
        dest_cases z; symmetry in Heqz; simpl in *;[].
        dest_cases w; symmetry in Heqw; simpl in *;[].
        dest_cases u; symmetry in Hequ; simpl in *;[].
        repndors; tcsp; ginv.

      + unfold PBFThandle_check_ready in h; simpl in *.
        dest_cases x; symmetry in Heqx; simpl in *;[].

        unfold find_and_execute_requests in Heqx.
        dest_cases w; symmetry in Heqw; repnd; ginv;[].

        unfold execute_requests in Heqw.
        remember (ready p) as rd; symmetry in Heqrd.
        destruct rd; [inversion Heqw; subst; simpl in *; tcsp|];[].

        dest_cases y; subst; simpl in *; tcsp;[|];
          [|inversion Heqw; subst; simpl in *; tcsp];[].

        dest_cases y; symmetry in Heqy; simpl in *; tcsp;[|];
          [|inversion Heqw; subst; simpl in *; tcsp];[].
        dest_cases u; symmetry in Hequ; repnd; simpl in *.
        dest_cases q; symmetry in Heqq.
        inversion Heqw; subst; clear Heqw; simpl in *.

        apply in_app_iff in h; simpl in *; repndors; ginv;[|].

        {
          apply in_map_iff in h; exrepnd.
          inversion h1; clear h1.
          remember (reply2client x) as cl.
          subst; simpl in *; GC.

          exists n c0 p w1 w0 y u2 u0 u1 q1.
          dands; auto.
        }

        {
          unfold check_broadcast_checkpoint in Heqq; simpl in *.
          dest_cases w; symmetry in Heqw; simpl in *; tcsp;[|].

          - dest_cases z; symmetry in Heqz; ginv.
            apply in_broadcast2others in h; exrepnd; ginv.

          - inversion Heqq; subst; simpl in *; tcsp.
        }

      + repndors; tcsp; ginv.

      + unfold PBFThandle_expired_timer in h.
        dest_cases x;[].
        dest_cases x; symmetry in Heqx; simpl in *;[].
        dest_cases y; symmetry in Heqy; simpl in *; tcsp;[|].

        * repnd; simpl in *.
          apply in_broadcast2others in h; exrepnd; ginv.

        * apply in_broadcast2others in h; exrepnd; ginv.

      + unfold PBFThandle_view_change in h.
        dest_cases x; simpl in *;[].
        dest_cases x; symmetry in Heqx; simpl in *;[].
        dest_cases y; symmetry in Heqy; simpl in *;[].
        dest_cases z; symmetry in Heqz; simpl in *;[].
        dest_cases q; symmetry in Heqq; simpl in *;[].
        repnd; simpl in *.
        dest_cases w; symmetry in Heqw; repnd; simpl in *;[].
        apply in_broadcast2others in h; exrepnd; ginv.

      + unfold PBFThandle_new_view in h.
        dest_cases x;[].
        dest_cases x; symmetry in Heqx; simpl in *;[].
        dest_cases y; symmetry in Heqy; simpl in *;[].
        dest_cases z; symmetry in Heqz; simpl in *;[].
        dest_cases w; symmetry in Heqw; simpl in *;[].
        dest_cases q; symmetry in Heqq; simpl in *;[].
        dest_cases u; symmetry in Hequ; simpl in *;[].
        dest_cases k; symmetry in Heqk; simpl in *;[].
        apply in_app_iff in h; repndors.

        * eapply add_prepares_to_log_from_new_view_pre_prepares_returns_prep_comm_rep in Hequ;[|exact h].
          repndors; exrepnd; ginv.

        * eapply update_state_new_view_returns_checkpoint in Heqk;[|eauto].
          exrepnd; ginv.

    - exrepnd.
      unfold PBFTsys.

      allrw; simpl.

      rw @loutput_sm_on_event_unroll2; simpl.

      unfold PBFTreplica_update at 1; simpl.
      allrw.
      fold DirectedMsgs in *.

      match goal with
      | [ |- context[option_map _ ?s] ] =>
        remember s as sop; symmetry in Heqsop; destruct sop; simpl in *; tcsp
      end;[].
      ginv.

      unfold PBFThandle_check_ready.
      unfold find_and_execute_requests.
      unfold execute_requests.
      allrw; simpl.

      dest_cases w.
      allrw; simpl.
      apply in_app_iff; simpl.

      left.
      apply in_map_iff; eexists; dands;[reflexivity|].
      auto.
  Qed.

  Definition hidden_check_broadcast_checkpoint
             (slf    : Rep)
             (sn     : SeqNum)
             (vn     : View)
             (keys   : local_key_map)
             (s      : PBFTstate)
             (s'     : PBFTstate)
             (msgs   : DirectedMsgs) : Prop
    := check_broadcast_checkpoint slf sn vn keys s = (s', msgs).

  Notation "'CHECK_BROADCAST_CHECKPOINT'" :=
    (hidden_check_broadcast_checkpoint _ _ _ _ _ _ _).

  Lemma hide_check_broadcast_checkpoint :
    forall slf sn vn keys s s' msgs,
      (check_broadcast_checkpoint slf sn vn keys s = (s', msgs))
      = hidden_check_broadcast_checkpoint slf sn vn keys s s' msgs.
  Proof. auto. Qed.

  Definition hidden_reply2requests
             (slf    : Rep)
             (view   : View)
             (keys   : local_key_map)
             (reqs   : list Request)
             (state  : PBFTsm_state)
             (lastr  : LastReplyState)
             (reps   : list (option Reply))
             (state' : PBFTsm_state)
             (lastr' : LastReplyState) : Prop
    := reply2requests slf view keys reqs state lastr = (reps, state', lastr').

  Notation "'REPLY2REQUESTS'" :=
    (hidden_reply2requests _ _ _ _ _ _ _ _ _).

  Lemma hide_reply2requests :
    forall slf view keys reqs state lastr reps state' lastr',
      (reply2requests slf view keys reqs state lastr = (reps, state', lastr'))
      = hidden_reply2requests slf view keys reqs state lastr reps state' lastr'.
  Proof. auto. Qed.

  Ltac hide_hyps :=
    repeat match goal with
           | [ H : check_broadcast_checkpoint _ _ _ _ _ = (_, _) |- _ ] =>
             rewrite hide_check_broadcast_checkpoint in H
           | [ H : reply2requests _ _ _ _ _ _ = (_, _, _) |- _ ] =>
             rewrite hide_reply2requests in H
           end.

  Ltac unhide_hyps :=
    repeat match goal with
           | [ H : hidden_check_broadcast_checkpoint _ _ _ _ _ _ _ |- _ ] =>
             rewrite <- hide_check_broadcast_checkpoint in H
           | [ H : hidden_check_broadcast_checkpoint _ _ _ _ _ _ _ _ _ |- _ ] =>
             rewrite <- hide_reply2requests in H
           end.

  Lemma in_reply2requests :
    forall slf view keys reqs state lastr rep reps state' lastr',
      reply2requests slf view keys reqs state lastr = (reps, state', lastr')
      -> In rep (list_option2list reps)
      ->
      exists (req : Request)
             (reqs1 reqs2 : list Request)
             (reps1 reps2 : list (option Reply))
             (state1 state2 : PBFTsm_state)
             (lastr1 lastr2 : LastReplyState),
        reqs = reqs1 ++ req :: reqs2
        /\ reply2requests slf view keys reqs1 state lastr = (reps1, state1, lastr1)
        /\ reply2request slf view keys req state1 lastr1 = (Some rep, state2, lastr2)
        /\ reply2requests slf view keys reqs2 state2 lastr2 = (reps2, state', lastr').
  Proof.
    induction reqs; introv e i; simpl in *; ginv; simpl in *; tcsp.
    dest_cases w; symmetry in Heqw; repnd.
    dest_cases y; symmetry in Heqy; repnd.
    ginv; simpl in *.
    dest_cases x; subst; simpl in *; repndors; subst; tcsp;[| |].

    - exists a ([] : list Request) reqs ([] : list (option Reply)) y2 state w0 lastr w1.
      simpl; dands; auto.

    - eapply IHreqs in Heqy;[|eauto]; clear IHreqs.
      exrepnd; subst.
      exists req (a :: reqs1) reqs2 (Some x :: reps1) reps2 state1 state2 lastr1 lastr2; simpl.
      allrw; simpl; dands; auto.

    - eapply IHreqs in Heqy;[|eauto]; clear IHreqs.
      exrepnd; subst.
      exists req (a :: reqs1) reqs2 (None :: reps1) reps2 state1 state2 lastr1 lastr2; simpl.
      allrw; simpl; dands; auto.
  Qed.

  Lemma eq_timestamps : forall t1 t2, timestamp2nat t1 = timestamp2nat t2 -> t1 = t2.
  Proof.
    introv; destruct t1, t2; simpl in *; auto.
  Qed.

  Lemma in_reply2request :
    forall slf view keys req state lastr rep state' lastr',
      reply2request slf view keys req state lastr = (Some rep, state', lastr')
      ->
      exists opr ts c entry result,
        request2info req = Some (opr, ts, c)
        /\ find_last_reply_entry_corresponding_to_client lastr c = Some entry
        /\ rep = reply (bare_reply view ts c slf result) (authenticate (PBFTmsg_bare_reply (bare_reply view ts c slf result)) keys)
        /\
        (
          (
            lre_timestamp entry < ts
            /\ PBFTsm_update c state opr = (result, state')
            /\ lastr' = update_last_reply_timestamp_and_result lastr c ts result
          )
          \/
          (
            lre_timestamp entry = ts
            /\ lre_reply entry = Some result
            /\ lastr' = lastr
            /\ state' = state
          )
        ).

  Proof.
    introv e.
    unfold reply2request in e.
    dest_all w;[|].

    - exists w0 w3 w2 w w1; dands; auto.

    - exists w0 w3 w2 w w5; dands; tcsp.
      right; dands; auto; try omega.
      apply eq_timestamps; omega.
  Qed.

  Lemma PBFTagreement :
    forall (eo : EventOrdering),
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> internal_messages_were_sent_usys eo PBFTsys
      -> forall (e1 e2 : Event)
                (c     : Client)
                (t     : Timestamp)
                (v1 v2 : View)
                (i1 i2 : Rep)
                (r1 r2 : PBFTresult)
                (tok1 tok2 : Tokens),
        isCorrect e1
        -> isCorrect e2
        -> In (send_reply (mk_reply v1 t c i1 r1 tok1)) (output_system_on_event_ldata PBFTsys eo e1)
        -> In (send_reply (mk_reply v2 t c i2 r2 tok2)) (output_system_on_event_ldata PBFTsys eo e2)
        -> r1 = r2.
  Proof.
    introv sentbyz sentint isCor1 isCor2 send1 send2.

    destruct (PBFTresdeq r1 r2) as [d|d]; auto.
    assert False; tcsp.

    (* replies are sent in response to check-ready messages *)
    apply send_reply_iff in send1.
    apply send_reply_iff in send2.
    exrepnd.

    repeat match goal with
           | [ H : reply2requests _ _ _ _ _ _ = _ |- _ ] =>
             eapply in_reply2requests in  H;[|eauto];[]
           end.
    exrepnd.

    match goal with
    | [ H : reply2request _ _ _ _ _ _ = _ |- _ ] => apply in_reply2request in H
    end.

    SearchAbout reply2requests.

  (*
    hide_hyps.

    pose proof (sentint e2) as q.
    match goal with
    | [ H1 : trigger ?e = _ , H2 : context[is_internal_message (trigger ?e)] |- _ ] =>
      rewrite H1 in H2
    end.
    repeat (autodimp q hyp);[].
    exrepnd.
*)

  Qed.
*)

End PBFTagreement.