Require Import Bool Vector List String Peano_dec Lia.
Require Import Common FMap HVector IndexSupport Topology Syntax Semantics StepM SemFacts.
Require Import RqRsTopo RqRsUtil.

Require Import Ex.SpecInds Ex.Template Ex.RuleTransform Ex.RuleTransformOk.
Require Import Ex.Msi.Msi Ex.Msi.MsiTopo Ex.Msi.MsiImp Ex.Msi.MsiSim.

Set Implicit Arguments.

Local Open Scope list.
Local Open Scope hvec.
Local Open Scope fmap.

Section MsiImpOk.
  Variable (tr: tree).
  Hypothesis (Htr: tr <> Node nil).
  Let topo := fst (tree2Topo tr 0).
  Let cifc := snd (tree2Topo tr 0).

  Lemma msi_ImplRules: ImplRules tr (MsiImp.impl Htr) (Msi.impl Htr).
  Proof.
    red; intros.
    destruct H; [subst|apply in_app_or in H; destruct H].

    - (** Main memory *)
      eexists; repeat split; [left; reflexivity|].
      red; simpl; intros.
      left; split; [|assumption].
      unfold memRulesFromChildren in H.
      apply concat_In in H; dest.
      apply in_map_iff in H; dest; subst.
      dest_in.
      all: apply immDownRule_RssEquivRule; red; simpl; auto.

    - (** Li cache *)
      apply in_map_iff in H; destruct H as [oidx [? ?]]; subst; simpl in *.
      eexists; repeat split;
        [right; apply in_or_app; left;
         apply in_map_iff; eexists; repeat split; eassumption
        |reflexivity|].

      red; intros.
      apply in_app_or in H; destruct H.

      + apply concat_In in H; destruct H as [crls [? ?]].
        apply in_map_iff in H; destruct H as [cidx [? ?]]; subst.
        pose proof (subtreeChildrenIndsOf_parentIdxOf
                      (tree2Topo_WfDTree tr 0) _ _ H2) as Hp.
        dest_in.

        Ltac li_cidx_RssEquivRule equiv_thm cidx :=
          left; split;
          [apply equiv_thm; red; simpl; auto; fail
          |apply in_or_app; left;
           apply in_concat;
           eexists; split;
           [apply in_map_iff; exists cidx; split; [reflexivity|assumption]
           |simpl; tauto]].

        all: try (li_cidx_RssEquivRule immDownRule_RssEquivRule cidx).
        all: try (li_cidx_RssEquivRule rqUpUpRule_RssEquivRule cidx).
        all: try (li_cidx_RssEquivRule rqUpDownRule_RssEquivRule cidx).
        all: try (right; right; right; repeat eexists; assumption).

      + dest_in.

        Ltac li_RssEquivRule equiv_thm :=
          left; split;
          [apply equiv_thm; red; simpl; auto; fail
          |apply in_or_app; right; simpl; tauto].

        all: try (li_RssEquivRule immRule_RssEquivRule).
        all: try (li_RssEquivRule immUpRule_RssEquivRule).
        all: try (li_RssEquivRule rqUpUpRuleS_RssEquivRule).
        all: try (li_RssEquivRule rqDownDownRule_RssEquivRule).
        all: try (li_RssEquivRule rsDownDownRule_RssEquivRule).
        all: try (li_RssEquivRule rsDownDownRuleS_RssEquivRule).
        all: try (right; left; repeat eexists;
                  apply in_or_app; right; simpl; tauto).
        all: try (right; right; left; repeat eexists;
                  apply in_or_app; right; simpl; tauto).

        * left; split.
          { apply rsDownDownRule_RssEquivRule.
            red; unfold getUpLockIdxBackI, getUpLockIdxBack; simpl; intros.
            red in H1; dest.
            congruence.
          }
          { apply in_or_app; right; simpl; tauto. }
        * left; split.
          { apply rsDownRqDownRule_RssEquivRule.
            red; unfold RsDownRqDownSoundPrec, getUpLockIdxBackI, getUpLockIdxBack; simpl; intros.
            red in H1; dest.
            rewrite <-H1.
            repeat split; assumption.
          }
          { apply in_or_app; right; simpl; tauto. }

    - (** L1 cache *)
      apply in_map_iff in H; destruct H as [oidx [? ?]]; subst.
      eexists; repeat split;
        [right; apply in_or_app; right;
         apply in_map_iff; eexists; repeat split; assumption|].
      red; intros.
      dest_in.

      Ltac l1_RssEquivRule equiv_thm :=
        left; split;
        [apply equiv_thm; red; simpl; auto; fail
        |simpl; tauto].

      all: try (l1_RssEquivRule immUpRule_RssEquivRule).
      all: try (l1_RssEquivRule immDownRule_RssEquivRule).
      all: try (l1_RssEquivRule rqUpUpRule_RssEquivRule).
      all: try (l1_RssEquivRule rqUpUpRuleS_RssEquivRule).
      all: try (l1_RssEquivRule rsDownDownRule_RssEquivRule).
      all: try (l1_RssEquivRule rsDownDownRuleS_RssEquivRule).
  Qed.

  Lemma msi_imp_msi_ok:
    (steps step_m) # (steps step_m) |-- (MsiImp.impl Htr) ⊑ (Msi.impl Htr).
  Proof.
    apply rss_holder_ok with (tr:= tr); try reflexivity.
    - apply msi_ImplRules.
    - simpl; rewrite !map_app, !map_map, !map_id.
      rewrite app_comm_cons.
      rewrite <-c_li_indices_head_rootOf by assumption.
      reflexivity.
    - apply msi_GoodRqRsSys.
    - apply msi_GoodExtRssSys.
  Qed.

  Local Definition spec :=
    @SpecInds.spec (c_l1_indices cifc) (tree2Topo_l1_NoPrefix tr 0).

  Theorem msi_imp_ok:
    (steps step_m) # (steps step_m) |-- (MsiImp.impl Htr) ⊑ spec.
  Proof.
    eapply refines_trans.
    - apply msi_imp_msi_ok.
    - apply MsiSim.msi_ok.
  Qed.

