From Goose.github_com.tchajed.goose.internal.examples Require Import append_log.
From Perennial.goose_lang.lib Require Import encoding crash_lock.
From Perennial.program_proof Require Import disk_prelude.
From Perennial.program_proof Require Import disk_lib.
From Perennial.program_proof Require Import append_log_hocap.
From Perennial.program_proof Require Import append_log_refinement_triples.
From Perennial.goose_lang.ffi Require Import append_log_ffi.
From Perennial.goose_lang Require Import logical_reln_defns logical_reln_adeq spec_assert.
From Perennial.base_logic Require Import ghost_var.

Existing Instances log_spec_ext log_spec_ffi_model log_spec_ext_semantics log_spec_ffi_interp log_spec_interp_adequacy.

Section refinement.
Context `{!heapGS Σ}.
Context `{!refinement_heapG Σ}.
Context `{stagedG Σ}.

Existing Instance logG0.
Context `{Hin: inG Σ (authR (optionUR (exclR log_stateO)))}.
Context `{Hin_nat_ctx: inG Σ (authR (optionUR (exclR (leibnizO (nat * (spec_lang.(language.expr) →
                                                                       spec_lang.(language.expr)))))))}.
Context (SIZE: nat).
Context (SIZE_nonzero: 0 < SIZE).
Context (SIZE_bounds: int.nat SIZE = SIZE).

Existing Instances spec_ffi_model_field spec_ffi_op_field spec_ext_semantics_field (* spec_ffi_interp_field  *) spec_ffi_interp_adequacy_field.

Notation sstate := (@state (@spec_ffi_op_field log_spec_ext) (spec_ffi_model_field)).
Notation sexpr := (@expr (@spec_ffi_op_field log_spec_ext)).
Notation sval := (@val (@spec_ffi_op_field log_spec_ext)).

Class appendG (Σ: gFunctors) :=
  { append_stagedG :> stagedG Σ;
    append_stateG :> inG Σ (authR (optionUR (exclR log_stateO)));
    append_nat_ctx :> inG Σ (authR (optionUR (exclR (leibnizO (nat * (spec_lang.(language.expr) →
                                                                       spec_lang.(language.expr)))))))
  }.

Definition append_names := unit.
Definition append_get_names (Σ: gFunctors) (hG: appendG Σ) := tt.
Definition append_update (Σ: gFunctors) (hG: appendG Σ) (n: append_names) := hG.

Definition LVL_INIT : nat := 100.
Definition LVL_INV : nat := 75.
Definition LVL_OPS : nat := 50.
Existing Instance logG0.

Definition append_inv {Σ: gFunctors} {hG: heapGS Σ} {rG: refinement_heapG Σ} {cG: crashGS Σ} {aG : appendG Σ} :=
  (∃ γ, log_inv SIZE γ LVL_INV%nat)%I.
Definition append_init {Σ: gFunctors} {hG: heapGS Σ} {rG: refinement_heapG Σ} {cG: crashGS Σ} {aG : appendG Σ}
  : iProp Σ := (∃ γ, log_init (P γ) SIZE).
Definition append_crash_cond {Σ: gFunctors} {hG: heapGS Σ} {rG: refinement_heapG Σ} {cG: crashGS Σ} {aG : appendG Σ}
  : iProp Σ := (∃ γ, log_crash_cond (P γ) SIZE).
Definition appendN : coPset := (∅ : coPset).
Definition append_val_interp {Σ: gFunctors} {hG: heapGS Σ} {rG: refinement_heapG Σ} {cG: crashGS Σ} {aG : appendG Σ}
           (ty: @ext_tys (@val_tys _ log_ty)) : val_semTy :=
  λ vspec vimpl, (∃ (lspec: loc) (limpl: loc) γ,
            ⌜ vspec = #lspec ∧ vimpl = #limpl ⌝ ∗ is_log SIZE γ LVL_INV limpl ∗ log_open lspec)%I.

Instance appendTy_model : specTy_model log_ty.
Proof using SIZE.
 refine
  {| styG := appendG;
     sty_names := append_names;
     sty_get_names := append_get_names;
     sty_update := append_update;
     sty_inv := @append_inv;
     sty_init := @append_init;
     sty_crash_cond := @append_crash_cond;
     styN := appendN;
     sty_lvl_init := LVL (LVL_INIT);
     sty_lvl_ops := LVL (LVL_OPS);
     sty_val_interp := @append_val_interp |}.
 - intros ? [] [] => //=.
 - intros ? [] => //=.
 - intros ?? [] [] => //=.
 - rewrite /sN/appendN. apply disjoint_empty_r.
 - abstract (intros; iIntros "H"; iDestruct "H" as (??? (->&->)) "H" => //=).
Defined.
(* XXX: some of the fields should be opaque/abstract here, because they're enormous proof terms.
  perhaps specTy_model should be split into two typeclasses? *)

Existing Instances subG_stagedG.

Definition appendΣ := #[stagedΣ;
                          GFunctor (authR (optionUR (exclR log_stateO)));
                          GFunctor ((authR (optionUR (exclR (leibnizO (nat * (spec_lang.(language.expr) →
                                                                       spec_lang.(language.expr))))))))].

Instance subG_appendG: ∀ Σ, subG appendΣ Σ → appendG Σ.
Proof. solve_inG. Qed.
Definition append_initP (σimpl: @state disk_op disk_model) (σspec : @state log_op log_model) : Prop :=
  (null_non_alloc σspec.(heap)) ∧
  (σimpl.(world) = init_disk ∅ SIZE) ∧
  (σspec.(world) = UnInit).
Definition append_update_pre (Σ: gFunctors) (hG: appendG Σ) (n: append_names) : appendG Σ := hG.

Program Instance appendTy_update_model : specTy_update appendTy_model :=
  {| sty_preG := appendG;
            styΣ := appendΣ;
            subG_styPreG := subG_appendG;
            sty_update_pre := @append_update_pre |}.
Next Obligation. rewrite //=. Qed.
Next Obligation. rewrite //=. intros ?? [] => //=. Qed.

Notation append_nat_K :=
(leibnizO (nat * ((@spec_lang log_spec_ext log_spec_ffi_model log_spec_ext_semantics).(language.expr)
                           → (@spec_lang log_spec_ext log_spec_ffi_model log_spec_ext_semantics).(language.expr)))).

Lemma append_init_obligation1: sty_init_obligation1 appendTy_update_model append_initP.
Proof.
  rewrite /sty_init_obligation1//=.
  iIntros (? hG hRG hC hAppend σs σi Hinit) "Hdisk".
  rewrite /log_start /append_init/log_init.
  inversion Hinit as [Hnn [Heqi Heqs]]. rewrite Heqs Heqi.
  iIntros "(Huninit_frag&Hlog_frag)". rewrite /P//=.
  rewrite /thread_tok_full.
  iMod (ghost_var_alloc ((O, id) : append_nat_K)) as (γ) "Hown".
  iModIntro. iExists tt, γ. iLeft. iFrame.
  rewrite /append_log_proof.uninit_log.
  iExists _.
  iSplitL "Hdisk".
  - by iApply disk_array_init_disk.
  - rewrite replicate_length //=.
Qed.

Lemma append_init_obligation2: sty_init_obligation2 append_initP.
Proof. intros ?? (?&?&?). rewrite //=. Qed.

Definition append_op_trans (op: log_spec_ext.(@spec_ffi_op_field).(@external)) : @val disk_op :=
  match op with
  | AppendOp => Log__Append
  | GetOp => Log__Get
  | ResetOp => Log__Reset
  | InitOp => (λ:<>, Init #SIZE)%V
  | OpenOp => Open
  end.

Inductive append_trans : @val log_op -> @val disk_op -> Prop :=
| AppendTrans (x: string) op:
    append_trans (λ: x, ExternalOp op (Var x)) (append_op_trans op).

Lemma append_rules_obligation:
  @sty_rules_obligation _ _ disk_semantics _ _ _ _ _ _ appendTy_model append_trans.
Proof.
  intros vs0 vs v0 v0' t1 t2 Htype0 Htrans.
  inversion Htype0 as [op Heq Htype]; subst.
  destruct op; inversion Htype; inversion Htrans; subst.
  - admit.
  - admit.
  - iIntros (?????) "#Hinv #Hspec #Hval".
    iIntros (j K Hctx).
    rewrite //=.
    iIntros "Hj".
    rewrite /append_val_interp. iDestruct "Hval" as (lspec limpl γ Heq) "(His_log&Hlog_open)".
    destruct Heq as (->&->). iDestruct "Hinv" as (?) "Hinv".
    iMod (ghost_step_lifting_puredet with "[Hj]") as "(Hj&_)"; swap 1 3.
    { iFrame. iDestruct "Hspec" as "($&?)".
    }
    { set_solver+. }
    { intros ?. eexists. simpl.
      apply head_prim_step. econstructor; eauto. }
    rewrite /LVL_OPS.
    wpc_apply (@wpc_Log__Reset with "[$] []").
    { eauto. }
    { rewrite /LVL_INV. lia. }
    iSplit; first done. iNext. iIntros. iExists _. eauto.
  - inversion Htype; subst.
    iIntros (?????) "#Hinv #Hspec #Hval".
    iIntros (j K Hctx).
    rewrite //=.
    iIntros "Hj".
    rewrite /append_val_interp.
    iDestruct "Hval" as %[-> ->]. iDestruct "Hinv" as (?) "Hinv".
    wpc_pures; first done.
    iMod (ghost_step_lifting_puredet with "[Hj]") as "(Hj&_)"; swap 1 3.
    { iFrame. iDestruct "Hspec" as "($&?)".
    }
    { set_solver+. }
    { intros ?. eexists. simpl.
      apply head_prim_step. econstructor; eauto. }
    wpc_apply (@wpc_Init with "[$] []").
    { eauto. }
    { eauto. }
    { rewrite /LVL_INV. lia. }
    iSplit; first done. iNext. iIntros (?) "(#His_log&Hj)".
    iDestruct "Hj" as (?) "(Hj&Hopen)".
    iExists _. iFrame.
    iExists _, _, _, _. iSplit.
    { iPureIntro; split; eauto. }
    iSplitR ""; eauto.
    iExists _, _, _. eauto.
  - inversion Htype; subst.
    iIntros (?????) "#Hinv #Hspec #Hval".
    iIntros (j K Hctx).
    rewrite //=.
    iIntros "Hj".
    rewrite /append_val_interp.
    iDestruct "Hval" as %[-> ->]. iDestruct "Hinv" as (?) "Hinv".
    iMod (ghost_step_lifting_puredet with "[Hj]") as "(Hj&_)"; swap 1 3.
    { iFrame. iDestruct "Hspec" as "($&?)".
    }
    { set_solver+. }
    { intros ?. eexists. simpl.
      apply head_prim_step. econstructor; eauto. }
    wpc_apply (@wpc_Open with "[$] []").
    { eauto. }
    { rewrite /LVL_INV. lia. }
    iSplit; first done. iNext. iIntros (?) "(#His_log&Hj)".
    iDestruct "Hj" as (?) "(Hj&Hopen)".
    iExists _. iFrame.
    iExists _, _, _. iSplit.
    { iPureIntro; split; eauto. }
    iFrame. iFrame "#".
Admitted.

Lemma append_crash_inv_obligation:
  @sty_crash_inv_obligation _ _ disk_semantics _ _ _ _ _ _ appendTy_model.
Proof using SIZE.
  clear SIZE_bounds SIZE_nonzero.
  rewrite /sty_crash_inv_obligation//=.
  iIntros (? hG hC hRG hAppend e Φ) "Hinit Hspec Hwand".
  rewrite /append_inv/append_init/log_inv.
  iDestruct ("Hinit") as (γ) "Hinit".
  rewrite /append_crash_cond.
  iPoseProof (append_log_na_crash_inv_obligation Nlog _ POpened (PStartedOpening _)
                                                 _ _ _ _ _ _ LVL_INIT
                                                 LVL_INV LVL_OPS with "Hinit [Hwand]") as ">(Hinv&Hwp)".
  { rewrite /LVL_INIT/LVL_INV. lia. }
  { rewrite /LVL_INIT/LVL_OPS. lia. }
  { iIntros "Hinv". iApply "Hwand". iExists _. eauto. }
  iModIntro. iSplitL "Hinv".
  { iExists _. iApply "Hinv". }
  iApply (wpc_mono with "Hwp"); eauto.
  iIntros "(_&H)". iExists _. iFrame.
Qed.

Lemma append_crash_obligation:
  @sty_crash_obligation _ _ disk_semantics _ _ _ _ _ _ appendTy_model.
Proof using SIZE.
  clear SIZE_bounds.
  rewrite /sty_crash_obligation//=.
  iIntros (? hG hC hRG hAppend) "Hinv Hcrash_cond".
  iMod (ghost_var_alloc ((O, id) : append_nat_K)) as (γtok) "Hown".
  iDestruct "Hinv" as (γ1) "#Hlog_inv".
  rewrite /append_crash_cond.
  iDestruct "Hcrash_cond" as (γ2 ls) "(Hstate_to_crash&HP)".
  rewrite/ log_state_to_crash.
  iModIntro. iNext. iIntros (hG').
  iModIntro. iIntros (hC' σs Hrel).
  destruct Hrel as (?&?&_&Heq&_).
  iIntros "Hctx".
  rewrite /append_init/log_init.
  destruct (σs.(world)) eqn:Hworld_case; try iDestruct "Hctx" as %[].
  - iAssert (⌜ ls = UnInit ∨ ls = Initing ⌝ ∗ log_ctx UnInit ∗ log_frag [])%I with "[HP Hctx]" as (Heqls) "(Hctx&Hfrag)".
    {
      rewrite /log_ctx/P.
      iDestruct "Hctx" as "(?&?)".
      destruct ls; try (iDestruct "HP" as "(?&?&?)" || iDestruct "HP" as "(?&?)");
        try (iFrame; eauto; done).
      - iDestruct (log_uninit_auth_closed_frag with "[$] [$]") as %[].
      - iDestruct (log_uninit_auth_closed_frag with "[$] [$]") as %[].
      - iDestruct "HP" as (?) "(HP&?)".
        iDestruct (log_uninit_auth_opened with "[$] [$]") as %[].
    }
    iExists _. unshelve (iExists _).
    { econstructor.
      { symmetry; eauto. }
      repeat econstructor.
    }
    iFrame. iIntros (hRG' (Heq1&Heq2)) "Hrestart".
    iModIntro.
    iExists tt, γtok. iLeft.
    rewrite /logG0//=/log_frag//=. rewrite Heq2. rewrite Heq1.
    iFrame. subst.
    rewrite /append_log_proof.uninit_log.
    rewrite /disk_array. rewrite /diskG0.
    rewrite Heq.
    destruct Heqls as [-> | ->]; iFrame.
  - rewrite /P/log_ctx.
    iAssert (⌜ ls = Closed s ∨ ls = Opening s  ⌝ ∗
             log_ctx (Closed s) ∗ log_frag s)%I with "[HP Hctx]" as (Heqls) "(Hctx&Hfrag)".
    {
      rewrite /log_ctx/P.
      iDestruct "Hctx" as "(?&?)".
      destruct ls; try (iDestruct "HP" as "(?&?&?)" || iDestruct "HP" as "(?&?)");
        try (iFrame; eauto; done).
      - iDestruct (log_closed_auth_uninit_frag with "[$] [$]") as %[].
      - iDestruct (log_closed_auth_uninit_frag with "[$] [$]") as %[].
      - iDestruct (log_auth_frag_unif with "[$] [$]") as %->. iFrame. eauto.
      - iDestruct (log_auth_frag_unif with "[$] [$]") as %->. iFrame. eauto.
      - iDestruct "HP" as (?) "(HP&?)".
        iDestruct (log_closed_auth_opened with "[$] [$]") as %[].
    }
    iExists _. unshelve (iExists _).
    { econstructor.
      { symmetry; eauto. }
      simpl.
      repeat econstructor.
    }
    iFrame. iIntros (hRG' (Heq1&Heq2)) "Hrestart".
    iModIntro.
    iExists tt, γtok. iRight.
    rewrite /logG0//=/log_frag//=. rewrite Heq2. rewrite Heq1.
    iFrame. subst.
    rewrite /append_log_proof.uninit_log.
    rewrite /disk_array. rewrite /diskG0.
    destruct Heqls as [-> | ->];
      iExists _; iFrame;
      iFrame; subst;
      (* XXX: need a typeclass? or lemma? to say that these kinds of
         disk assertions are "stable" when we go from hG to hG' because
         disk ffi generation number doesn't change *)
      rewrite /append_log_proof.uninit_log;
      rewrite /append_log_proof.crashed_log;
      rewrite /append_log_proof.is_log';
      rewrite /append_log_proof.is_hdr;
      rewrite /disk_array; rewrite /diskG0;
      rewrite Heq;
      iFrame.
  - rewrite /P/log_ctx.
    iAssert (∃ l0, ⌜ ls = Opened s l0  ⌝ ∗ log_ctx (Opened s l) ∗ log_frag s)%I with "[HP Hctx]" as (? Heqls) "(Hctx&Hfrag)".
    {
      rewrite /log_ctx/P.
      iDestruct "Hctx" as "(?&?)".
      destruct ls; try (iDestruct "HP" as "(?&?&?)" || iDestruct "HP" as "(?&?)");
        try (iFrame; eauto; done).
      - iDestruct (log_uninit_auth_opened with "[$] [$]") as %[].
      - iDestruct (log_uninit_auth_opened with "[$] [$]") as %[].
      - iDestruct (log_closed_auth_opened with "[$] [$]") as %[].
      - iDestruct (log_closed_auth_opened with "[$] [$]") as %[].
      - iDestruct "HP" as (?) "(HP&?)".
        iDestruct (log_auth_frag_unif with "[$] [$]") as %->.
        iDestruct (log_open_unif with "[$] [$]") as %->. iFrame.
        iExists _. iFrame; eauto.
    }
    iExists _. unshelve (iExists _).
    { econstructor.
      { symmetry; eauto. }
      simpl.
      repeat econstructor.
    }
    iFrame. iIntros (hRG' (Heq1&Heq2)) "Hrestart".
    iModIntro.
    iExists tt, γtok. iRight.
    rewrite /logG0//=/log_frag//=. rewrite Heq2. rewrite Heq1.
    iFrame. subst.
    rewrite /append_log_proof.uninit_log.
    rewrite /disk_array. rewrite /diskG0.
      iExists _; iFrame;
      iFrame; subst;
      (* XXX: need a typeclass? or lemma? to say that these kinds of
         disk assertions are "stable" when we go from hG to hG' because
         disk ffi generation number doesn't change *)
      rewrite /append_log_proof.uninit_log;
      rewrite /append_log_proof.crashed_log;
      rewrite /append_log_proof.is_log';
      rewrite /append_log_proof.is_hdr;
      rewrite /disk_array; rewrite /diskG0;
      rewrite Heq;
      iFrame.
Qed.

Existing Instances log_semantics.
Existing Instances spec_ffi_model_field spec_ffi_op_field spec_ext_semantics_field spec_ffi_interp_field spec_ffi_interp_adequacy_field.
(* XXX: might need to change typed_translate / refinement to use the spec_ wrappers around type classes *)

Lemma append_refinement (es: @expr log_op) σs e σ (τ: @ty log_ty.(@val_tys log_op)):
  typed_translate.expr_transTy _ _ _ append_trans ∅ es e τ →
  σ.(trace) = σs.(trace) →
  σ.(oracle) = σs.(oracle) →
  append_initP σ σs →
  refinement.trace_refines e e σ es es σs.
Proof.
  intros. intros ?.
  efeed pose proof sty_adequacy; eauto using append_init_obligation1, append_init_obligation2,
                                 append_crash_inv_obligation, append_crash_obligation,
                                 append_rules_obligation.
Qed.

End refinement.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From extructures Require Import ord fmap.
From CoqUtils Require Import hseq word.

Require Import lib.utils common.types.
Require Import symbolic.symbolic sealing.classes.

Import Symbolic.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Sym.

Section WithClasses.

Context {mt : machine_types}
        {ops : machine_ops mt}
        {opss : machine_ops_spec ops}
        {scr : syscall_regs mt}
        {ssa : @sealing_syscall_addrs mt}.

Open Scope ord_scope.

Class sealing_key := {
  key : ordType;
  max_key;
  inc_key : key -> key;
  ltb_inc : forall sk, sk < max_key -> sk < inc_key sk
}.

Context {sk : sealing_key}.

(* We represent keys as tags on dummy values instead of payloads
  because this eliminates conversions from keys to words and back. *)
Inductive stag :=
| DATA   :        stag
| KEY    : key -> stag
| SEALED : key -> stag.

Definition stag_eq t1 t2 :=
  match t1, t2 with
    | DATA, DATA => true
    | KEY k1, KEY k2
    | SEALED k1, SEALED k2 => k1 == k2
    | _, _ => false
  end.

Lemma stag_eqP : Equality.axiom stag_eq.
Proof.
by move=> [|k1|k1] [|k2|k2] /=; apply: (iffP idP) => // [/eqP->|[->]].
Qed.

Definition stag_eqMixin := EqMixin stag_eqP.
Canonical stag_eqType := Eval hnf in EqType stag stag_eqMixin.

Definition stags := {|
  pc_tag_type := [eqType of unit];
  reg_tag_type := [eqType of stag];
  mem_tag_type := [eqType of stag];
  entry_tag_type := [eqType of unit]
|}.

Section WithHSeqs.

Definition sealing_handler (iv : ivec stags) : option (vovec stags (op iv)) :=
  match iv with
  | IVec (OP NOP)       tt DATA [hseq]               => Some (@OVec stags NOP tt tt)
  | IVec (OP CONST)     tt DATA [hseq _]             => Some (@OVec stags CONST tt DATA)
  | IVec (OP MOV)       tt DATA [hseq tsrc; _]       => Some (@OVec stags MOV tt tsrc)
  | IVec (OP (BINOP o)) tt DATA [hseq DATA; DATA; _] => Some (@OVec stags (BINOP o) tt DATA)
  | IVec (OP LOAD)      tt DATA [hseq DATA; tmem; _] => Some (@OVec stags LOAD tt tmem)
  | IVec (OP STORE)     tt DATA [hseq DATA; tsrc; _] => Some (@OVec stags STORE tt tsrc)
  | IVec (OP JUMP)      tt DATA [hseq DATA]          => Some (@OVec stags JUMP tt tt)
  | IVec (OP BNZ)       tt DATA [hseq DATA]          => Some (@OVec stags BNZ tt tt)
  | IVec (OP JAL)       tt DATA [hseq DATA; _]       => Some (@OVec stags JAL tt DATA)
  | IVec SERVICE        tt _    [hseq]               => Some tt
  | IVec _              tt _ _                       => None
  end.

End WithHSeqs.

Program Instance sym_sealing : params := {
  ttypes := stags;

  transfer := sealing_handler;

  internal_state := key  (* next key to generate *)
}.

Import DoNotation.

Definition mkkey (s : state mt) : option (state mt) :=
  let 'State mem reg pc@pct key := s in
  if key < max_key then
    let key' := inc_key key in
    do! reg' <- updm reg syscall_ret 0%w@(KEY key);
    do! ret  <- reg ra;
    match ret with
    | pc'@DATA => Some (State mem reg' (pc'@tt) key')
    | _ => None
    end
  else
    None.

Definition seal (s : state mt) : option (state mt) :=
  let 'State mem reg pc@pct next_key := s in
  match reg syscall_arg1, reg syscall_arg2 with
  | Some payload@DATA, Some _@(KEY key) =>
    do! reg' <- updm reg syscall_ret payload@(SEALED key);
    do! ret  <- reg ra;
    match ret with
    | pc'@DATA => Some (State mem reg' (pc'@tt) next_key)
    | _ => None
    end
  | _, _ => None
  end.

Definition unseal (s : state mt) : option (state mt) :=
  let 'State mem reg pc@pct next_key := s in
  match reg syscall_arg1, reg syscall_arg2 with
  | Some payload@(SEALED key), Some _@(KEY key') =>
    if key == key' then
      do! reg' <- updm reg syscall_ret payload@DATA;
      do! ret  <- reg ra;
      match ret with
      | pc'@DATA => Some (State mem reg' (pc'@tt) next_key)
      | _ => None
      end
    else None
  | _, _ => None
  end.

Definition sealing_syscalls : syscall_table mt :=
  [fmap (mkkey_addr,  Syscall tt mkkey);
        (seal_addr,   Syscall tt seal);
        (unseal_addr, Syscall tt unseal)].

Definition step := step sealing_syscalls.

End WithClasses.

(* BCP: Aren't there also some proof obligations that we need to satisfy? *)
(* CH: You mean for the concrete-symbolic refinement?
   I expect those to appear when talking about that refinement,
   which we don't yet *)

(* BCP: Yes, that's what I meant.  I know we're not there yet, but I
   am wondering where we want to write them.  Still confused about the
   modularization strategy for the whole codebase... *)
(* CH: We will probably make a refinementCS.v file at some point,
   and I expect that to use any of Arthur's results we'll need
   to give this kind of details *)

Notation memory mt := (Symbolic.memory mt sym_sealing).
Notation registers mt := (Symbolic.registers mt sym_sealing).

End Sym.


Require Import String List.
Import ListNotations.

Require Import Kami.Kami.
Require Import Hemiola.Lib.Index.
Require Import Compiler.HemiolaDeep Compiler.CompileK.
Require Import MesiDeep.

Set Implicit Arguments.

Definition KMesi: Kind := Bit 3.
Definition mesiM {var}: Expr var (SyntaxKind KMesi) := ($4)%kami_expr.
Definition mesiE {var}: Expr var (SyntaxKind KMesi) := ($3)%kami_expr.
Definition mesiS {var}: Expr var (SyntaxKind KMesi) := ($2)%kami_expr.
Definition mesiI {var}: Expr var (SyntaxKind KMesi) := ($1)%kami_expr.
Definition mesiNP {var}: Expr var (SyntaxKind KMesi) := ($0)%kami_expr.

Section Directory.
  Context `{ReifyConfig} `{TopoConfig}.

  Definition KDir :=
    STRUCT { "dir_st" :: KMesi;
             "dir_excl" :: KCIdx;
             "dir_sharers" :: KCBv }.

  Definition compile_dir_get {var}
             (oidx: KCIdx @ var) (dir: (Struct KDir) @ var): Expr var (SyntaxKind KMesi) :=
    (let dir_st := dir!KDir@."dir_st" in
     let dir_excl := dir!KDir@."dir_excl" in
     let dir_sharers := dir!KDir@."dir_sharers" in
     IF (dir_st == mesiM && dir_excl == oidx) then mesiM
     else IF (dir_st == mesiE && dir_excl == oidx) then mesiE
     else IF (dir_st == mesiS && bvTest dir_sharers oidx) then mesiS
     else mesiI)%kami_expr.

End Directory.

Section Instances.
  Context `{TopoConfig}.

  Instance MesiCompExtType: CompExtType :=
    {| kind_of_hetype := fun het => match het with
                                    | HDir => Struct KDir
                                    end
    |}.

  Arguments compile_bexp {_ _ _ _ _ _ _ _ _} _ _ _ _ {_}.
  Fixpoint compile_dir_exp
           (var: Kind -> Type) {het}
           (msgIn: var (Struct KMsg))
           (mshr: var (Struct MSHR))
           (frs : var (Struct KMsg))
           (ostvars: HVector.hvec (Vector.map (fun hty => var (kind_of hty)) hostf_ty))
           (he: heexp (hvar_of var) het): Expr var (SyntaxKind (kind_of het)) :=
    (match he in (hexp_dir _ h) return (Expr var (SyntaxKind (kind_of h))) with
     | HDirC _ => #(HVector.hvec_ith ostvars Mesi.dir)
     | HDirGetSt dir => ((compile_dir_exp msgIn mshr frs ostvars dir)!KDir@."dir_st")
     | HDirGetExcl dir => ((compile_dir_exp msgIn mshr frs ostvars dir)!KDir@."dir_excl")
     | HDirGetStO oidx dir => compile_dir_get (compile_bexp msgIn mshr frs ostvars oidx)
                                              (compile_dir_exp msgIn mshr frs ostvars dir)
     | HDirGetSh dir => ((compile_dir_exp msgIn mshr frs ostvars dir)!KDir@."dir_sharers")
     | HDirRemoveSh sh cidx =>
       bvUnset (compile_dir_exp msgIn mshr frs ostvars sh) (compile_bexp msgIn mshr frs ostvars cidx)
     | HDirAddSharer oidx dir =>
       (let kdir := compile_dir_exp msgIn mshr frs ostvars dir in
        STRUCT { "dir_st" ::= mesiS;
                 "dir_excl" ::= kdir!KDir@."dir_excl";
                 "dir_sharers" ::=
                   IF (kdir!KDir@."dir_st" == mesiS)
                 then (bvSet (kdir!KDir@."dir_sharers") (compile_bexp msgIn mshr frs ostvars oidx))
                 else (bvSingleton _ (compile_bexp msgIn mshr frs ostvars oidx)) })
     | HDirRemoveSharer oidx dir =>
       (let kdir := compile_dir_exp msgIn mshr frs ostvars dir in
        STRUCT { "dir_st" ::= mesiS;
                 "dir_excl" ::= kdir!KDir@."dir_excl";
                 "dir_sharers" ::= bvUnset (kdir!KDir@."dir_sharers")
                                           (compile_bexp msgIn mshr frs ostvars oidx) })

     | HDirSetM oidx => (STRUCT { "dir_st" ::= mesiM;
                                  "dir_excl" ::= compile_bexp msgIn mshr frs ostvars oidx;
                                  "dir_sharers" ::= $$Default })
     | HDirSetE oidx => (STRUCT { "dir_st" ::= mesiE;
                                  "dir_excl" ::= compile_bexp msgIn mshr frs ostvars oidx;
                                  "dir_sharers" ::= $$Default })
     | HDirSetS oinds => (STRUCT { "dir_st" ::= mesiS;
                                   "dir_excl" ::= $$Default;
                                   "dir_sharers" ::=
                                     List.fold_left
                                       (fun bv i => bvSet bv i)
                                       (map (compile_bexp msgIn mshr frs ostvars) oinds)
                                       $$Default })
     | HDirSetI _ => (STRUCT { "dir_st" ::= mesiI;
                               "dir_excl" ::= $$Default;
                               "dir_sharers" ::= $$Default })

     | HRqUpFrom oidx => {$TopoTemplate.rqUpIdx, compile_dir_exp msgIn mshr frs ostvars oidx}
     | HRsUpFrom oidx => {$TopoTemplate.rsUpIdx, compile_dir_exp msgIn mshr frs ostvars oidx}
     | HDownTo oidx => {$TopoTemplate.downIdx, compile_dir_exp msgIn mshr frs ostvars oidx}
     | HRqUpFromM oinds => compile_dir_exp msgIn mshr frs ostvars oinds
     | HRsUpFromM oinds => compile_dir_exp msgIn mshr frs ostvars oinds
     | HDownToM oinds => compile_dir_exp msgIn mshr frs ostvars oinds
     | HSingleton se => bvSet $$Default (_truncate_ (compile_dir_exp msgIn mshr frs ostvars se))
     | HInvalidate se =>
       (* (IF ((compile_bexp msgIn mshr ostvars se) == mesiNP) then mesiNP else mesiI) *)
       mesiI
     end)%kami_expr.

  Definition compile_dir_OPrec
             (var: Kind -> Type)
             (msgIn: var (Struct KMsg))
             (mshr: var (Struct MSHR))
             (frs : var (Struct KMsg))
             (ostvars: HVector.hvec (Vector.map (fun hty => var (kind_of hty)) hostf_ty))
             (pd: heoprec (hvar_of var)): Expr var (SyntaxKind Bool) :=
    (match pd with
     | DirLastSharer cidx =>
       bvIsSingleton (#(HVector.hvec_ith ostvars Mesi.dir)!KDir@."dir_sharers")
                     (compile_bexp msgIn mshr frs ostvars cidx)
     | DirNotLastSharer _ =>
       bvCount (#(HVector.hvec_ith ostvars Mesi.dir)!KDir@."dir_sharers") > $1
     | DirOtherSharerExists cidx =>
       bvUnset (#(HVector.hvec_ith ostvars Mesi.dir)!KDir@."dir_sharers")
               (compile_bexp msgIn mshr frs ostvars cidx) != $0
     end)%kami_expr.

  Instance MesiCompExtExp: CompExtExp :=
    {| compile_eexp := compile_dir_exp;
       compile_eoprec := compile_dir_OPrec
    |}.

  Definition MesiInfo :=
    STRUCT { "mesi_owned" :: Bool;
             "mesi_status" :: KMesi;
             "mesi_dir_st" :: KMesi;
             "mesi_dir_sharers" :: Bit hcfg_children_max }.
  Let MesiInfoK := Struct MesiInfo.

  Variables indexSz lgWay edirLgWay: nat.

  Definition MesiInfoRead := InfoRead MesiInfoK indexSz hcfg_addr_sz lgWay edirLgWay.
  Let MesiInfoReadK := Struct MesiInfoRead.

  Definition mesi_compile_info_to_ostVars
             (var: Kind -> Type) (pinfo: var MesiInfoK)
             (cont: HVector.hvec (Vector.map (fun hty => var (kind_of hty)) hostf_ty) ->
                    ActionT var Void): ActionT var Void :=
    (LET value <- $$Default;
    LET owned <- #pinfo!MesiInfo@."mesi_owned";
    LET status: KMesi <- #pinfo!MesiInfo@."mesi_status";
    LET dir <- STRUCT { "dir_st" ::=
                          (IF (#pinfo!MesiInfo@."mesi_dir_st" == mesiNP)
                           then mesiI else #pinfo!MesiInfo@."mesi_dir_st");
                        "dir_excl" ::= bvFirstSet (#pinfo!MesiInfo@."mesi_dir_sharers");
                        "dir_sharers" ::= #pinfo!MesiInfo@."mesi_dir_sharers" };
    cont (value, (owned, (status, (dir, tt)))))%kami_action.

  Definition mesi_compile_value_read_to_ostVars
             (var: Kind -> Type)
             (ostVars: HVector.hvec (Vector.map (fun hty => var (kind_of hty)) hostf_ty))
             (rval: var KValue)
    : HVector.hvec (Vector.map (fun hty => var (kind_of hty)) hostf_ty) :=
    HVector.hvec_upd ostVars Mesi.val rval.

  Definition MesiLineWrite := LineWrite lgWay edirLgWay MesiInfoK.
  Let MesiLineWriteK := Struct MesiLineWrite.

  Definition mesi_compile_line_update
             (var: Kind -> Type) (line: var MesiLineWriteK)
             i ht (Heq: Vector.nth hostf_ty i = ht)
             (ve: Expr var (SyntaxKind (kind_of ht))): Expr var (SyntaxKind MesiLineWriteK).
  Proof.
    subst ht.
    refine (if Fin.eq_dec i Mesi.val then _
            else if Fin.eq_dec i Mesi.owned then _
                 else if Fin.eq_dec i Mesi.status then _
                      else if Fin.eq_dec i Mesi.dir then _
                           else ($$Default)%kami_expr); subst i.
    - exact (STRUCT { "addr" ::= #line!MesiLineWrite@."addr";
                      "info_write" ::= #line!MesiLineWrite@."info_write";
                      "info_hit" ::= #line!MesiLineWrite@."info_hit";
                      "info_way" ::= #line!MesiLineWrite@."info_way";
                      "edir_hit" ::= #line!MesiLineWrite@."edir_hit";
                      "edir_way" ::= #line!MesiLineWrite@."edir_way";
                      "edir_slot" ::= #line!MesiLineWrite@."edir_slot";
                      "info" ::= #line!MesiLineWrite@."info";
                      "value_write" ::= $$true;
                      "value" ::= ve;
                      "may_victim" ::= #line!MesiLineWrite@."may_victim";
                      "reps" ::= #line!MesiLineWrite@."reps" })%kami_expr.
    - exact (STRUCT { "addr" ::= #line!MesiLineWrite@."addr";
                      "info_write" ::= $$true;
                      "info_hit" ::= #line!MesiLineWrite@."info_hit";
                      "info_way" ::= #line!MesiLineWrite@."info_way";
                      "edir_hit" ::= #line!MesiLineWrite@."edir_hit";
                      "edir_way" ::= #line!MesiLineWrite@."edir_way";
                      "edir_slot" ::= #line!MesiLineWrite@."edir_slot";
                      "info" ::= updStruct (#line!MesiLineWrite@."info")%kami_expr
                                           (MesiInfo!!"mesi_owned")
                                           ve;
                      "value_write" ::= #line!MesiLineWrite@."value_write";
                      "value" ::= #line!MesiLineWrite@."value";
                      "may_victim" ::= #line!MesiLineWrite@."may_victim";
                      "reps" ::= #line!MesiLineWrite@."reps" })%kami_expr.
    - exact (STRUCT { "addr" ::= #line!MesiLineWrite@."addr";
                      "info_write" ::= $$true;
                      "info_hit" ::= #line!MesiLineWrite@."info_hit";
                      "info_way" ::= #line!MesiLineWrite@."info_way";
                      "edir_hit" ::= #line!MesiLineWrite@."edir_hit";
                      "edir_way" ::= #line!MesiLineWrite@."edir_way";
                      "edir_slot" ::= #line!MesiLineWrite@."edir_slot";
                      "info" ::= updStruct (#line!MesiLineWrite@."info")%kami_expr
                                           (MesiInfo!!"mesi_status")
                                           ve;
                      "value_write" ::= #line!MesiLineWrite@."value_write";
                      "value" ::= #line!MesiLineWrite@."value";
                      "may_victim" ::= #line!MesiLineWrite@."may_victim";
                      "reps" ::= #line!MesiLineWrite@."reps" })%kami_expr.
    - exact (STRUCT { "addr" ::= #line!MesiLineWrite@."addr";
                      "info_write" ::= $$true;
                      "info_hit" ::= #line!MesiLineWrite@."info_hit";
                      "info_way" ::= #line!MesiLineWrite@."info_way";
                      "edir_hit" ::= #line!MesiLineWrite@."edir_hit";
                      "edir_way" ::= #line!MesiLineWrite@."edir_way";
                      "edir_slot" ::= #line!MesiLineWrite@."edir_slot";
                      "info" ::=
                        STRUCT { "mesi_owned" ::= #line!MesiLineWrite@."info"!MesiInfo@."mesi_owned";
                                 "mesi_status" ::= #line!MesiLineWrite@."info"!MesiInfo@."mesi_status";
                                 "mesi_dir_st" ::= ve!KDir@."dir_st";
                                 "mesi_dir_sharers" ::=
                                   (IF (ve!KDir@."dir_st" == mesiS)
                                    then (ve!KDir@."dir_sharers")
                                    else (bvSingleton _ (ve!KDir@."dir_excl"))) };
                      "value_write" ::= #line!MesiLineWrite@."value_write";
                      "value" ::= #line!MesiLineWrite@."value";
                      "may_victim" ::= #line!MesiLineWrite@."may_victim";
                      "reps" ::= #line!MesiLineWrite@."reps" })%kami_expr.
  Defined.

  Instance MesiCompLineRW: CompLineRW lgWay edirLgWay :=
    {| infoK := MesiInfoK;
       invRsId := idx_to_word hcfg_msg_id_sz Mesi.mesiInvRs;
       compile_info_to_ostVars := mesi_compile_info_to_ostVars;
       compile_value_read_to_ostVars := mesi_compile_value_read_to_ostVars;
       compile_line_update := mesi_compile_line_update |}.

End Instances.

Require Import Hemiola.Ex.TopoTemplate.

Section Cache.
  Context `{TopoConfig}.
  Variables (oidx: IdxT)
            (indexSz lgWay edirLgWay predNumVictims: nat).

  Definition BitsPerByte := 8.
  Definition offsetSz := Nat.log2 (Nat.div hcfg_addr_sz BitsPerByte) + hcfg_line_values_lg.
  Definition tagSz := hcfg_addr_sz - indexSz - offsetSz.

  Definition getIndexE (var: Kind -> Type)
             (addr: Expr var (SyntaxKind (Bit (offsetSz + indexSz + tagSz))))
    : Expr var (SyntaxKind (Bit indexSz)) :=
    (UniBit (ConstExtract _ _ _) addr)%kami_expr.

  Definition getIndex (var: Kind -> Type)
             (addr: fullType var (SyntaxKind (Bit (offsetSz + indexSz + tagSz))))
    : Expr var (SyntaxKind (Bit indexSz)) :=
    getIndexE (#addr)%kami_expr.

  Definition getTag (var: Kind -> Type)
             (addr: fullType var (SyntaxKind (Bit (offsetSz + indexSz + tagSz))))
    : Expr var (SyntaxKind (Bit tagSz)) :=
    (_truncLsb_ #addr)%kami_expr.

  Definition buildAddr (var: Kind -> Type)
             (tag: fullType var (SyntaxKind (Bit tagSz)))
             (index: fullType var (SyntaxKind (Bit indexSz)))
    : Expr var (SyntaxKind (Bit (offsetSz + indexSz + tagSz))) :=
    {#tag, {#index, $0}}%kami_expr.

  Definition mshrConflictF (var: Kind -> Type)
             (addr1 addr2: Expr var (SyntaxKind (Bit (offsetSz + indexSz + tagSz))))
    : Expr var (SyntaxKind Bool) :=
    (addr1 != addr2 && getIndexE addr1 == getIndexE addr2)%kami_expr.

  Definition MesiEDir :=
    STRUCT { "mesi_edir_owned" :: Bool;
             "mesi_edir_st" :: KMesi;
             "mesi_edir_sharers" :: Bit hcfg_children_max }.
  Let MesiEDirK := Struct MesiEDir.

  Definition edirToInfo (var: Kind -> Type)
             (edir: fullType var (SyntaxKind MesiEDirK))
    : Expr var (SyntaxKind (Struct MesiInfo)) :=
    (STRUCT { "mesi_owned" ::= #edir!MesiEDir@."mesi_edir_owned";
              "mesi_status" ::= mesiI;
              "mesi_dir_st" ::= #edir!MesiEDir@."mesi_edir_st";
              "mesi_dir_sharers" ::= #edir!MesiEDir@."mesi_edir_status" })%kami_expr.

  Definition edirFromInfo (var: Kind -> Type)
             (pinfo: fullType var (SyntaxKind (Struct MesiInfo)))
    : Expr var (SyntaxKind MesiEDirK) :=
    (STRUCT { "mesi_edir_owned" ::= #pinfo!MesiInfo@."mesi_owned";
              "mesi_edir_st" ::= #pinfo!MesiInfo@."mesi_dir_st";
              "mesi_edir_sharers" ::= #pinfo!MesiInfo@."mesi_dir_sharers" })%kami_expr.

  Definition isJustDir (var: Kind -> Type)
             (pinfo: fullType var (SyntaxKind (Struct MesiInfo)))
    : Expr var (SyntaxKind Bool) :=
    ((#pinfo!MesiInfo@."mesi_status" <= mesiI) &&
     (#pinfo!MesiInfo@."mesi_dir_st" != mesiE))%kami_expr.

  Definition isDirInvalid (var: Kind -> Type)
             (pinfo: fullType var (SyntaxKind (Struct MesiInfo)))
    : Expr var (SyntaxKind Bool) :=
    (#pinfo!MesiInfo@."mesi_dir_st" <= mesiI)%kami_expr.

  Definition edirEmptySlot (var: Kind -> Type)
             (edir: Expr var (SyntaxKind MesiEDirK))
    : Expr var (SyntaxKind Bool) :=
    (edir!MesiEDir@."mesi_edir_st" <= mesiI)%kami_expr.

  Definition mesiInfoInit: ConstT (Struct MesiInfo) :=
    (CSTRUCT { "mesi_owned" ::= ConstBool false;
               "mesi_status" ::= ConstBit $1;
               "mesi_dir_st" ::= ConstBit $1;
               "mesi_dir_sharers" ::= ConstBit $0 })%init.

  Definition mesiEDirInit: ConstT MesiEDirK :=
    (CSTRUCT { "mesi_edir_owned" ::= ConstBool false;
               "mesi_edir_st" ::= ConstBit $1;
               "mesi_edir_sharers" ::= ConstBit $0 })%init.

  Definition mesiL1: Modules :=
    cache oidx KValue lgWay 0
          mesiInfoInit getIndex getTag buildAddr isDirInvalid predNumVictims.

  Definition mesiLi: Modules :=
    ncid oidx KValue lgWay edirLgWay
         mesiInfoInit mesiEDirInit
         getIndex getTag buildAddr edirToInfo edirFromInfo isJustDir isDirInvalid edirEmptySlot
         predNumVictims.

End Cache.