End MsiImpOk.


Require Import extraction.
Require Import syntax lang Integers.
Open Scope hdl_type_scope.
Open Scope hdl_exp_scope.
Open Scope hdl_stmt_scope.

Definition m : interp_ty (tarr 16<<<tvec32>>>).
  refine (arr_init _ _).
  apply (Int.repr 0).
  intros.
  inversion H.
  apply (Int.repr (Z_of_nat' n)).
  apply (Int.repr (Z_of_nat' n)).
  Defined.

Definition loop : prog.
  (* refine (@ADecl Output 64 TVec32 "w" _ ). *)
  refine (@ADecl Input 16 TVec32 "m" _).
  refine (Output vec "x" ::== Int.repr 0;;; _).
  refine (syntax.iter 0 16 (fun i => _ )).
  refine (SAssign Blocking "x" _ ).
  refine ((EBinop OAdd (EVar "x") _)).
  refine (EDeref _ _).
  exact i.
  apply ("m").
Defined.

Definition loop_print_tb : verilog :=
  pretty_print_tb_results "looper" "380" loop.
(* Definition loop_print : verilog :=  *)
(*   pretty_print "looper" loop. *)

Extract Constant main => "Prelude.putStrLn loop_print_tb".

Extraction "looper.hs" loop_print_tb main.


From iris.algebra Require Import excl auth gmap agree gset.
From iris.heap_lang Require Export lifting notation locations lang.
From iris.base_logic.lib Require Export invariants.
From iris.program_logic Require Export atomic.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation par.
From iris.bi.lib Require Import fractional.
From iris.bi Require Import derived_laws_sbi.
Set Default Proof Using "Type*".

Definition lockNode : val :=
  rec: "lockN" "y" :=
    if: CAS "y" #false #true
    then #()
    else "lockN" "y".

Definition unlockNode : val :=
  λ: "y",
  "y" <- #false.

Definition prog : val :=
  λ: "x" "y" "v",
  lockNode "y";;
  "x" <- "v";;
  unlockNode "y";; "v".

Section Toy_Template.
  Context `{!heapG Σ} (N : namespace).
  Notation iProp := (iProp Σ).

  (* We should be able to prove the following specs: *)

  Lemma lock_spec (y: loc) :
    <<< ∀ (b: bool), y ↦ #b >>>
        lockNode #y @ ⊤
    <<< y ↦ #true ∗ if b then False else True, RET #() >>>.
  Proof.
    iIntros (Φ) "HP". iLöb as "IH".
    rewrite /lockNode.
    wp_pures.
    wp_apply (aacc_aupd_commit with "IH"). first done.
    awp_apply "IH".
    awp_apply "HP".
    iPoseProof (aupd_aacc with "HP") as "AC".
    wp_cmpxchg as H1 | H2.
    wp_cmpxchg.
    wp_apply . *)
  Admitted.

  Lemma unlock_spec (y: loc) :
    <<< y ↦ #true >>>
        unlockNode #y @ ⊤
    <<< y ↦ #false, RET #() >>>.
  Proof. Admitted.

  Definition is_locked_ref x y v : iProp :=
    (∃ (b: bool), y ↦ #b ∗ if b then True else x ↦ v)%I.

  Lemma prog_spec (x y: loc) (v: val) :
    <<< ∀ (u: val), is_locked_ref x y u >>>
        prog #x #y v @ ⊤
    <<< is_locked_ref x y v, RET #() >>>.
  Proof.
    unfold is_locked_ref.
    iIntros (Φ) "HP". iLöb as "IH".
    wp_lam. wp_pures. wp_bind (lockNode _)%E.
    wp_apply lock_spec.
    About atomic_update.
    SearchAbout atomic_update. (AU << _ >> @ _, _ << _ COMM >>).


(** Refinement rules for disjoint rules *)
Require Import Coq.omega.Omega.
Require Import Fiat.Parsers.Refinement.PreTactics.
Require Import Fiat.Computation.Refinements.General.
Require Import Fiat.Parsers.StringLike.LastCharSuchThat.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Parsers.ContextFreeGrammar.ValidReflective.
Require Import Fiat.Parsers.Refinement.DisjointLemmas.
Require Import Fiat.Parsers.Refinement.DisjointRulesCommon.
Require Import Fiat.Parsers.Refinement.PossibleTerminalsSets.
Require Import Fiat.Parsers.ParserInterface.
Require Import Fiat.Common.List.DisjointFacts.
Export DisjointLemmas.Exports.

Set Implicit Arguments.

Local Arguments minus !_ !_.

Lemma find_after_last_char_such_that'_short {Char HSLM HSL}
      str P len
  : @find_after_last_char_such_that' Char HSLM HSL P len str <= len.
Proof.
  revert str; induction len; simpl; intros; [ omega | ].
  destruct (get len str) eqn:H.
  { edestruct P; try omega.
    rewrite IHlen; omega. }
  { rewrite IHlen; omega. }
Qed.

Lemma find_after_last_char_such_that_short {Char HSLM HSL}
      str P
  : @find_after_last_char_such_that Char HSLM HSL str P <= length str.
Proof.
  apply find_after_last_char_such_that'_short.
Qed.

Lemma refine_find_after_last_char_such_that {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
      (str : String)
      (P : Char -> bool)
  : refine { n : nat | n <= length str
                       /\ ((exists n', is_after_last_char_such_that str n' P)
                           -> is_after_last_char_such_that str n P) }
           (ret (find_after_last_char_such_that str P)).
Proof.
  intros v H.
  computes_to_inv; subst.
  apply PickComputes.
  split; [ apply find_after_last_char_such_that_short | ].
  apply is_after_last_char_such_that__find_after_last_char_such_that.
Qed.

Section with_grammar.
  Context {HSLM : StringLikeMin Ascii.ascii}
          {HSL : StringLike Ascii.ascii}
          {HSI : StringIso Ascii.ascii}
          {HSLP : StringLikeProperties Ascii.ascii}
          {HSIP : StringIsoProperties Ascii.ascii}
          {G : pregrammar' Ascii.ascii}
          (pdata : possible_data G).

  Local Notation possible_terminals_of nt
    := (@all_possible_ascii_of_nt G pdata nt).
  Local Notation possible_terminals_of_production its
    := (@all_possible_ascii_of_production G pdata its).
  Local Notation possible_first_terminals_of_production its
    := (@possible_first_ascii_of_production G pdata its).
  Local Notation possible_last_terminals_of nt
    := (@possible_last_ascii_of_nt G pdata nt).

  Definition rev_search_for_condition
             str nt (n : nat)
    := is_after_last_char_such_that
         str
         n
         (fun ch => list_bin ascii_beq ch (possible_last_terminals_of nt)).

  Lemma refine_disjoint_rev_search_for'
        {str offset len nt its}
        (H_disjoint : disjoint ascii_beq
                               (possible_last_terminals_of nt)
                               (possible_terminals_of_production its))
    : refine {splits : list nat
             | split_list_is_complete
                 G str offset len
                 (NonTerminal nt::its) splits}
             (n <- { n : nat | n <= length (substring offset len str)
                               /\ ((exists n', rev_search_for_condition (substring offset len str) nt n')
                                   -> rev_search_for_condition (substring offset len str) nt n) };
                ret [n]).
  Proof.
    intros ls H.
    computes_to_inv; subst.
    destruct H as [H0 H1].
    apply PickComputes.
    hnf; cbv zeta.
    intros Hlen it' its' Heq n ? H_reachable pit pits.
    inversion Heq; subst it' its'; clear Heq.
    left.
    pose proof (terminals_disjoint_rev_search_for _ _ H_disjoint pit pits H_reachable) as H'.
    specialize (H1 (ex_intro _ n H')).
    unfold rev_search_for_condition in H1.
    pose proof (is_after_last_char_such_that_eq_nat_iff H1 H') as H''.
    destruct_head or; destruct_head and; subst;
      rewrite ?Min.min_r, ?Min.min_l by assumption;
      omega.
  Qed.

  Definition rev_search_for_not_condition
             str its n
    := is_after_last_char_such_that
         str
         n
         (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of_production its))).

  Lemma refine_disjoint_rev_search_for_not'
        {str offset len nt its}
        (H_disjoint : disjoint ascii_beq
                               (possible_last_terminals_of nt)
                               (possible_terminals_of_production its))
    : refine {splits : list nat
             | split_list_is_complete
                 G str offset len
                 (NonTerminal nt::its)
                 splits}
             (n <- { n : nat | n <= length (substring offset len str)
                               /\ ((exists n', rev_search_for_not_condition (substring offset len str) its n')
                                   -> rev_search_for_not_condition (substring offset len str) its n) };
                ret [n]).
  Proof.
    intros ls H.
    computes_to_inv; subst.
    destruct H as [H0 H1].
    apply PickComputes.
    hnf; cbv zeta.
    intros Hlen it' its' Heq n ? H_reachable pit pits.
    inversion Heq; subst it' its'; clear Heq.
    left.
    pose proof (terminals_disjoint_rev_search_for_not _ _ H_disjoint pit pits H_reachable) as H'.
    specialize (H1 (ex_intro _ n H')).
    pose proof (is_after_last_char_such_that_eq_nat_iff H1 H') as H''.
    destruct_head or; destruct_head and; subst;
      rewrite ?Min.min_r by assumption;
      omega.
  Qed.

  Lemma refine_disjoint_rev_search_for
        {str offset len nt its}
        (H_disjoint : disjoint ascii_beq
                               (possible_last_terminals_of nt)
                               (possible_terminals_of_production its))
    : refine {splits : list nat
             | split_list_is_complete
                 G str offset len
                 (NonTerminal nt::its)
                 splits}
             (ret [find_after_last_char_such_that (substring offset len str) (fun ch => list_bin ascii_beq ch (possible_last_terminals_of nt))]).
  Proof.
    rewrite refine_disjoint_rev_search_for' by assumption.
    setoid_rewrite refine_find_after_last_char_such_that.
    simplify with monad laws; reflexivity.
  Qed.

  Lemma refine_disjoint_rev_search_for_not
        {str offset len nt its}
        (H_disjoint : disjoint ascii_beq
                               (possible_last_terminals_of nt)
                               (possible_terminals_of_production its))
    : refine {splits : list nat
             | split_list_is_complete
                 G str offset len
                 (NonTerminal nt::its)
                 splits}
             (ret [find_after_last_char_such_that (substring offset len str) (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of_production its)))]).
  Proof.
    rewrite refine_disjoint_rev_search_for_not' by assumption.
    setoid_rewrite refine_find_after_last_char_such_that.
    simplify with monad laws; reflexivity.
  Qed.

  Lemma refine_disjoint_rev_search_for_idx
        {str offset len nt its idx}
        (Heq : default_to_production (G := G) idx = NonTerminal nt :: its)
        (H_disjoint : disjoint ascii_beq
                               (possible_last_terminals_of nt)
                               (possible_terminals_of_production its))
    : refine {splits : list nat
             | split_list_is_complete_idx
                 G str offset len
                 idx
                 splits}
             (ret [find_after_last_char_such_that (substring offset len str) (fun ch => list_bin ascii_beq ch (possible_last_terminals_of nt))]).
  Proof.
    unfold split_list_is_complete_idx.
    erewrite <- refine_disjoint_rev_search_for by eassumption.
    rewrite Heq.
    apply refine_pick_pick; intro; trivial.
  Qed.

  Lemma refine_disjoint_rev_search_for_not_idx
        {str offset len nt its idx}
        (Heq : default_to_production (G := G) idx = NonTerminal nt :: its)
        (H_disjoint : disjoint ascii_beq
                               (possible_last_terminals_of nt)
                               (possible_terminals_of_production its))
    : refine {splits : list nat
             | split_list_is_complete_idx
                 G str offset len
                 idx
                 splits}
             (ret [find_after_last_char_such_that (substring offset len str) (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of_production its)))]).
  Proof.
    unfold split_list_is_complete_idx.
    erewrite <- refine_disjoint_rev_search_for_not by eassumption.
    rewrite Heq.
    apply refine_pick_pick; intro; trivial.
  Qed.
End with_grammar.

Ltac solve_disjoint_side_conditions :=
  idtac;
  lazymatch goal with
  | [ |- Carriers.default_to_production (G := ?G) ?k = ?e ]
    => cbv -[Equality.ascii_beq orb andb BinNat.N.leb Reflective.opt.N_of_ascii];
       try reflexivity
  | [ |- is_true (Operations.List.disjoint _ _ _) ]
    => vm_compute; try reflexivity
  end.

Ltac pose_disjoint_rev_search_for lem :=
  idtac;
  lazymatch goal with
  | [ HSLP : @StringLikeProperties _ ?HSLM ?HSL, pdata : possible_data ?G
      |- context[@ParserInterface.split_list_is_complete_idx ?Char ?G ?HSLM ?HSL ?str ?offset ?len ?idx] ]
    => pose proof (fun idx' nt its => @refine_disjoint_rev_search_for_idx HSLM HSL HSLP G pdata str offset len nt its idx') as lem
  end.
Ltac replace_with_native_compute_in c H :=
  let c' := (eval native_compute in c) in
  (* By constrast [set ... in ...] seems faster than [change .. with ... in ...] in 8.4?! *)
  replace c with c' in H by (clear; native_cast_no_check (eq_refl c')).

Ltac rewrite_once_disjoint_rev_search_for_specialize alt_side_condition_tac lem lem' :=
  idtac;
  let G := (lazymatch goal with
             | [ |- context[ParserInterface.split_list_is_complete_idx ?G ?str ?offset ?len ?idx] ]
               => G
             end) in
  match goal with
  | [ |- context[ParserInterface.split_list_is_complete_idx G ?str ?offset ?len ?idx] ]
    => pose proof (lem idx) as lem';
       do 2 (lazymatch type of lem' with
              | forall a : ?T, _ => idtac; let x := fresh in evar (x : T); specialize (lem' x); subst x
              end);
       let T := match type of lem' with forall a : ?T, _ => T end in
       let H' := fresh in
       assert (H' : T) by solve [ solve_disjoint_side_conditions | alt_side_condition_tac () ];
       specialize (lem' H'); clear H';
       cbv beta delta [id
                         all_possible_ascii_of_nt all_possible_ascii_of_production
                         possible_first_ascii_of_nt possible_first_ascii_of_production
                         possible_last_ascii_of_nt possible_last_ascii_of_production] in lem';
       do 2 (let x := match type of lem' with
                      | context[characters_set_to_ascii_list ?ls]
                        => constr:(characters_set_to_ascii_list ls)
                      end in
             replace_with_vm_compute_in x lem');
       unfold Equality.list_bin in lem';
       change (orb false) with (fun bv : bool => bv) in lem';
       cbv beta in lem';
       let T := match type of lem' with forall a : ?T, _ => T end in
       let H' := fresh in
       assert (H' : T) by solve [ solve_disjoint_side_conditions | alt_side_condition_tac () ];
       specialize (lem' H'); clear H'
  end.
Ltac rewrite_once_disjoint_rev_search_for alt_side_condition_tac lem :=
  let lem' := fresh "lem'" in
  rewrite_once_disjoint_rev_search_for_specialize alt_side_condition_tac lem lem';
  setoid_rewrite lem'; clear lem'.
Ltac rewrite_disjoint_rev_search_for_no_clear alt_side_condition_tac lem :=
  pose_disjoint_rev_search_for lem;
  progress repeat rewrite_once_disjoint_rev_search_for alt_side_condition_tac lem.
Ltac rewrite_disjoint_rev_search_for_with_alt alt_side_condition_tac :=
  idtac;
  let lem := fresh "lem" in
  rewrite_disjoint_rev_search_for_no_clear alt_side_condition_tac lem;
  clear lem.
Ltac leave_side_conditions _ :=
  try rewrite disjoint_uniquize by auto using Equality.ascii_bl, Equality.ascii_lb;
  shelve.
Ltac rewrite_disjoint_rev_search_for_leaving_side_conditions :=
  unshelve rewrite_disjoint_rev_search_for_with_alt leave_side_conditions.
Ltac rewrite_disjoint_rev_search_for :=
  rewrite_disjoint_rev_search_for_with_alt ltac:(fun _ => fail).
Ltac refine_disjoint_rev_search_for_with_alt alt_side_condition_tac :=
  idtac;
  let lem := fresh "lem" in
  pose_disjoint_rev_search_for lem;
  let lem' := fresh "lem'" in
  rewrite_once_disjoint_rev_search_for_specialize alt_side_condition_tac lem lem';
  refine lem'; clear lem'.
Ltac refine_disjoint_rev_search_for_leaving_side_conditions :=
  unshelve refine_disjoint_rev_search_for_with_alt leave_side_conditions.
Ltac refine_disjoint_rev_search_for :=
  refine_disjoint_rev_search_for_with_alt ltac:(fun _ => fail).