From RecordUpdate Require Import RecordSet.

From Perennial.program_proof Require Import disk_lib.
From Perennial.program_proof Require Import wal.invariant wal.common_proof.

Section goose_lang.
Context `{!heapGS Σ}.
Context `{!walG Σ}.

Implicit Types (v:val) (z:Z).
Implicit Types (γ: wal_names).
Implicit Types (s: log_state.t) (memLog: list update.t) (txns: list (u64 * list update.t)).
Implicit Types (pos: u64) (txn_id: nat).

Context (P: log_state.t -> iProp Σ).
Let N := walN.
Let innerN := walN .@ "wal".
Let circN := walN .@ "circ".

Theorem wal_wf_update_durable :
  relation.wf_preserved (update_durable) wal_wf.
Proof.
  intros s1 s2 [] Hwf ?; simpl in *; monad_inv.
  destruct Hwf as (Hwf1&Hwf2&Hwf3).
  destruct s1; split; unfold log_state.updates in *; simpl in *; eauto.
  split; eauto.
  lia.
Qed.

(* just an example, to work out the Flush proof without all the complications *)
Theorem wp_updateDurable (Q: iProp Σ) l γ dinit :
  {{{ is_wal P l γ dinit ∗
       (∀ σ σ' b,
         ⌜wal_wf σ⌝ -∗
         ⌜relation.denote (update_durable) σ σ' b⌝ -∗
         (P σ ={⊤ ∖ ↑N}=∗ P σ' ∗ Q))
   }}}
    Skip
  {{{ RET #(); Q}}}.
Proof.
  iIntros (Φ) "[#Hwal Hfupd] HΦ".
  iDestruct "Hwal" as "[Hwal Hcirc]".
  iInv "Hwal" as "Hinv".
  wp_call.
  iDestruct "Hinv" as (σ) "(Hinner&HP)".
  iNamed "Hinner".
  iNamed "Hdisk".
  iNamed "Hdisk".
  iNamed "circ.end".
  pose proof (is_txn_bound _ _ _ Hend_txn) as Hend_bound.
  iMod (fupd_mask_subseteq (⊤ ∖ ↑N)) as "HinnerN"; first by solve_ndisj.
  iMod ("Hfupd" $! σ (set log_state.durable_lb (λ _, (σ.(log_state.durable_lb) `max` diskEnd_txn_id)%nat) σ)
          with "[% //] [%] [$HP]") as "[HP HQ]".
  { simpl.
    econstructor; monad_simpl.
    econstructor; monad_simpl; lia. }
  iMod "HinnerN" as "_".
  iSpecialize ("HΦ" with "HQ").
  iFrame "HΦ".
  iIntros "!> !>".
  iExists _; iFrame "HP".
  iSplit.
  - iPureIntro.
    eapply wal_wf_update_durable; eauto.
    { simpl; monad_simpl.
      econstructor; monad_simpl.
      econstructor; monad_simpl; lia. }
  - simpl.
    iFrame.
    iExists _. iFrame "Howncs".
    iExists installed_txn_id, _, _. simpl. iFrame "# ∗ %".
    iExists _, diskEnd_txn_id.
    rewrite (Nat.max_l (_ `max` _)%nat _); last by lia.
    iFrame "# %".
    iPureIntro.
    split; first by lia.
    split; first by lia.
    destruct (decide (σ.(log_state.durable_lb) ≤ diskEnd_txn_id)).
    {
      rewrite Nat.max_r; last by lia.
      rewrite subslice_zero_length.
      apply Forall_nil_2.
    }
    rewrite Nat.max_l; last by lia.
    rewrite -(subslice_app_contig _ (S diskEnd_txn_id)) in Hdurable_nils;
      last by lia.
    apply Forall_app in Hdurable_nils.
    intuition.
Qed.

Theorem simulate_flush l γ Q σ dinit pos txn_id nextDiskEnd_txn_id mutable :
  is_circular circN (circular_pred γ) γ.(circ_name) -∗
  (is_wal_inner l γ σ dinit ∗ P σ) -∗
  diskEnd_at_least γ.(circ_name) (int.Z pos) -∗
  txn_pos γ txn_id pos -∗
  memLog_linv_nextDiskEnd_txn_id γ mutable nextDiskEnd_txn_id -∗
  (∀ (σ σ' : log_state.t) (b : ()),
      ⌜wal_wf σ⌝
        -∗ ⌜relation.denote (log_flush pos txn_id) σ σ' b⌝ -∗ P σ ={⊤ ∖ ↑N}=∗ P σ' ∗ Q) -∗
  |NC={⊤ ∖ ↑innerN}=>
    ∃ σ' nextDiskEnd_txn_id',
      is_wal_inner l γ σ' dinit ∗ P σ' ∗ Q ∗
      memLog_linv_nextDiskEnd_txn_id γ mutable nextDiskEnd_txn_id' ∗
      ⌜nextDiskEnd_txn_id ≤ nextDiskEnd_txn_id' < length σ.(log_state.txns)⌝ ∗
      ⌜Forall (λ x, x.2 = []) (
        subslice (S nextDiskEnd_txn_id) (S nextDiskEnd_txn_id')
        σ.(log_state.txns)
      )⌝.
Proof.
  iIntros "#Hcirc Hinv #Hlb #Hpos_txn HstableSet Hfupd".
  iDestruct "Hinv" as "[Hinner HP]".
  iNamed "Hinner".
  iNamed "Hdisk".
  iNamed "Hdisk".
  iNamed "circ.end".
  iMod (is_circular_diskEnd_lb_agree with "Hlb Hcirc Howncs") as "(%Hlb&Howncs)"; first by solve_ndisj.
  iDestruct (txn_pos_valid_general with "Htxns_ctx Hpos_txn") as %His_txn.
  pose proof (is_txn_bound _ _ _ His_txn).
  pose proof (is_txn_bound _ _ _ Hend_txn).
  pose proof (wal_wf_txns_mono_pos Hwf His_txn Hend_txn) as Hpos_diskEnd.

  iMod (fupd_mask_subseteq (⊤ ∖ ↑N)) as "HinnerN"; first by solve_ndisj.
  iMod ("Hfupd" $!
    σ
    (
      set log_state.durable_lb (λ _,
        (diskEnd_txn_id `max` (σ.(log_state.durable_lb) `max` txn_id))%nat
      ) σ
    )
    with "[% //] [%] HP"
  ) as "[HP HQ]".
  { simpl; monad_simpl.
    repeat (econstructor; monad_simpl; eauto); lia.
  }
  iMod "HinnerN" as "_".
  iFrame "HQ".

  iAssert (⌜
    int.Z pos = int.Z diskEnd →
    Forall (λ x, x.2 = []) (
      subslice
        (S (σ.(log_state.durable_lb) `max` diskEnd_txn_id))
        (S txn_id)
        σ.(log_state.txns)
    )
  ⌝)%I with "[HstableSet HnextDiskEnd_inv]" as "%Hpos_diskEnd_nils".
  {
    iApply pure_impl_2.
    iIntros (Hpos_diskEnd_eq).
    apply word.unsigned_inj in Hpos_diskEnd_eq.
    rewrite Hpos_diskEnd_eq in His_txn.
    iPoseProof (subslice_stable_nils2 with "[HstableSet HnextDiskEnd_inv]")
      as "Hnils".
    1: eassumption.
    1: apply Hdurable_lb_pos.
    1: apply His_txn.
    {
      iSplit; first by iFrame.
      iFrame "#".
    }
    iFrame.
  }

  iAssert (|==>
    ⌜Forall (λ x, x.2 = []) (
      subslice
        (S diskEnd_txn_id)
        (S (diskEnd_txn_id `max` (txn_id)))
        σ.(log_state.txns)
    )⌝ ∗
    (diskEnd_txn_id `max` (txn_id))%nat
      [[γ.(stable_txn_ids_name)]]↦ro tt ∗
    nextDiskEnd_inv γ σ.(log_state.txns) ∗
    txns_ctx γ σ.(log_state.txns) ∗
    ∃ nextDiskEnd_txn_id',
      memLog_linv_nextDiskEnd_txn_id γ mutable nextDiskEnd_txn_id' ∗
      ⌜nextDiskEnd_txn_id ≤ nextDiskEnd_txn_id' < length σ.(log_state.txns)⌝ ∗
      ⌜Forall (λ x, x.2 = []) (
        subslice (S nextDiskEnd_txn_id) (S nextDiskEnd_txn_id')
        σ.(log_state.txns)
      )⌝
  )%I
    with "[HstableSet HnextDiskEnd_inv Htxns_ctx]"
    as "H".
  {
    destruct (decide (
      txn_id ≤ diskEnd_txn_id
    )%nat).
    { rewrite -> (max_l diskEnd_txn_id _) by lia.
      rewrite ?subslice_zero_length. iSplitR; first by done.

      iAssert (⌜nextDiskEnd_txn_id < length σ.(log_state.txns)⌝)%I as "%HnextDiskEnd_txn_bound".
      {
        iNamed "HstableSet".
        iDestruct (txn_pos_valid_general with "Htxns_ctx HnextDiskEnd_txn") as %HnextDiskEnd_txn_bound.
        eapply is_txn_bound in HnextDiskEnd_txn_bound. iPureIntro. lia.
      }

      iFrame "Hend_txn_stable".
      iFrame "HnextDiskEnd_inv".
      iFrame "Htxns_ctx".
      iExists nextDiskEnd_txn_id.
      rewrite ?subslice_zero_length.
      iFrame "HstableSet".
      iModIntro.
      iSplit; first by iPureIntro; lia.
      iPureIntro.
      eauto.
    }

    pose proof (wal_wf_txns_mono_pos Hwf His_txn Hend_txn).
    replace diskEnd with pos in * by word.

    iMod (stable_txn_id_advance _ _ _ txn_id
          with "HstableSet HnextDiskEnd_inv Hend_txn_stable Htxns_ctx")
      as "H"; eauto.
    { lia. }

    iDestruct "H" as "(#Hstable & HnextDiskEnd_inv & Htxns_ctx & H)".
    iDestruct "H" as (nextDiskEnd_txn_id') "(HstableSet & %Hle & %Hnils')".
    iModIntro.

    iSplit.
    {
      iDestruct (subslice_stable_nils with "[$HnextDiskEnd_inv $Hend_txn_stable]") as "%Hnils_txn".
      1: eassumption.
      2: eassumption.
      2: eapply His_txn.
      1: lia.
      iPureIntro.
      destruct (decide (diskEnd_txn_id ≤ txn_id)%nat).
      {
        rewrite Nat.max_r; last by lia.
        assumption.
      }
      rewrite Nat.max_l; last by lia.
      rewrite subslice_zero_length.
      apply Forall_nil_2.
    }

    iFrame "HnextDiskEnd_inv".
    iSplitR.
    {
      destruct (decide (diskEnd_txn_id ≤ txn_id)%nat).
      {
        rewrite (Nat.max_r _ txn_id); last by lia.
        iFrame "#".
      }
      rewrite (Nat.max_l _ txn_id); last by lia.
      iFrame "#".
    }
    iFrame "Htxns_ctx".
    iExists nextDiskEnd_txn_id'.
    iFrame "HstableSet".
    done.
  }

  iMod "H" as "(%Hnils & #Hstable & HnextDiskEnd_inv & Htxns_ctx & H)".
  iDestruct "H" as (nextDiskEnd_txn_id') "(HstableSet & %Hle & %Hnils')".

  iModIntro.
  iExists _, _; iFrame "HP".
  iFrame (Hle Hnils') "HstableSet".
  iSplit; auto.
  { iPureIntro.
    eapply wal_wf_update_durable; eauto.
    simpl; monad_simpl.
    repeat (econstructor; monad_simpl; eauto); lia.
  }
  simpl.
  iFrame.
  iExists _; iFrame.
  iExists installed_txn_id, _, _. iFrame "# ∗".
  iSplitL.
  2: {
    iPureIntro.
    auto with lia.
  }
  iExists _, diskEnd_txn_id.
  simpl.
  iSplit; first by (iPureIntro; lia).
  iSplit; first by (iPureIntro; lia).
  iSplit.
  {
    iPureIntro.
    destruct (decide (
      (diskEnd_txn_id `max` txn_id) ≤ σ.(log_state.durable_lb)
    )%nat).
    {
      rewrite Nat.max_r; last by lia.
      rewrite Nat.max_l; last by lia.
      destruct (decide (S diskEnd_txn_id ≤ txn_id)%nat).
      {
        rewrite Nat.max_r in Hnils; last by lia.
        rewrite -(subslice_app_contig _ (S diskEnd_txn_id)) in Hdurable_nils;
          last by lia.
        apply Forall_app in Hdurable_nils.
        intuition.
      }
      rewrite -(subslice_app_contig _ (S diskEnd_txn_id)) in Hdurable_nils;
        last by lia.
      apply Forall_app in Hdurable_nils.
      intuition.
    }
    replace (_ `max` (_ `max` _))%nat with (diskEnd_txn_id `max` txn_id)%nat
      by lia.
    assumption.
  }
  iSplit.
  {
    iPureIntro.
    destruct (decide (int.Z pos < int.Z diskEnd)) as [Hcmp|Hcmp].
    {
      apply Hpos_diskEnd in Hcmp.
      replace (_ `max` _)%nat
        with (σ.(log_state.durable_lb) `max` diskEnd_txn_id)%nat
        by lia.
      eassumption.
    }
    rewrite -HdiskEnd_val in Hlb.
    assert (int.Z pos = int.Z diskEnd) as Hpos_diskEnd_eq by lia.
    apply word.unsigned_inj in Hpos_diskEnd_eq.
    subst pos.
    rewrite Nat.max_l; last by lia.
    destruct (decide
      ((σ.(log_state.durable_lb) `max` diskEnd_txn_id) ≤ txn_id)%nat
    ).
    {
      rewrite Nat.max_r; last by lia.
      rewrite Nat.max_r; last by lia.
      assumption.
    }
    replace (_ `max` _)%nat
      with (σ.(log_state.durable_lb) `max` diskEnd_txn_id)%nat; last by lia.
    assumption.
  }
  iSplit; first by (iPureIntro; assumption).
  iSplit; first by (iPureIntro; assumption).
  destruct (decide (
    txn_id ≤ (σ.(log_state.durable_lb) `max` diskEnd_txn_id)
  )%nat).
  {
    replace ((_ `max` _) `max` _)%nat
      with (σ.(log_state.durable_lb) `max` diskEnd_txn_id)%nat;
      last by lia.
    iFrame "#".
  }
  replace ((_ `max` _) `max` _)%nat
    with (diskEnd_txn_id `max` txn_id)%nat; last by lia.
  iFrame "#".

  Unshelve.
  all: try constructor.
Qed.

(* this is a dumb memory safety proof for loading nextDiskEnd when its value
doesn't matter for correctness *)
Theorem wp_load_some_nextDiskEnd st γ :
  {{{ wal_linv st γ }}}
        struct.loadF sliding "mutable"
          (struct.loadF WalogState "memLog" #st)
  {{{ (nextDiskEnd:u64), RET #nextDiskEnd; wal_linv st γ }}}.
Proof.
  iIntros (Φ) "Hinv HΦ".
  iNamed "Hinv".
  iNamed "Hfields".
  iNamed "Hfield_ptsto".
  wp_loadField.
  (* this is very bad, breaks sliding abstraction boundary *)
  iNamed "His_memLog"; iNamed "Hinv". wp_loadField.
  iApply "HΦ".
  iExists _; iFrame "# ∗".
  iExists _; iFrame "# ∗".
  iSplit; auto.
  iSplit; auto.
  iExists _, _; iFrame "# ∗".
Qed.

Theorem wp_Walog__Flush (Q: iProp Σ) l γ dinit txn_id pos :
  {{{ is_wal P l γ dinit ∗
      txn_pos γ txn_id pos ∗
       (∀ σ σ' b,
         ⌜wal_wf σ⌝ -∗
         ⌜relation.denote (log_flush pos txn_id) σ σ' b⌝ -∗
         (P σ ={⊤ ∖ ↑N}=∗ P σ' ∗ Q))
   }}}
    Walog__Flush #l #pos
  {{{ RET #(); Q}}}.
Proof.
  iIntros (Φ) "(#Hwal & #Hpos_txn & Hfupd) HΦ".
  destruct_is_wal.

  wp_apply util_proof.wp_DPrintf.
  wp_loadField.
  wp_apply (acquire_spec with "lk"). iIntros "(Hlocked&Hlkinv)".
  wp_loadField.
  wp_apply (wp_condBroadcast with "cond_logger").
  wp_loadField.

  wp_apply (wp_load_some_nextDiskEnd with "Hlkinv"); iIntros (x) "Hlkinv".
  wp_pures.

  wp_apply (wp_If_optional with "[] [Hlkinv Hlocked]"); [ | iAccu | ].
  {
    iIntros (Φ') "(Hlkinv&Hlocked) HΦ".
    wp_loadField.
    wp_apply (wp_endGroupTxn with "Hlkinv").
    iIntros "Hlkinv".
    wp_pures.
    iApply ("HΦ" with "[$]").
  }
  iIntros "(Hlkinv&Hlocked)".
  wp_pures.

  wp_bind (For _ _ _).
  wp_apply (wp_forBreak_cond (λ b,
    wal_linv σₛ.(wal_st) γ ∗ locked #σₛ.(memLock) ∗
    if b then ⊤ else diskEnd_at_least γ.(circ_name) (int.Z pos)
  )%I with "[] [$Hlkinv $Hlocked]").
  { iIntros "!>" (Φ') "(Hlkinv&Hlocked&_) HΦ".
    wp_loadField.
    iNamed "Hlkinv".
    iNamed "Hfields".
    iNamed "Hfield_ptsto".
    wp_loadField.
    wp_pures.
    wp_if_destruct.
    - wp_loadField.
      wp_apply (wp_condWait with "[-HΦ $cond_logger $lk $Hlocked]").
      { iExists _; iFrame "∗ #".
        iExists _; by iFrame "∗ #". }
      iIntros "(Hlocked&Hlockin)".
      wp_pures.
      iApply "HΦ"; by iFrame.
    - iApply "HΦ".
      iFrame "Hlocked".
      iNamed "HdiskEnd_circ".
      iSplitL.
      { iExists _; iFrame "# ∗".
        iExists _; by iFrame "# ∗". }
      iApply (diskEnd_at_least_mono with "HdiskEnd_at_least"); auto.
  }

  iIntros "(Hlkinv&Hlocked&#HdiskEnd_lb)".
  wp_seq.
  wp_bind Skip.
  iDestruct "Hwal" as "[Hwal Hcirc]".
  iInv "Hwal" as "Hinv".
  iApply wp_ncfupd.
  wp_call.
  iDestruct "Hinv" as (σ) "[Hinner HP]".
  iNamed "Hlkinv".
  iNamed "HmemLog_linv".

  iAssert (⌜txns = σ.(log_state.txns)⌝)%I as "%Htxnseq".
  {
    iNamed "Hinner".
    iDestruct (ghost_var_agree with "Howntxns γtxns") as "%Htxnseq".
    done.
  }
  subst.

  iMod (simulate_flush with "Hcirc [$Hinner $HP] HdiskEnd_lb Hpos_txn HnextDiskEnd Hfupd") as "H".
  iDestruct "H" as (σ' nextDiskEnd_txn_id') "(Hinner & HP & HQ & HnextDiskEnd & %Hle & %Hnils)".
  iApply fupd_ncfupd. iApply fupd_intro.
  iModIntro.

  iSplitL "Hinner HP".
  { iNext. iExists _. iFrame. }

  wp_loadField.
  wp_apply (release_spec with "[-HQ HΦ]").
  { iFrame "lk". iFrame "Hlocked". iNext. iExists _.
    iFrame "Hfields HdiskEnd_circ Hstart_circ".
    iExists _, _, _, _, _, _, _.
    iFrame "∗#%".
    iNamed "Hlinv_pers".
    iFrame "#%".
    iPureIntro.
    split; first by (intuition (eauto; try lia)).
    pose proof Htxns as [Hbnds Hregs].
    split.
    {
      intros bndry Hbndry.
      specialize (Hbnds bndry).
      apply elem_of_list_lookup in Hbndry.
      destruct Hbndry as [i Hbndry].
      do 4 (destruct i; first by (
        simpl in Hbndry; inversion Hbndry; subst bndry; clear Hbndry;
        apply Hbnds; set_solver
      )).
      destruct i.
      2: {
        destruct i; first by (
          simpl in Hbndry; inversion Hbndry; subst bndry; clear Hbndry;
          apply Hbnds; set_solver
        ).
        inversion Hbndry.
      }
      simpl in Hbndry; inversion Hbndry; subst bndry; clear Hbndry.
      simpl.
      clear Hbnds.
      pose proof Htxns as [Hbnds _].
      unshelve (epose proof (Hbnds _ _) as Hbnd).
      2: {
        apply elem_of_list_lookup.
        exists mwrb_us.
        reflexivity.
      }
      simpl in Hbnd.
      lia.
    }
    intros i bndry1 bndry2 Hbndry1 Hbndry2.
    specialize (Hregs i bndry1 bndry2).
    do 3 (destruct i; first by (
      simpl in Hbndry1; inversion Hbndry1; subst bndry1; clear Hbndry1;
      simpl in Hbndry2; inversion Hbndry2; subst bndry2; clear Hbndry2;
      simpl; apply Hregs; reflexivity
    )).
    clear Hregs.
    unshelve (epose proof (
      is_memLog_boundaries_region_consec mwrb_uss _ _ _ _ _ Htxns _ _
    ) as Hreg1).
    3-4: reflexivity.
    unshelve (epose proof (
      is_memLog_boundaries_region_consec mwrb_us _ _ _ _ _ Htxns _ _
    ) as Hreg2).
    3-4: reflexivity.
    simpl in Hreg1.
    simpl in Hreg2.
    destruct i.
    {
      simpl in Hbndry1; inversion Hbndry1; subst bndry1; clear Hbndry1;
      simpl in Hbndry2; inversion Hbndry2; subst bndry2; clear Hbndry2.
      simpl.
      split; first by lia.
      split; first by lia.
      rewrite -(subslice_app_contig _ (S nextDiskEnd_txn_id)); last by lia.
      apply is_memLog_region_append_nils; first by assumption.
      intuition.
    }
    destruct i; last by inversion Hbndry2.
    simpl in Hbndry1; inversion Hbndry1; subst bndry1; clear Hbndry1;
    simpl in Hbndry2; inversion Hbndry2; subst bndry2; clear Hbndry2.
    simpl.
    split; first by lia.
    split; first by lia.
    eapply is_memLog_region_prepend_nils; first by eassumption.
    rewrite subslice_app_contig; last by lia.
    intuition.
  }
  wp_pures. by iApply ("HΦ" with "HQ").
Qed.

End goose_lang.


Require Import Common.Definitions.
Require Import Common.Linking.
Require Import Common.Blame.
Require Import Common.CompCertExtensions.
Require Import CompCert.Smallstep.
Require Import CompCert.Behaviors.

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

(* The repetition verbatim of theorem statements as axioms is
   particularly annoying; we will want to eliminate this duplication.
     [CH: Agreed, but easy to fix with some extra definitions.]

   Naming conventions can also be harmonized.

   The current proof is generic while still relying on our Common and
   CompCert's infrastructure. [CH: I find this just fine for now.] *)

(* CH: It seemed a bit strange that Program.interface is used
       concretely, instead of being just another parameter below.
       Same for linkable. It seems related to using everything in
       Common though, and so it's just fine for now. *)

Module Type Source_Sig.
  Parameter program : Type.

  Parameter prog_interface : program -> Program.interface.

  Parameter well_formed_program : program -> Prop.

  Parameter closed_program : program -> Prop.

  Parameter linkable_mains : program -> program -> Prop.

  Local Axiom linkable_mains_sym : forall prog1 prog2,
    linkable_mains prog1 prog2 ->
    linkable_mains prog2 prog1.

  Local Axiom linkable_disjoint_mains: forall prog1 prog2,
    well_formed_program prog1 ->
    well_formed_program prog2 ->
    linkable (prog_interface prog1) (prog_interface prog2) ->
    linkable_mains prog1 prog2.

  Parameter program_link : program -> program -> program.

  Local Axiom linking_well_formedness : forall p1 p2,
    well_formed_program p1 ->
    well_formed_program p2 ->
    linkable (prog_interface p1) (prog_interface p2) ->
    well_formed_program (program_link p1 p2).

  Local Axiom interface_preserves_closedness_l : forall p1 p2 p1',
    closed_program (program_link p1 p2) ->
    prog_interface p1 = prog_interface p1' ->
    well_formed_program p1 ->
    well_formed_program p1' ->
    closed_program (program_link p1' p2).

  Module CS.
    Parameter sem : program -> semantics.
  End CS.

  (* Notes:
     - the trace (i.e. behavior) `t` in the diagram from the paper
       corresponds to `Goes_wrong t'` in the notation below
     - in the paper we use the following notations:
       + t ≺ m = exists m' <= m. t = Goes_wrong m'
         t ≺P m = exists m' <= m. t = Goes_wrong m' /\ undef_in t (prog_interface P)
       + this means that t' plays below the role of m' above
  *)
  Local Axiom blame_program : forall p Cs t' P' m,
    well_formed_program p ->
    well_formed_program Cs ->
    linkable (prog_interface p) (prog_interface Cs) ->
    closed_program (program_link p Cs) ->
    program_behaves (CS.sem (program_link p Cs)) (Goes_wrong t') ->
    well_formed_program P' ->
    prog_interface P' = prog_interface p ->
    closed_program (program_link P' Cs) ->
    does_prefix (CS.sem (program_link P' Cs)) m ->
    not_wrong_finpref m ->
    trace_finpref_prefix t' m ->
    (prefix m (Goes_wrong t') \/ undef_in t' (prog_interface p)).

End Source_Sig.

(* CH: The number of different well-formedness conditions seems a bit
       out of control here. *)

Module Type Intermediate_Sig.
  Parameter program : Type.

  Parameter prog_interface : program -> Program.interface.

  Parameter well_formed_program : program -> Prop.

  Parameter closed_program : program -> Prop.

  Parameter linkable_mains : program -> program -> Prop.

  Parameter matching_mains : program -> program -> Prop.

  Parameter program_link : program -> program -> program.

  Local Axiom linkable_mains_sym : forall p1 p2,
    linkable_mains p1 p2 -> linkable_mains p2 p1.

  Local Axiom program_linkC : forall p1 p2,
    well_formed_program p1 ->
    well_formed_program p2 ->
    linkable (prog_interface p1) (prog_interface p2) ->
    program_link p1 p2 = program_link p2 p1.

  Local Axiom linking_well_formedness : forall p1 p2,
    well_formed_program p1 ->
    well_formed_program p2 ->
    linkable (prog_interface p1) (prog_interface p2) ->
    well_formed_program (program_link p1 p2).

  Local Axiom interface_preserves_closedness_r : forall p1 p2 p2',
    well_formed_program p1 ->
    well_formed_program p2' ->
    prog_interface p2 = prog_interface p2' ->
    linkable (prog_interface p1) (prog_interface p2) ->
    closed_program (program_link p1 p2) ->
    linkable_mains p1 p2 ->
    matching_mains p2 p2' ->
    closed_program (program_link p1 p2').

  Module CS.
    Parameter sem : program -> semantics.
  End CS.

  (* Local Axiom decomposition_with_refinement : *)
  (*   forall p c, *)
  (*     well_formed_program p -> *)
  (*     well_formed_program c -> *)
  (*     linkable (prog_interface p) (prog_interface c) -> *)
  (*     linkable_mains p c -> *)
  (*   forall beh1, *)
  (*     program_behaves (CS.sem (program_link p c)) beh1 -> *)
  (*   exists beh2, *)
  (*     program_behaves (PS.sem p (prog_interface c)) beh2 /\ *)
  (*     behavior_improves beh1 beh2. *)

  (* Local Axiom decomposition_prefix : *)
  (*   forall p c m, *)
  (*     well_formed_program p -> *)
  (*     well_formed_program c -> *)
  (*     linkable (prog_interface p) (prog_interface c) -> *)
  (*     linkable_mains p c -> *)
  (*     not_wrong_finpref m -> (* needed here, and will have it in main proof *) *)
  (*     does_prefix (CS.sem (program_link p c)) m -> *)
  (*     does_prefix (PS.sem p (prog_interface c)) m. *)

  (* Local Axiom composition_prefix : *)
  (*   forall p c m, *)
  (*     well_formed_program p -> *)
  (*     well_formed_program c -> *)
  (*     linkable_mains p c -> *)
  (*     closed_program (program_link p c) -> *)
  (*     mergeable_interfaces (prog_interface p) (prog_interface c) -> *)
  (*     does_prefix (PS.sem p (prog_interface c)) m -> *)
  (*     does_prefix (PS.sem c (prog_interface p)) m -> *)
  (*     does_prefix (CS.sem (program_link p c)) m. *)

  Local Axiom compose_mergeable_interfaces :
    forall p c,
      linkable (prog_interface p) (prog_interface c) ->
      closed_program (program_link p c) ->
      mergeable_interfaces (prog_interface p) (prog_interface c).

  Local Axiom recombination_prefix :
    forall p c p' c',
      well_formed_program p ->
      well_formed_program c ->
      well_formed_program p' ->
      well_formed_program c' ->
      mergeable_interfaces (prog_interface p) (prog_interface c) ->
      prog_interface p = prog_interface p' ->
      prog_interface c = prog_interface c' ->
      closed_program (program_link p c) ->
      closed_program (program_link p' c') ->
    forall m,
      does_prefix (CS.sem (program_link p c)) m ->
      does_prefix (CS.sem (program_link p' c')) m ->
      does_prefix (CS.sem (program_link p c')) m.
End Intermediate_Sig.

Module Type S2I_Sig (Source : Source_Sig) (Intermediate : Intermediate_Sig).
  Parameter matching_mains : Source.program -> Intermediate.program -> Prop.

  Local Axiom matching_mains_equiv : forall p1 p2 p3,
    matching_mains p1 p2 ->
    matching_mains p1 p3 ->
    Intermediate.matching_mains p2 p3.
End S2I_Sig.

Module Type Linker_Sig
       (Source : Source_Sig)
       (Intermediate : Intermediate_Sig)
       (S2I : S2I_Sig Source Intermediate).
  Local Axiom definability_with_linking :
    forall p c b m,
      Intermediate.well_formed_program p ->
      Intermediate.well_formed_program c ->
      linkable (Intermediate.prog_interface p) (Intermediate.prog_interface c) ->
      Intermediate.closed_program (Intermediate.program_link p c) ->
      program_behaves (Intermediate.CS.sem (Intermediate.program_link p c)) b ->
      prefix m b ->
      not_wrong_finpref m ->
    exists p' c',
      Source.prog_interface p' = Intermediate.prog_interface p /\
      Source.prog_interface c' = Intermediate.prog_interface c /\
      S2I.matching_mains p' p /\
      S2I.matching_mains c' c /\
      Source.well_formed_program p' /\
      Source.well_formed_program c' /\
      Source.closed_program (Source.program_link p' c') /\
      does_prefix (Source.CS.sem (Source.program_link p' c')) m.

(* TODO: split definability_with_linking into a more standard
         definability + a "unlinking" lemma *)

  (* Local Axiom definability : *)
  (*   forall p m, *)
  (*     Intermediate.well_formed_program p -> *)
  (*     Intermediate.closed_program p -> *)
  (*     does_prefix (Intermediate.CS.sem p) m -> *)
  (*     not_wrong_finpref m -> *)
  (*   exists p', *)
  (*     Source.prog_interface p' = Intermediate.prog_interface p /\ *)
  (*     S2I.matching_mains p' p /\ *)
  (*     Source.well_formed_program p' /\ *)
  (*     Source.closed_program p' /\ *)
  (*     does_prefix (Source.CS.sem p') m. *)

  (* Local Axiom unlinking : forall p i1 i2, *)
  (*   Source.prog_interface p = unionm i1 i2 -> *)
  (*   Source.well_formed_program p -> *)
  (*   linkable i1 i2 -> *)
  (*   exists p1 p2, Source.program_link p1 p2 = p /\ *)
  (*     Source.prog_interface p1 = i1 /\ *)
  (*     Source.prog_interface p2 = i2. *)

End Linker_Sig.

Module Type Compiler_Sig
       (Source : Source_Sig)
       (Intermediate : Intermediate_Sig)
       (S2I : S2I_Sig Source Intermediate).
  Parameter compile_program : Source.program -> option Intermediate.program.

  Local Axiom well_formed_compilable :
    forall p,
      Source.well_formed_program p ->
    exists pc,
      compile_program p = Some pc.

  Local Axiom compilation_preserves_well_formedness : forall p p_compiled,
    Source.well_formed_program p ->
    compile_program p = Some p_compiled ->
    Intermediate.well_formed_program p_compiled.

  Local Axiom compilation_preserves_interface : forall p p_compiled,
    compile_program p = Some p_compiled ->
    Intermediate.prog_interface p_compiled = Source.prog_interface p.

  Local Axiom compilation_preserves_linkability : forall p p_compiled c c_compiled,
    Source.well_formed_program p ->
    Source.well_formed_program c ->
    linkable (Source.prog_interface p) (Source.prog_interface c) ->
    compile_program p = Some p_compiled ->
    compile_program c = Some c_compiled ->
    linkable (Intermediate.prog_interface p_compiled) (Intermediate.prog_interface c_compiled).

  Local Axiom compilation_preserves_linkable_mains : forall p1 p1' p2 p2',
    Source.well_formed_program p1 ->
    Source.well_formed_program p2 ->
    Source.linkable_mains p1 p2 ->
    compile_program p1 = Some p1' ->
    compile_program p2 = Some p2' ->
    Intermediate.linkable_mains p1' p2'.

  Local Axiom compilation_has_matching_mains : forall p p_compiled,
    Source.well_formed_program p ->
    compile_program p = Some p_compiled ->
    S2I.matching_mains p p_compiled.

  (* CH: To match the paper this should be weakened even more to work with prefixes *)
  (* Local Axiom separate_compilation_weaker : *)
  (*   forall p c pc_comp p_comp c_comp, *)
  (*     Source.well_formed_program p -> *)
  (*     Source.well_formed_program c -> *)
  (*     linkable (Source.prog_interface p) (Source.prog_interface c) -> *)
  (*     compile_program p = Some p_comp -> *)
  (*     compile_program c = Some c_comp -> *)
  (*     compile_program (Source.program_link p c) = Some pc_comp -> *)
  (*   forall b : program_behavior, *)
  (*     program_behaves (Intermediate.CS.sem pc_comp) b <-> *)
  (*     program_behaves (Intermediate.CS.sem (Intermediate.program_link p_comp c_comp)) b. *)

  (* Local Axiom S_simulates_I: *)
  (*   forall p, *)
  (*     Source.closed_program p -> *)
  (*     Source.well_formed_program p -> *)
  (*   forall tp, *)
  (*     compile_program p = Some tp -> *)
  (*     backward_simulation (Source.CS.sem p) (Intermediate.CS.sem tp). *)

  Local Axiom forward_simulation_same_safe_prefix:
    forall p p_compiled c c_compiled m,
      linkable (Source.prog_interface p) (Source.prog_interface c) ->
      Source.closed_program (Source.program_link p c) ->
      Source.well_formed_program p ->
      Source.well_formed_program c ->
      does_prefix (Source.CS.sem (Source.program_link p c)) m ->
      not_wrong_finpref m ->
      compile_program p = Some p_compiled ->
      compile_program c = Some c_compiled ->
      does_prefix (Intermediate.CS.sem (Intermediate.program_link p_compiled c_compiled)) m.

  Local Axiom backward_simulation_behavior_improves_prefix :
    forall p p_compiled c c_compiled m,
      linkable (Source.prog_interface p) (Source.prog_interface c) ->
      Source.closed_program (Source.program_link p c) ->
      Source.well_formed_program p ->
      Source.well_formed_program c ->
      compile_program p = Some p_compiled ->
      compile_program c = Some c_compiled ->
      does_prefix (Intermediate.CS.sem (Intermediate.program_link p_compiled c_compiled)) m ->
    exists b,
      program_behaves (Source.CS.sem (Source.program_link p c)) b /\
      (prefix m b \/ behavior_improves_finpref b m).

End Compiler_Sig.


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

(* Shared state, as implemented by the message soup.

   At this point, the implementation is based on top of standard union
   maps. This defines the procedure for allocating new messages: just
   by taking the next-to-the largest id in the corresponding
   batch. Indeed, this is not particularly nice, as it assumes the
   _global_ message soup.

   It's not clear at this moment, what will be the best representation
   of the soup so it would be in the same time _local_ and also would
   allow for th allocation. Perhaps, we should just consider local
   soups, ensuring that they all carry distinct labels, and then when
   cojoin them, make sure that for clashing message id's protocol
   labels are different.

 *)

Section TaggedMessages.

  Structure TaggedMessage :=
    TMsg {
        tag: nat;
        (* Okay, this is a big omissin, but for now I'm sick and tired
           to deal with casts everywhere, so for the moment the
           contents of the messages are going to be just sequences of
           natural number, and it's up to the client-supplied
           coherence predicate to restrict them appropriately, relating this thing to tags *)
        tms_cont :> seq nat
      }.

End TaggedMessages.

Section Shared.

  Definition Label := [ordType of nat].

  (* (Heterogenious) messages are parametrized by

     - lab   - protocol Label
     - ptype - protocol, defining the content type
     - content  - the contents of the message
     - from/to  - IDs of the sender.receiver node
     - active - a bit, indicating whether the message hasn't been consumed yet (i.e., read)

     I'm not sure, if we're going to need anything else. *)
  Structure msg (mtype : Type) :=
    Msg {content  : mtype;
         from     : nat;
         to       : nat;
         active   : bool }.

  (* Message IDs: pairs Label * id, where Label comes from the protocol. *)
  Definition mid := [ordType of nat].

  (* Message soup (for a specific protocol) is just a partial finite
     map from message IDs (mid) to arbitrary Messages. *)
  Definition soup : Type :=
    union_map mid (msg (TaggedMessage)).

  Variables (s: soup) (V: valid s).

  (* Allocating new message in the soup *)
  Definition post_msg m : soup * mid :=
    let: f := fresh s in (s \+ f \\-> m, f).

  Lemma post_valid m :  valid (post_msg m).1.
  Proof. by rewrite ?valid_fresh. Qed.

  Lemma post_fresh m : (post_msg m).2 \notin dom s.
  Proof. by rewrite ?dom_fresh. Qed.

  (* Marking is  *)
  Definition mark_msg T (m : msg T) : msg T :=
    Msg (content m) (from m) (to m) false.

  (* Updating the message soup, consuming the message id *)
  Definition consume_msg (s : soup) (id : mid) : soup :=
    let: mr := find id s in
    if mr is Some m then upd id (mark_msg m) s else s.

  Definition is_active (id : mid) :=
    exists m, find id s = Some m /\ active m.

  Definition is_consumed (id : mid) :=
    exists m, find id s = Some m /\ ~~ active m.

  (* TODO: consumes "truth table" -- three possible scenarios (how to express?) *)

  (* Obvious fact about marking message *)
  Lemma find_consume s' (id: mid) m:
    valid s' -> find id s' = Some m ->
    find id (consume_msg s' id) = Some (mark_msg m).
  Proof. by move=>V' E; rewrite/consume_msg E findU eqxx V'/=. Qed.

  Lemma find_mark m s' msg :
    valid s' -> find m (consume_msg s' m) = Some msg ->
    exists msg', find m s' = Some msg' /\ msg = mark_msg msg'.
  Proof.
  move=>V'; rewrite /consume_msg; case D: (m \in dom s').
  - move/um_eta: D=>[msg'][->]_; rewrite findU eqxx/= V'.
    by case=><-; eexists _.
  by case: dom_find (D)=>//->_; move/find_some=>Z; rewrite Z in D.
  Qed.

  Lemma mark_other m m' s' :
    valid s' -> m' == m = false -> find m' (consume_msg s' m) = find m' s'.
  Proof.
  move=>V' N; rewrite /consume_msg; case D: (m \in dom s').
  by case: dom_find (D)=>//v->_ _; rewrite findU N.
  by case: dom_find (D)=>//->_.
  Qed.

  Lemma consume_valid s' m : valid s' -> valid (consume_msg s' m).
  Proof.
  move=>V'; rewrite /consume_msg; case (find m s')=>//v.
  by rewrite /mark_msg validU.
  Qed.

  Lemma consumeUn (s': soup) (i : mid) mm
        (j : mid) : valid (s' \+ i \\-> mm) ->
    consume_msg (s' \+ i \\-> mm) j =
    if i == j then s' \+ i \\-> mark_msg mm
    else (consume_msg s' j) \+ (i \\-> mm).
  Proof.
  rewrite ![_ \+ i \\-> _]joinC; rewrite eq_sym.
  move=>V'; case B: (j==i); rewrite /consume_msg findPtUn2// B.
  - by move/eqP: B=>?; subst j; rewrite updPtUn.
  by case X: (find j s')=>//; rewrite updUnL domPt inE eq_sym B.
  Qed.

  Notation "'{{' m 'in' s 'at' id '}}'" := (find id s = Some m).
  Notation "'{{' m 'in' s '}}'" := (exists id, {{m in s at id}}).

End Shared.

(* Local per-protocol state with per-node resources *)
Section Local.

  Variable U : Type.

  Definition nid := nat.

  (* Local state of a a protocol is simply a partial map from node ids
     to their local contributions, along with the validity of the
     cumulative contribution. *)

  Definition lstate_type := union_map [ordType of nid] U.

End Local.

(*
Definition um_all {A:ordType} {B} (p : A -> B -> bool) (u : union_map A B) : bool :=
  um_recf false true (fun k v f rec Hval Hpath => p k v && rec) u.

Definition um_some {A:ordType} {B} (p : A -> B -> bool) (u : union_map A B) : bool :=
  um_recf false false (fun k v f rec Hval Hpath => p k v || rec) u.
*)

Section Statelets.

  (* A particular statelet instance.
     The Label and the PCM are the parameters and are defined by the protocol.
     The lstate and dsop are subject of the evolution.
   *)
  Structure dstatelet  :=
    DStatelet {
        (* Not sure if it's the best way to represent information
           about kinds of messages in this particular dstatelet, but
           let's think of tags as of integers for now, so dTagToCont
           will map the tags to specific types. *)

        (* Local state for each node as a pair of heaps; first heap is
           real, second heap is a ghost one. Let's deal with this
           model for now before we figure out how to discharge
           equalities in a better way *)
        dstate     : lstate_type heap;
        dsoup      : soup
    }.

  Fixpoint empty_lstate (ns : seq nid) :=
    if ns is n :: ns'
    then n \\-> Heap.empty \+ (empty_lstate ns')
    else  Unit.

  (* Definition empty_dstatelet ns : dstatelet := *)
  (*   @DStatelet (empty_lstate (undup ns)) Unit. *)

  (* Lemma valid_mt_soup ns : valid (dsoup (empty_dstatelet ns)). *)
  (* Proof. by rewrite /= valid_unit. Qed. *)

  (* Lemma dom_mt ns : *)
  (*   valid (empty_lstate (undup ns)) /\ dom (empty_lstate (undup ns)) =i undup ns. *)
  (* Proof. *)
  (* elim: ns=>//=[|n ns [H1 H2]]; first by rewrite dom0. *)
  (* case B: (n \in ns)=>//=; split. *)
  (* - by rewrite gen_validPtUn/= H1 H2/=; apply/negbT; rewrite mem_undup. *)
  (* move=> z; rewrite um_domPtUn inE/= gen_validPtUn/= H1 H2/=. *)
  (* rewrite -mem_undup in B; rewrite B/=. *)
  (* case C: (n == z)=>//=; first by rewrite in_cons eq_sym C. *)
  (* by rewrite H2 in_cons eq_sym C/=. *)
  (* Qed. *)

  (* Lemma valid_mt_state ns : valid (dstate (empty_dstatelet ns)). *)
  (* Proof. *)
  (* elim:ns=>//=n ns H; case I: (n \in ns)=>//=.   *)
  (* by rewrite gen_validPtUn H/=; case: (dom_mt ns)=>_->; rewrite mem_undup I. *)
  (* Qed. *)

  (* Lemma mt_nodes ns : dom (dstate (empty_dstatelet ns)) =i ns. *)
  (* Proof. *)
  (* by case: (dom_mt ns)=>_ H2 z; rewrite -mem_undup -H2. *)
  (* Qed. *)

  Definition empty_dstatelet : dstatelet :=
    @DStatelet (empty_lstate [::]) Unit.

  Lemma valid_mt_soup : valid (dsoup empty_dstatelet).
  Proof. by rewrite /= valid_unit. Qed.

  Lemma valid_mt_state  : valid (dstate empty_dstatelet).
  Proof. by rewrite valid_unit. Qed.

  Lemma mt_nodes : dom (dstate empty_dstatelet) =i [::].
  Proof. by rewrite dom0. Qed.

End Statelets.

Module StateGetters.
Section StateGetters.

Definition state := union_map Label dstatelet.

(* Retrieve statelet from the state *)
Definition getStatelet (s: state) (i : Label) : dstatelet :=
  match find i s with
  | Some d => d
  | None => empty_dstatelet
  end.

End StateGetters.
End StateGetters.

Export StateGetters.


From caml5 Require Import
  prelude.
From caml5.lang Require Import
  notations
  proofmode.
From caml5.std Require Export
  base.

Section heapGS.
  Context `{!heapGS Σ}.
  Implicit Types l : loc.

  Definition record2_make : val :=
    λ: "v₀" "v₁",
      let: "l" := AllocN #2 "v₀" in
      "l".(1) <- "v₁" ;;
      "l".

  Definition record2_model l dq v₀ v₁ : iProp Σ :=
    l.(0) ↦{dq} v₀ ∗
    l.(1) ↦{dq} v₁.

  #[global] Instance record2_model_timeless l dq v₀ v₁ :
    Timeless (record2_model l dq v₀ v₁).
  Proof.
    apply _.
  Qed.
  #[global] Instance record2_model_persistent l v₀ v₁ :
    Persistent (record2_model l DfracDiscarded v₀ v₁).
  Proof.
    apply _.
  Qed.

  #[global] Instance record2_model_fractional l v₀ v₁ :
    Fractional (λ q, record2_model l (DfracOwn q) v₀ v₁).
  Proof.
    apply _.
  Qed.
  #[global] Instance record2_model_as_fractional l q v₀ v₁ :
    AsFractional (record2_model l (DfracOwn q) v₀ v₁) (λ q, record2_model l (DfracOwn q) v₀ v₁) q.
  Proof.
    split; done || apply _.
  Qed.

  Lemma record2_model_persist l dq v₀ v₁ :
    record2_model l dq v₀ v₁ ==∗
    record2_model l DfracDiscarded v₀ v₁.
  Proof.
    iIntros "(Hv₀ & Hv₁)".
    iMod (mapsto_persist with "Hv₀") as "$".
    iMod (mapsto_persist with "Hv₁") as "$".
    done.
  Qed.

  Lemma record2_model_valid l dq v₀ v₁ :
    record2_model l dq v₀ v₁ -∗
    ⌜✓ dq⌝.
  Proof.
    iIntros "(Hv₀ & Hv₁)". iApply (mapsto_valid with "Hv₀").
  Qed.
  Lemma record2_model_combine l dq1 v₀1 v₁1 dq2 v₀2 v₁2 :
    record2_model l dq1 v₀1 v₁1 -∗
    record2_model l dq2 v₀2 v₁2 -∗
      record2_model l (dq1 ⋅ dq2) v₀1 v₁1 ∗
      ⌜v₀1 = v₀2 ∧ v₁1 = v₁2⌝.
  Proof.
    iIntros "(Hv₀1 & Hv₁1) (Hv₀2 & Hv₁2)".
    iDestruct (mapsto_combine with "Hv₀1 Hv₀2") as "(Hv₀ & <-)".
    iDestruct (mapsto_combine with "Hv₁1 Hv₁2") as "(Hv₁ & <-)".
    iSplit; last done. iFrame.
  Qed.
  Lemma record2_model_valid_2 l dq1 v₀1 v₁1 dq2 v₀2 v₁2 :
    record2_model l dq1 v₀1 v₁1 -∗
    record2_model l dq2 v₀2 v₁2 -∗
    ⌜✓ (dq1 ⋅ dq2) ∧ v₀1 = v₀2 ∧ v₁1 = v₁2⌝.
  Proof.
    iIntros "Hl1 Hl2".
    iDestruct (record2_model_combine with "Hl1 Hl2") as "(Hl & %)".
    iDestruct (record2_model_valid with "Hl") as %?.
    done.
  Qed.
  Lemma record2_model_agree l dq1 v₀1 v₁1 dq2 v₀2 v₁2 :
    record2_model l dq1 v₀1 v₁1 -∗
    record2_model l dq2 v₀2 v₁2 -∗
    ⌜v₀1 = v₀2 ∧ v₁1 = v₁2⌝.
  Proof.
    iIntros "Hl1 Hl2".
    iDestruct (record2_model_valid_2 with "Hl1 Hl2") as %?. naive_solver.
  Qed.
  Lemma record2_model_dfrac_ne l1 dq1 v₀1 v₁1 l2 dq2 v₀2 v₁2 :
    ¬ ✓ (dq1 ⋅ dq2) →
    record2_model l1 dq1 v₀1 v₁1 -∗
    record2_model l2 dq2 v₀2 v₁2 -∗
    ⌜l1 ≠ l2⌝.
  Proof.
    iIntros "% Hl1 Hl2" (->).
    iDestruct (record2_model_valid_2 with "Hl1 Hl2") as %?. naive_solver.
  Qed.
  Lemma record2_model_ne l1 v₀1 v₁1 l2 dq2 v₀2 v₁2 :
    record2_model l1 (DfracOwn 1) v₀1 v₁1 -∗
    record2_model l2 dq2 v₀2 v₁2 -∗
    ⌜l1 ≠ l2⌝.
  Proof.
    iApply record2_model_dfrac_ne. intros []%exclusive_l. apply _.
  Qed.
  Lemma record2_model_exclusive l v₀1 v₁1 v₀2 v₁2 :
    record2_model l (DfracOwn 1) v₀1 v₁1 -∗
    record2_model l (DfracOwn 1) v₀2 v₁2 -∗
    False.
  Proof.
    iIntros "Hl1 Hl2".
    iDestruct (record2_model_ne with "Hl1 Hl2") as %?. naive_solver.
  Qed.

  Lemma record2_dfrac_relax dq l v₀ v₁ :
    ✓ dq →
    record2_model l (DfracOwn 1) v₀ v₁ ==∗
    record2_model l dq v₀ v₁.
  Proof.
    iIntros "% (Hv₀ & Hv₁)".
    iMod (mapsto_dfrac_relax with "Hv₀") as "Hv₀"; first done.
    iMod (mapsto_dfrac_relax with "Hv₁") as "Hv₁"; first done.
    iFrame. done.
  Qed.

  Lemma record2_make_spec v₀ v₁ :
    {{{ True }}}
      record2_make v₀ v₁
    {{{ l, RET #l; record2_model l (DfracOwn 1) v₀ v₁ ∗ meta_token l ⊤ }}}.
  Proof.
    iIntros "%Φ _ HΦ".
    wp_rec. wp_pures.
    wp_apply (wp_allocN with "[//]"); first done. iIntros "%l (Hl & Hmeta & _)". rewrite loc_add_0.
    wp_pures.
    iDestruct (array_cons with "Hl") as "(Hv₀ & Hl)".
    iEval (setoid_rewrite <- loc_add_0) in "Hv₀".
    iDestruct (array_singleton with "Hl") as "Hv₁".
    wp_store.
    iApply "HΦ". iFrame. done.
  Qed.

  Lemma record2_get0_spec l dq v₀ v₁ :
    {{{ record2_model l dq v₀ v₁ }}}
      !#l.(0)
    {{{ RET v₀; record2_model l dq v₀ v₁ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁) HΦ".
    wp_load.
    iApply ("HΦ" with "[$Hv₀ $Hv₁]").
  Qed.
  Lemma record2_get1_spec l dq v₀ v₁ :
    {{{ record2_model l dq v₀ v₁ }}}
      !#l.(1)
    {{{ RET v₁; record2_model l dq v₀ v₁ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁) HΦ".
    wp_load.
    iApply ("HΦ" with "[$Hv₀ $Hv₁]").
  Qed.

  Lemma record2_set0_spec l v₀ v₁ v :
    {{{ record2_model l (DfracOwn 1) v₀ v₁ }}}
      #l.(0) <- v
    {{{ RET #(); record2_model l (DfracOwn 1) v v₁ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁) HΦ".
    wp_store.
    iApply ("HΦ" with "[$Hv₀ $Hv₁]").
  Qed.
  Lemma record2_set1_spec l v₀ v₁ v :
    {{{ record2_model l (DfracOwn 1) v₀ v₁ }}}
      #l.(1) <- v
    {{{ RET #(); record2_model l (DfracOwn 1) v₀ v }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁) HΦ".
    wp_store.
    iApply ("HΦ" with "[$Hv₀ $Hv₁]").
  Qed.
End heapGS.

#[global] Opaque record2_make.

#[global] Opaque record2_model.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.
From BitBlasting Require Import QFBV CNF BBCommon BBEq BBUlt BBDisj.
From ssrlib Require Import ZAriths Tactics Bools Seqs.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Definition bit_blast_ule g ls1 ls2 : generator * cnf * literal :=
  let '(g_eq, cs_eq, r_eq) := bit_blast_eq g ls1 ls2 in
  let '(g_ult, cs_ult, r_ult) := bit_blast_ult g_eq ls1 ls2 in
  let '(g_disj, cs_disj, r_disj) := bit_blast_disj g_ult r_eq r_ult in
  (g_disj, catrev cs_eq (catrev cs_ult cs_disj), r_disj).

Definition mk_env_ule E g ls1 ls2 : env * generator * cnf * literal :=
  let '(E_eq, g_eq, cs_eq, r_eq) := mk_env_eq E g ls1 ls2 in
  let '(E_ult, g_ult, cs_ult, r_ult) := mk_env_ult E_eq g_eq ls1 ls2 in
  let '(E_disj, g_disj, cs_disj, r_disj) := mk_env_disj E_ult g_ult r_eq r_ult in
  (E_disj, g_disj, catrev cs_eq (catrev cs_ult cs_disj), r_disj).

Lemma bit_blast_ule_correct g bs1 bs2 E ls1 ls2 g' cs lr:
  bit_blast_ule g ls1 ls2 = (g', cs, lr) ->
  size ls1 = size ls2 ->
  enc_bits E ls1 bs1 ->
  enc_bits E ls2 bs2 ->
  interp_cnf E (add_prelude cs) ->
  enc_bit E lr (leB bs1 bs2).
Proof.
  rewrite /bit_blast_ule.
  case Heq : (bit_blast_eq g ls1 ls2) => [[g_eq cs_eq] r_eq].
  case Hult : (bit_blast_ult g_eq ls1 ls2) => [[g_ult cs_ult] r_ult].
  case Hdisj : (bit_blast_disj g_ult r_eq r_ult) => [[g_disj cs_disj] r_disj].
  case => _ <- <- Hsz Henc1 Henc2.
  rewrite 2!add_prelude_catrev.
  move => Hcnf.
  move/andP : Hcnf => [Hcnf_eq Hcnf].
  move/andP : Hcnf => [Hcnf_ult Hcnf_disj].
  move : (bit_blast_eq_correct Heq Hsz Henc1 Henc2 Hcnf_eq) => Hreq.
  move : (bit_blast_ult_correct Hult Henc1 Henc2 Hcnf_ult) => Hrult.
  move : (bit_blast_disj_correct Hdisj Hreq Hrult Hcnf_disj) => Hrdisj.
  rewrite /enc_bit in Hrdisj. move/eqP: Hrdisj => Hrdisj.
  apply/eqP. by rewrite /leB/enc_bit.
Qed.

Lemma mk_env_ule_is_bit_blast_ule E g ls1 ls2 E' g' cs lr:
  mk_env_ule E g ls1 ls2 = (E', g', cs, lr) ->
  bit_blast_ule g ls1 ls2 = (g', cs, lr).
Proof.
  rewrite /bit_blast_ule /mk_env_ule /=.
  move => H. dcase_hyps. subst.
  rewrite (mk_env_eq_is_bit_blast_eq H).
  rewrite (mk_env_ult_is_bit_blast_ult H1).
  done.
Qed.

Lemma mk_env_ule_newer_gen E g ls1 ls2 E' g' cs lr:
  mk_env_ule E g ls1 ls2 = (E', g', cs, lr) ->
  (g <=? g')%positive.
Proof.
  rewrite /mk_env_ule. rewrite /gen.
  case Heq: (mk_env_eq E g ls1 ls2) => [[[E_eq g_eq] cs_eq] lr_eq].
  case Hult: (mk_env_ult E_eq g_eq ls1 ls2) => [[[E_ult g_ult] cs_ult] lr_ult].
  case Hdisj: (mk_env_disj E_ult g_ult lr_eq lr_ult) => [[[E_disj g_disj] cs_disj] lr_disj].
  case. move=> _ <- _ _ .
  move: (mk_env_disj_newer_gen Hdisj) => g_ult_le_g_disj.
  move: (mk_env_ult_newer_gen Hult) => g_eq_le_g_ult.
  move: (mk_env_eq_newer_gen Heq) => g_le_g_eq.
  apply: (pos_leb_trans (pos_leb_trans g_le_g_eq g_eq_le_g_ult) g_ult_le_g_disj).
Qed.

Lemma mk_env_ule_newer_res E g ls1 ls2 E' g' cs lr :
  mk_env_ule E g ls1 ls2 = (E', g', cs, lr) ->
  newer_than_lit g' lr.
Proof.
  rewrite /mk_env_ule. rewrite /gen.
  case Heq: (mk_env_eq E g ls1 ls2) => [[[E_eq g_eq] cs_eq] lr_eq].
  case Hult: (mk_env_ult E_eq g_eq ls1 ls2) => [[[E_ult g_ult] cs_ult] lr_ult].
  case Hdisj: (mk_env_disj E_ult g_ult lr_eq lr_ult) => [[[E_disj g_disj] cs_disj] lr_disj].
  case. move=> _ <- _ <-.
  exact: (mk_env_disj_newer_res Hdisj).
Qed.

Lemma mk_env_ule_newer_cnf E g ls1 ls2 E' g' cs lr :
  mk_env_ule E g ls1 ls2 = (E', g', cs, lr) ->
  newer_than_lit g lit_tt ->
  newer_than_lits g ls1 -> newer_than_lits g ls2 ->
  newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_ule. rewrite /gen.
  case Heq: (mk_env_eq E g ls1 ls2) => [[[E_eq g_eq] cs_eq] lr_eq].
  case Hult: (mk_env_ult E_eq g_eq ls1 ls2) => [[[E_ult g_ult] cs_ult] lr_ult].
  case Hdisj: (mk_env_disj E_ult g_ult lr_eq lr_ult) => [[[E_disj g_disj] cs_disj] lr_disj].
  case. move=> _ <- <- _. move=> Hnew_gtt Hnew_gls1 Hnew_gls2.
  rewrite 2!newer_than_cnf_catrev.
  move: (mk_env_eq_newer_cnf Heq Hnew_gtt Hnew_gls1 Hnew_gls2) => H_new_cnf_geq_cseq.
  move: (mk_env_eq_newer_gen Heq) => g_le_geq.
  move: (mk_env_ult_newer_gen Hult) => geq_le_gult.
  move: (newer_than_lit_le_newer Hnew_gtt g_le_geq) => Hnew_geqtt.
  move: (newer_than_lits_le_newer Hnew_gls1 g_le_geq) => Hnew_geqls1.
  move: (newer_than_lits_le_newer Hnew_gls2 g_le_geq) => Hnew_geqls2.
  move: (mk_env_ult_newer_cnf Hult Hnew_geqtt Hnew_geqls1 Hnew_geqls2) => H_new_cnf_gult_csult.
  move: (mk_env_disj_newer_res Hdisj) => tmp.
  move: (mk_env_ult_newer_res Hult Hnew_geqtt) => tmp2.
  move: (mk_env_eq_newer_res Heq) => tmp3.
  move: (newer_than_lit_le_newer tmp3 geq_le_gult) => tmp4.
  move: (mk_env_disj_newer_cnf Hdisj tmp4 tmp2) => -> /=.
  move: (mk_env_disj_newer_gen Hdisj) => g_ult_le_g_disj.
  move: (newer_than_cnf_le_newer H_new_cnf_gult_csult g_ult_le_g_disj) => -> /=.
  move: (pos_leb_trans geq_le_gult g_ult_le_g_disj) => geq_le_gdisj.
  move: (newer_than_cnf_le_newer H_new_cnf_geq_cseq geq_le_gdisj) => -> /=.
  done.
Qed.

Lemma mk_env_ule_preserve E g ls1 ls2 E' g' cs lr :
  mk_env_ule E g ls1 ls2 = (E', g', cs, lr) ->
  env_preserve E E' g.
Proof.
  rewrite /mk_env_ule. rewrite /gen.
  case Heq: (mk_env_eq E g ls1 ls2) => [[[E_eq g_eq] cs_eq] lr_eq].
  case Hult: (mk_env_ult E_eq g_eq ls1 ls2) => [[[E_ult g_ult] cs_ult] lr_ult].
  case Hdisj: (mk_env_disj E_ult g_ult lr_eq lr_ult) => [[[E_disj g_disj] cs_disj] lr_disj].
  case=> <- _ _ _.
  move: (mk_env_eq_preserve Heq) => Hpre_eq.
  move: (mk_env_ult_preserve Hult) => Hpre_ult.
  move: (mk_env_disj_preserve Hdisj) => Hpre_disj.
  move: (mk_env_eq_newer_gen Heq) => Hng_eq.
  move: (mk_env_ult_newer_gen Hult) => Hng_ult.
  move: (mk_env_disj_newer_gen Hdisj) => Hng_disj.
  move: (env_preserve_le Hpre_ult Hng_eq) => Hpre2.
  move: (pos_leb_trans Hng_eq Hng_ult) => g_le_gult.
  move: (env_preserve_le Hpre_disj g_le_gult) => Hpre3.
  exact: (env_preserve_trans (env_preserve_trans Hpre_eq Hpre2) Hpre3).
Qed.

Lemma mk_env_ule_sat E g ls1 ls2 E' g' cs lr :
    mk_env_ule E g ls1 ls2 = (E', g', cs, lr) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 -> newer_than_lits g ls2 ->
    interp_cnf E' cs.
Proof.
  rewrite /mk_env_ule. rewrite /gen.
  case Heq: (mk_env_eq E g ls1 ls2) => [[[E_eq g_eq] cs_eq] lr_eq].
  case Hult: (mk_env_ult E_eq g_eq ls1 ls2) => [[[E_ult g_ult] cs_ult] lr_ult].
  case Hdisj: (mk_env_disj E_ult g_ult lr_eq lr_ult) => [[[E_disj g_disj] cs_disj] lr_disj].
  case=> <- _ <- _. move=> Hnew_gtt Hnew_gls1 Hnew_gls2.
  rewrite 2!interp_cnf_catrev.
  move: (mk_env_eq_newer_cnf Heq Hnew_gtt Hnew_gls1 Hnew_gls2) => H_new_cnf_geq_cseq.
  move: (mk_env_eq_newer_gen Heq) => g_le_geq.
  move: (mk_env_ult_newer_gen Hult) => geq_le_gult.
  move: (newer_than_lit_le_newer Hnew_gtt g_le_geq) => Hnew_geqtt.
  move: (newer_than_lits_le_newer Hnew_gls1 g_le_geq) => Hnew_geqls1.
  move: (newer_than_lits_le_newer Hnew_gls2 g_le_geq) => Hnew_geqls2.
  move: (mk_env_ult_sat Hult Hnew_geqtt Hnew_geqls1 Hnew_geqls2) => Hsat_ult.
  move: (mk_env_disj_newer_gen Hdisj) => g_ult_le_g_disj.
  move: (mk_env_disj_preserve Hdisj) => Hpre_disj.
  move: (newer_than_lit_le_newer Hnew_geqtt geq_le_gult) => Hnew_gulttt.
  move: (newer_than_lits_le_newer Hnew_geqls1 geq_le_gult) => Hnew_gultls1.
  move: (newer_than_lits_le_newer Hnew_geqls2 geq_le_gult) => Hnew_gultls2.
  move: (mk_env_ult_newer_cnf Hult Hnew_geqtt Hnew_geqls1 Hnew_geqls2) => Hnew_cnf_gult_csult.
  move: (env_preserve_cnf Hpre_disj Hnew_cnf_gult_csult) => -> /=.
  rewrite Hsat_ult /=.
  move: (mk_env_disj_newer_res Hdisj) => tmp.
  move: (mk_env_ult_newer_res Hult Hnew_geqtt) => tmp2.
  move: (mk_env_eq_newer_res Heq) => tmp3.
  move: (newer_than_lit_le_newer tmp3 geq_le_gult) => tmp4.
  move: (mk_env_disj_sat Hdisj tmp4 tmp2) => -> /=.
  move: (mk_env_eq_sat Heq Hnew_gtt Hnew_gls1 Hnew_gls2) => H.
  move: (mk_env_eq_preserve Heq) => Hpre_eq.
  move: (mk_env_ult_preserve Hult) => Hpre_ult.
  move: (mk_env_eq_newer_cnf Heq Hnew_gtt Hnew_gls1 Hnew_gls2) => Hnew_cnf_geq_cseq.
  move: (env_preserve_cnf Hpre_ult Hnew_cnf_geq_cseq) => eq1.
  rewrite H in eq1.
  move: (mk_env_disj_newer_cnf Hdisj tmp4 tmp2) => Hnew_cnf_gdisj_csdisj.
  move: (newer_than_cnf_le_newer Hnew_cnf_geq_cseq geq_le_gult) => Hnewcnf_gult_cseq.
  move: (env_preserve_cnf Hpre_disj Hnewcnf_gult_cseq) => -> /=.
    by rewrite eq1 /=.
Qed.

Lemma mk_env_ule_env_equal E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_ule E1 g ls1 ls2 = (E1', g1', cs1, lrs1) ->
  mk_env_ule E2 g ls1 ls2 = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  rewrite /mk_env_ule => Heq.
  dcase (mk_env_eq E1 g ls1 ls2) => [[[[E_eq1 g_eq1] cs_eq1] lrs_eq1] Hv_eq1].
  dcase (mk_env_eq E2 g ls1 ls2) => [[[[E_eq2 g_eq2] cs_eq2] lrs_eq2] Hv_eq2].
  move: (mk_env_eq_env_equal Heq Hv_eq1 Hv_eq2) => [Heq1 [? [? ?]]]; subst.
  dcase (mk_env_ult E_eq1 g_eq2 ls1 ls2) => [[[[E_lt1 g_lt1] cs_lt1] lrs_lt1] Hv_lt1].
  dcase (mk_env_ult E_eq2 g_eq2 ls1 ls2) => [[[[E_lt2 g_lt2] cs_lt2] lrs_lt2] Hv_lt2].
  move: (mk_env_ult_env_equal Heq1 Hv_lt1 Hv_lt2) => [Heq2 [? [? ?]]]; subst.
  dcase (mk_env_disj E_lt1 g_lt2 lrs_eq2 lrs_lt2) =>[[[[E_d1 g_d1] cs_d1] lrs_d1] Hv_d1].
  dcase (mk_env_disj E_lt2 g_lt2 lrs_eq2 lrs_lt2) =>[[[[E_d2 g_d2] cs_d2] lrs_d2] Hv_d2].
  move: (mk_env_disj_env_equal Heq2 Hv_d1 Hv_d2) => [Heq3 [? [? ?]]]; subst.
  case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Common subexpression elimination over RTL.  This optimization
  proceeds by value numbering over extended basic blocks. *)

Require Import Coqlib.
Require Import Maps.
Require Import Errors.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import ValueDomain.
Require Import ValueAnalysis.
Require Import CSEdomain.
Require Import Kildall.
Require Import CombineOp.

(** The idea behind value numbering algorithms is to associate
  abstract identifiers (``value numbers'') to the contents of registers
  at various program points, and record equations between these
  identifiers.  For instance, consider the instruction
  [r1 = add(r2, r3)] and assume that [r2] and [r3] are mapped
  to abstract identifiers [x] and [y] respectively at the program
  point just before this instruction.  At the program point just after,
  we can add the equation [z = add(x, y)] and associate [r1] with [z],
  where [z] is a fresh abstract identifier.  However, if we already
  knew an equation [u = add(x, y)], we can preferably add no equation
  and just associate [r1] with [u].  If there exists a register [r4]
  mapped with [u] at this point, we can then replace the instruction
  [r1 = add(r2, r3)] by a move instruction [r1 = r4], therefore eliminating
  a common subexpression and reusing the result of an earlier addition.

  The representation of value numbers and equations is described in
  module [CSEdomain]. *)

(** * Operations on value numberings *)

(** [valnum_reg n r] returns the value number for the contents of
  register [r].  If none exists, a fresh value number is returned
  and associated with register [r].  The possibly updated numbering
  is also returned.  [valnum_regs] is similar, but for a list of
  registers. *)

Definition valnum_reg (n: numbering) (r: reg) : numbering * valnum :=
  match PTree.get r n.(num_reg) with
  | Some v => (n, v)
  | None   =>
      let v := n.(num_next) in
      ( {| num_next := Psucc v;
           num_eqs  := n.(num_eqs);
           num_reg  := PTree.set r v n.(num_reg);
           num_val  := PMap.set v (r :: nil) n.(num_val) |},
       v)
  end.

Fixpoint valnum_regs (n: numbering) (rl: list reg)
                     {struct rl} : numbering * list valnum :=
  match rl with
  | nil =>
      (n, nil)
  | r1 :: rs =>
      let (n1, v1) := valnum_reg n r1 in
      let (ns, vs) := valnum_regs n1 rs in
      (ns, v1 :: vs)
  end.

(** [find_valnum_rhs rhs eqs] searches the list of equations [eqs]
  for an equation of the form [vn = rhs] for some value number [vn].
  If found, [Some vn] is returned, otherwise [None] is returned. *)

Fixpoint find_valnum_rhs (r: rhs) (eqs: list equation)
                         {struct eqs} : option valnum :=
  match eqs with
  | nil => None
  | Eq v str r' :: eqs1 =>
      if str && eq_rhs r r' then Some v else find_valnum_rhs r eqs1
  end.

(** [find_valnum_rhs' rhs eqs] is similar, but also accepts equations
  of the form [vn >= rhs]. *)

Fixpoint find_valnum_rhs' (r: rhs) (eqs: list equation)
                          {struct eqs} : option valnum :=
  match eqs with
  | nil => None
  | Eq v str r' :: eqs1 =>
      if eq_rhs r r' then Some v else find_valnum_rhs' r eqs1
  end.

(** [find_valnum_num vn eqs] searches the list of equations [eqs]
  for an equation of the form [vn = rhs] for some equation [rhs].
  If found, [Some rhs] is returned, otherwise [None] is returned. *)

Fixpoint find_valnum_num (v: valnum) (eqs: list equation)
                         {struct eqs} : option rhs :=
  match eqs with
  | nil => None
  | Eq v' str r' :: eqs1 =>
      if str && peq v v' then Some r' else find_valnum_num v eqs1
  end.

(** [reg_valnum n vn] returns a register that is mapped to value number
    [vn], or [None] if no such register exists. *)

Definition reg_valnum (n: numbering) (vn: valnum) : option reg :=
  match PMap.get vn n.(num_val) with
  | nil => None
  | r :: rs => Some r
  end.

(** [regs_valnums] is similar, for a list of value numbers. *)

Fixpoint regs_valnums (n: numbering) (vl: list valnum) : option (list reg) :=
  match vl with
  | nil => Some nil
  | v1 :: vs =>
      match reg_valnum n v1, regs_valnums n vs with
      | Some r1, Some rs => Some (r1 :: rs)
      | _, _ => None
      end
  end.

(** [find_rhs] return a register that already holds the result of the
    given arithmetic operation or memory load, or a value more defined
    than this result, according to the given
    numbering.  [None] is returned if no such register exists. *)

Definition find_rhs (n: numbering) (rh: rhs) : option reg :=
  match find_valnum_rhs' rh n.(num_eqs) with
  | None => None
  | Some vres => reg_valnum n vres
  end.

(** Update the [num_val] mapping prior to a redefinition of register [r]. *)

Definition forget_reg (n: numbering) (rd: reg) : PMap.t (list reg) :=
  match PTree.get rd n.(num_reg) with
  | None => n.(num_val)
  | Some v => PMap.set v (List.remove peq rd (PMap.get v n.(num_val))) n.(num_val)
  end.

Definition update_reg (n: numbering) (rd: reg) (vn: valnum) : PMap.t (list reg) :=
  let nv := forget_reg n rd in PMap.set vn (rd :: PMap.get vn nv) nv.

(** [add_rhs n rd rhs] updates the value numbering [n] to reflect
  the computation of the operation or load represented by [rhs]
  and the storing of the result in register [rd].  If an equation
  [vn = rhs] is known, register [rd] is set to [vn].  Otherwise,
  a fresh value number [vn] is generated and associated with [rd],
  and the equation [vn = rhs] is added. *)

Definition add_rhs (n: numbering) (rd: reg) (rh: rhs) : numbering :=
  match find_valnum_rhs rh n.(num_eqs) with
  | Some vres =>
      {| num_next := n.(num_next);
         num_eqs  := n.(num_eqs);
         num_reg  := PTree.set rd vres n.(num_reg);
         num_val  := update_reg n rd vres |}
  | None =>
      {| num_next := Psucc n.(num_next);
         num_eqs  := Eq n.(num_next) true rh :: n.(num_eqs);
         num_reg  := PTree.set rd n.(num_next) n.(num_reg);
         num_val  := update_reg n rd n.(num_next) |}
  end.

(** [add_op n rd op rs] specializes [add_rhs] for the case of an
  arithmetic operation.  The right-hand side corresponding to [op]
  and the value numbers for the argument registers [rs] is built
  and added to [n] as described in [add_rhs].

  If [op] is a move instruction, we simply assign the value number of
  the source register to the destination register, since we know that
  the source and destination registers have exactly the same value.
  This enables more common subexpressions to be recognized. For instance:
<<
     z = add(x, y);  u = x; v = add(u, y);
>>
  Since [u] and [x] have the same value number, the second [add]
  is recognized as computing the same result as the first [add],
  and therefore [u] and [z] have the same value number. *)

Definition add_op (n: numbering) (rd: reg) (op: operation) (rs: list reg) :=
  match is_move_operation op rs with
  | Some r =>
      let (n1, v) := valnum_reg n r in
      {| num_next := n1.(num_next);
         num_eqs  := n1.(num_eqs);
         num_reg  := PTree.set rd v n1.(num_reg);
         num_val  := update_reg n1 rd v |}
  | None =>
      let (n1, vs) := valnum_regs n rs in
      add_rhs n1 rd (Op op vs)
  end.

(** [add_load n rd chunk addr rs] specializes [add_rhs] for the case of a
  memory load.  The right-hand side corresponding to [chunk], [addr]
  and the value numbers for the argument registers [rs] is built
  and added to [n] as described in [add_rhs]. *)

Definition add_load (n: numbering) (rd: reg)
                    (chunk: memory_chunk) (addr: addressing)
                    (rs: list reg) :=
  let (n1, vs) := valnum_regs n rs in
  add_rhs n1 rd (Load chunk addr vs).

(** [set_unknown n rd] returns a numbering where [rd] is mapped to
  no value number, and no equations are added.  This is useful
  to model instructions with unpredictable results such as [Ibuiltin]. *)

Definition set_unknown (n: numbering) (rd: reg) :=
  {| num_next := n.(num_next);
     num_eqs  := n.(num_eqs);
     num_reg  := PTree.remove rd n.(num_reg);
     num_val  := forget_reg n rd |}.

(** [kill_equations pred n] remove all equations satisfying predicate [pred]. *)

Fixpoint kill_eqs (pred: rhs -> bool) (eqs: list equation) : list equation :=
  match eqs with
  | nil => nil
  | (Eq l strict r) as eq :: rem =>
      if pred r then kill_eqs pred rem else eq :: kill_eqs pred rem
  end.

Definition kill_equations (pred: rhs -> bool) (n: numbering) : numbering :=
  {| num_next := n.(num_next);
     num_eqs  := kill_eqs pred n.(num_eqs);
     num_reg  := n.(num_reg);
     num_val  := n.(num_val) |}.

(** [kill_all_loads n] removes all equations involving memory loads,
  as well as those involving memory-dependent operators.
  It is used to reflect the effect of a builtin operation, which can
  change memory in unpredictable ways and potentially invalidate all such equations. *)

Definition filter_loads (r: rhs) : bool :=
  match r with
  | Op op _ => op_depends_on_memory op
  | Load _ _ _ => true
  end.

Definition kill_all_loads (n: numbering) : numbering :=
  kill_equations filter_loads n.

(** [kill_loads_after_store app n chunk addr args] removes all equations
  involving loads that could be invalidated by a store of quantity [chunk]
  at address determined by [addr] and [args].  Loads that are disjoint
  from this store are preserved.  Equations involving memory-dependent
  operators are also removed. *)

Definition filter_after_store (app: VA.t) (n: numbering) (p: aptr) (sz: Z) (r: rhs) :=
  match r with
  | Op op vl =>
      op_depends_on_memory op
  | Load chunk addr vl =>
      match regs_valnums n vl with
      | None => true
      | Some rl =>
          negb (pdisjoint (aaddressing app addr rl) (size_chunk chunk) p sz)
      end
  end.

Definition kill_loads_after_store
             (app: VA.t) (n: numbering)
             (chunk: memory_chunk) (addr: addressing) (args: list reg) :=
  let p := aaddressing app addr args in
  kill_equations (filter_after_store app n p (size_chunk chunk)) n.

(** [add_store_result n chunk addr rargs rsrc] updates the numbering [n]
  to reflect the knowledge gained after executing an instruction
  [Istore chunk addr rargs rsrc].  An equation [vsrc >= Load chunk addr vargs]
  is added, but only if the value of [rsrc] is known to be normalized
  with respect to [chunk]. *)

Definition store_normalized_range (chunk: memory_chunk) : aval :=
  match chunk with
  | Mint8signed => Sgn 8
  | Mint8unsigned => Uns 8
  | Mint16signed => Sgn 16
  | Mint16unsigned => Uns 16
  | _ => Vtop
  end.

Definition add_store_result (app: VA.t) (n: numbering) (chunk: memory_chunk) (addr: addressing)
                            (rargs: list reg) (rsrc: reg) :=
  if vincl (avalue app rsrc) (store_normalized_range chunk) then
    let (n1, vsrc) := valnum_reg n rsrc in
    let (n2, vargs) := valnum_regs n1 rargs in
    {| num_next := n2.(num_next);
       num_eqs  := Eq vsrc false (Load chunk addr vargs) :: n2.(num_eqs);
       num_reg  := n2.(num_reg);
       num_val  := n2.(num_val) |}
  else n.

(** [kill_loads_after_storebyte app n dst sz] removes all equations
  involving loads that could be invalidated by a store of [sz] bytes
  starting at address [dst]. Loads that are disjoint from this
  store-bytes are preserved.  Equations involving memory-dependent
  operators are also removed. *)

Definition kill_loads_after_storebytes
             (app: VA.t) (n: numbering) (dst: reg) (sz: Z) :=
  let p := aaddr app dst in
  kill_equations (filter_after_store app n p sz) n.

(** [add_memcpy app n1 n2 rsrc rdst sz] adds equations to [n2] that
  represent the effect of a [memcpy] block copy operation of [sz] bytes
  from the address denoted by [rsrc] to the address denoted by [rdst].
  [n2] is the numbering returned by [kill_loads_after_storebytes]
  and [n1] is the original numbering before the [memcpy] operation.
  Valid equations (found in [n1]) involving loads within the source
  area of the [memcpy] are translated as equations involving loads
  within the destination area, and added to numbering [n2].
  Currently, we only track [memcpy] operations between stack
  locations, as often occur when compiling assignments between local C
  variables of struct type. *)

Definition shift_memcpy_eq (src sz delta: Z) (e: equation) :=
  match e with
  | Eq l strict (Load chunk (Ainstack i) _) =>
      let i := Int.unsigned i in
      let j := i + delta in
      if zle src i
      && zle (i + size_chunk chunk) (src + sz)
      && zeq (Zmod delta (align_chunk chunk)) 0
      && zle 0 j
      && zle j Int.max_unsigned
      then Some(Eq l strict (Load chunk (Ainstack (Int.repr j)) nil))
      else None
  | _ => None
  end.

Fixpoint add_memcpy_eqs (src sz delta: Z) (eqs1 eqs2: list equation) :=
  match eqs1 with
  | nil => eqs2
  | e :: eqs =>
      match shift_memcpy_eq src sz delta e with
      | None => add_memcpy_eqs src sz delta eqs eqs2
      | Some e' => e' :: add_memcpy_eqs src sz delta eqs eqs2
      end
  end.

Definition add_memcpy (app: VA.t) (n1 n2: numbering) (rsrc rdst: reg) (sz: Z) :=
  match aaddr app rsrc, aaddr app rdst with
  | Stk src, Stk dst =>
      {| num_next := n2.(num_next);
         num_eqs  := add_memcpy_eqs (Int.unsigned src) sz
                                    (Int.unsigned dst - Int.unsigned src)
                                    n1.(num_eqs) n2.(num_eqs);
         num_reg  := n2.(num_reg);
         num_val  := n2.(num_val) |}
  | _, _ => n2
  end.

(** Take advantage of known equations to select more efficient
  forms of operations, addressing modes, and conditions. *)

Section REDUCE.

Variable A: Type.
Variable f: (valnum -> option rhs) -> A -> list valnum -> option (A * list valnum).
Variable n: numbering.

Fixpoint reduce_rec (niter: nat) (op: A) (args: list valnum) : option(A * list reg) :=
  match niter with
  | O => None
  | Datatypes.S niter' =>
      match f (fun v => find_valnum_num v n.(num_eqs)) op args with
      | None => None
      | Some(op', args') =>
          match reduce_rec niter' op' args' with
          | None =>
              match regs_valnums n args' with Some rl => Some(op', rl) | None => None end
          | Some _ as res =>
              res
          end
      end
  end.

Definition reduce (op: A) (rl: list reg) (vl: list valnum) : A * list reg :=
  match reduce_rec 4%nat op vl with
  | None     => (op, rl)
  | Some res => res
  end.

End REDUCE.

(** * The static analysis *)

(** We now equip the type [numbering] with a partial order and a greatest
  element.  The partial order is based on entailment: [n1] is greater
  than [n2] if [n1] is satisfiable whenever [n2] is.  The greatest element
  is, of course, the empty numbering (no equations). *)

Module Numbering.
  Definition t := numbering.
  Definition ge (n1 n2: numbering) : Prop :=
    forall valu ge sp rs m,
    numbering_holds valu ge sp rs m n2 ->
    numbering_holds valu ge sp rs m n1.
  Definition top := empty_numbering.
  Lemma top_ge: forall x, ge top x.
  Proof.
    intros; red; intros. unfold top. apply empty_numbering_holds.
  Qed.
  Lemma refl_ge: forall x, ge x x.
  Proof.
    intros; red; auto.
  Qed.
End Numbering.

(** We reuse the solver for forward dataflow inequations based on
  propagation over extended basic blocks defined in library [Kildall]. *)

Module Solver := BBlock_solver(Numbering).

(** The transfer function for the dataflow analysis returns the numbering
  ``after'' execution of the instruction at [pc], as a function of the
  numbering ``before''.  For [Iop] and [Iload] instructions, we add
  equations or reuse existing value numbers as described for
  [add_op] and [add_load].  For [Istore] instructions, we forget
  equations involving memory loads at possibly overlapping locations,
  then add an equation for loads from the same location stored to.
  For [Icall] instructions, we could simply associate a fresh, unconstrained by equations value number
  to the result register.  However, it is often undesirable to eliminate
  common subexpressions across a function call (there is a risk of
  increasing too much the register pressure across the call), so we
  just forget all equations and start afresh with an empty numbering.
  Finally, for instructions that modify neither registers nor
  the memory, we keep the numbering unchanged.

  For builtin invocations [Ibuiltin], we have three strategies:
- Forget all equations.  This is appropriate for builtins that can be
  turned into function calls ([EF_external], [EF_malloc], [EF_free]).
- Forget equations involving loads but keep equations over registers.
  This is appropriate for builtins that can modify memory,
  e.g. volatile stores, or [EF_builtin]
- Keep all equations, taking advantage of the fact that neither memory
  nor registers are modified.  This is appropriate for annotations
  and for volatile loads.
*)

Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numbering) :=
  match f.(fn_code)!pc with
  | None => before
  | Some i =>
      match i with
      | Inop s =>
          before
      | Iop op args res s =>
          add_op before res op args
      | Iload chunk addr args dst s =>
          add_load before dst chunk addr args
      | Istore chunk addr args src s =>
          let app := approx!!pc in
          let n := kill_loads_after_store app before chunk addr args in
          add_store_result app n chunk addr args src
      | Icall sig ros args res s =>
          empty_numbering
      | Itailcall sig ros args =>
          empty_numbering
      | Ibuiltin ef args res s =>
          match ef with
          | EF_inline_asm _ =>
              empty_numbering
          | EF_i64_builtin _ | EF_builtin _ _ | EF_vstore _ | EF_vstore_global _ _ _ =>
              set_unknown (kill_all_loads before) res
          | EF_memcpy sz al =>
              match args with
              | rdst :: rsrc :: nil =>
                  let app := approx!!pc in
                  let n := kill_loads_after_storebytes app before rdst sz in
                  set_unknown (add_memcpy app before n rsrc rdst sz) res
              | _ =>
                  empty_numbering
              end
          | EF_vload _ | EF_vload_global _ _ _ | EF_annot _ _ | EF_annot_val _ _ =>
              set_unknown before res
          end
      | Icond cond args ifso ifnot =>
          before
      | Ijumptable arg tbl =>
          before
      | Ireturn optarg =>
          before
      end
  end.

(** The static analysis solves the dataflow inequations implied
  by the [transfer] function using the ``extended basic block'' solver,
  which produces sub-optimal solutions quickly.  The result is
  a mapping from program points to numberings. *)

Definition analyze (f: RTL.function) (approx: PMap.t VA.t): option (PMap.t numbering) :=
  Solver.fixpoint (fn_code f) successors_instr (transfer f approx) f.(fn_entrypoint).

(** * Code transformation *)

(** The code transformation is performed instruction by instruction.
  [Iload] instructions and non-trivial [Iop] instructions are turned
  into move instructions if their result is already available in a
  register, as indicated by the numbering inferred at that program point.

  Some operations are so cheap to compute that it is generally not
  worth reusing their results.  These operations are detected by the
  function [is_trivial_op] in module [Op]. *)

Definition transf_instr (n: numbering) (instr: instruction) :=
  match instr with
  | Iop op args res s =>
      if is_trivial_op op then instr else
        let (n1, vl) := valnum_regs n args in
        match find_rhs n1 (Op op vl) with
        | Some r =>
            Iop Omove (r :: nil) res s
        | None =>
            let (op', args') := reduce _ combine_op n1 op args vl in
            Iop op' args' res s
        end
  | Iload chunk addr args dst s =>
      let (n1, vl) := valnum_regs n args in
      match find_rhs n1 (Load chunk addr vl) with
      | Some r =>
          Iop Omove (r :: nil) dst s
      | None =>
          let (addr', args') := reduce _ combine_addr n1 addr args vl in
          Iload chunk addr' args' dst s
      end
  | Istore chunk addr args src s =>
      let (n1, vl) := valnum_regs n args in
      let (addr', args') := reduce _ combine_addr n1 addr args vl in
      Istore chunk addr' args' src s
  | Icond cond args s1 s2 =>
      let (n1, vl) := valnum_regs n args in
      let (cond', args') := reduce _ combine_cond n1 cond args vl in
      Icond cond' args' s1 s2
  | _ =>
      instr
  end.

Definition transf_code (approxs: PMap.t numbering) (instrs: code) : code :=
  PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs.

Definition vanalyze := ValueAnalysis.analyze.

Definition transf_function (rm: romem) (f: function) : res function :=
  let approx := vanalyze rm f in
  match analyze f approx with
  | None => Error (msg "CSE failure")
  | Some approxs =>
      OK(mkfunction
           f.(fn_sig)
           f.(fn_params)
           f.(fn_stacksize)
           (transf_code approxs f.(fn_code))
           f.(fn_entrypoint))
  end.

Definition transf_fundef (rm: romem) (f: fundef) : res fundef :=
  AST.transf_partial_fundef (transf_function rm) f.

Definition transf_program (p: program) : res program :=
  transform_partial_program (transf_fundef (romem_for_program p)) p.


(*

  Copyright 2014 Cornell University

  This file is part of CFGV project.

  CFGV 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.

  CFGV 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 CFGV.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/CFGVLFMTP2014/
  Authors: Abhishek Anand & Vincent Rahli

*)

Set Implicit Arguments.
Require Export AlphaEqProps.
Require Import Omega.

Ltac EqDecRefl :=
  let dec:= fresh "dec" in
  let HH:= fresh "Hrefl" in
repeat match goal with
[pp : @eq ?T ?ta ?tb |- _ ] =>
  assert (Deq T) as dec by eauto with Deq;
  pose proof (UIPReflDeq dec _ pp) as HH;
  try rewrite HH; clear HH dec
end.

Ltac EqDec ta tb :=
  let dec:= fresh "dec" in
  let Heq:= fresh "Heq" ta tb in
  let Hneq:= fresh "Hneq" ta tb in
  let T := type of ta in
  assert (Deq T) as dec by eauto with Deq;
  destruct (dec ta tb) as [Heq| Hneq]; clear dec.

Definition tAlphaEqG {G} (sa sb : GSym G)
  (vc: VarSym G ) (ta : Term sa) (tb : Term sb):=
match (deqGSym sa sb) with
| left eqq => tAlphaEq vc (transport eqq ta) tb
| right eqq => False
end.

Definition pAlphaEqG {G} (sa sb : GSym G)
  (vc: VarSym G ) (ta : Pattern sa) (tb : Pattern sb):=
match (deqGSym sa sb) with
| left eqq => pAlphaEq vc (transport eqq ta) tb
| right eqq => False
end.

Ltac notAlpha :=
  let Halc := fresh "Halc" in
  let AlphaTac := introv Halc;
    inverts Halc;
    EqDecSndEq;
    subst;
    contradiction in
  let Hseq := fresh  "Hseq" in
  let Hseqd := fresh  "Hseqd" in
  try(AlphaTac);
  unfold  tAlphaEqG; unfold  pAlphaEqG;
  match goal with
  [|- context [deqGSym ?l ?l]] =>
    rewrite DeqTrue; simpl; AlphaTac
  | [|- context [deqGSym ?l ?r]] =>
    destruct (deqGSym l r) as [Hseq |?]; cpx;
    duplicate Hseq as Hseqd;
    inverts Hseq; cpx ; try subst; cpx
  end.

Lemma decideAbsT {G} (vc : VarSym G)
  (sa : GSym G) (ta: Term sa)
(Hdt : forall phnew : Term sa,
      tSize phnew <= tSize ta ->
      forall (sb : GSym G) (tb : Term sb),
     decidable (tAlphaEqG vc phnew tb))
(sb : GSym G) (tb: Term sa)
(la lb :(list (vType vc))) :
decidable (AlphaEqAbs (termAbs vc la ta) (termAbs vc lb tb)).
Proof.
  remember (beq_nat (length la) (length lb)) as blen.
  destruct blen;
    [
        applysym beq_nat_true in Heqblen
      |
        right ;
        applysym beq_nat_false in Heqblen;
        introv Hal; inverts Hal;
        EqDecSndEq; omega
    ].
  remember (GFreshVars (la++lb
              ++ tAllVars ta++tAllVars tb) la) as lvn.
  remember (tSwap ta (combine la lvn)) as phnew.
  pose proof (tcase
        (@swapPreservesSize G vc (combine la lvn)) _ ta) as Hs.
  specialize (Hdt (tSwap ta (combine la lvn))).
  rewrite Hs in Hdt.
  dimp Hdt. apply Hdt with
        (tb:= (tSwap tb (combine lb lvn))) in hyp.
  unfold tAlphaEqG in hyp.
  rewrite DeqTrue in hyp. allsimpl.
  clear Hs  Hdt.
  clear dependent phnew.
  destruct hyp as [? | Hnal];[left| right];
  pose proof (FreshDistVarsSpec
      (la ++ lb ++ tAllVars ta ++ tAllVars tb) la ) as XX;
  rewrite <- Heqlvn in XX;
  simpl in XX; repnd; dands;
  symmetry in XX.
  - apply alAbT with (lbnew:=lvn);
        cpx; try congruence;
    unfold tFresh; allsimpl; repeat(disjoint_reasoning).
  - introv Hal. apply Hnal. clear Hnal. clear Heqlvn.
    apply betterAbsTElim
    with (lvAvoid:= lvn) in Hal.
     allsimpl. exrepnd.
    apply tAlphaEqEquivariantRev with
    (sw := combine lvn lbnew).
    autorewrite with SwapAppR.
    unfold tFresh in Hal3.
    allsimpl. repnd.
    symmetry in XX.
    autorewrite with slow; try congruence;
    cpx; repeat (disjoint_reasoning);
    repeat match goal with
    [ H : disjoint _ _ |- _ ] => clear H
    | [ H : no_repeats _ _ |- _ ] => clear H
    end.
Defined.

Lemma decideAbsP {G} (vc : VarSym G)
  (sa : GSym G) (ta: Pattern sa)
(Hdt : forall phnew : Pattern sa,
      pSize phnew <= pSize ta ->
      forall (sb : GSym G) (tb : Pattern sb),
        decidable (pAlphaEqG vc phnew tb))
(sb : GSym G) (tb: Pattern sa)
(la lb :(list (vType vc))) :
decidable (AlphaEqAbs (patAbs vc la ta) (patAbs vc lb tb)).
Proof.
  remember (beq_nat (length la) (length lb)) as blen.
  destruct blen;
    [
        applysym beq_nat_true in Heqblen
      |
        right ;
        applysym beq_nat_false in Heqblen;
        introv Hal; inverts Hal;
        EqDecSndEq; omega
    ].
  remember (GFreshVars (la++lb
              ++ pAllVars ta++pAllVars tb) la) as lvn.
  remember (pSwap ta (combine la lvn)) as phnew.
  pose proof (pcase
        (@swapPreservesSize G vc (combine la lvn)) _ ta) as Hs.
  specialize (Hdt (pSwap ta (combine la lvn))).
  rewrite Hs in Hdt.
  dimp Hdt. apply Hdt with
        (tb:= (pSwap tb (combine lb lvn))) in hyp.
  unfold pAlphaEqG in hyp.
  rewrite DeqTrue in hyp. allsimpl.
  clear Hs  Hdt.
  clear dependent phnew.
  destruct hyp as [? | Hnal];[left| right];
  pose proof (FreshDistVarsSpec
      (la ++ lb ++ pAllVars ta ++ pAllVars tb) la ) as XX;
  rewrite <- Heqlvn in XX;
  simpl in XX; repnd; dands;
  symmetry in XX.
  - apply alAbP with (lbnew:=lvn);
        cpx; try congruence;
    unfold pFresh; allsimpl; repeat(disjoint_reasoning).
  - introv Hal. apply Hnal. clear Hnal. clear Heqlvn.
    apply betterAbsPElim
    with (lvAvoid:= lvn) in Hal.
     allsimpl. exrepnd.
    apply pAlphaEqEquivariantRev with
    (sw := combine lvn lbnew).
    autorewrite with SwapAppR.
    unfold pFresh in Hal3.
    allsimpl. repnd.
    symmetry in XX.
    autorewrite with slow; try congruence;
    cpx; repeat (disjoint_reasoning);
    repeat match goal with
    [ H : disjoint _ _ |- _ ] => clear H
    | [ H : no_repeats _ _ |- _ ] => clear H
    end.
Defined.

Definition diffVarClasses{G} {sa : GSym G} (ta: Term sa)
            {sb: GSym G} (tb : Term sb) :=
match (ta, tb) with
| (vleaf vca va, vleaf vcb vb)
    => match (DeqVarSym vca vcb) with
      |left _ => False
      |right _ => True
      end
| _ => False
end.

Definition diffPVarClasses{G}
        {sa : GSym G} (ta: Pattern sa)
        {sb: GSym G} (tb : Pattern sb) :=
match (ta, tb) with
| (pvleaf vca va, pvleaf vcb vb)
    => match (DeqVarSym vca vcb) with
      |left _ => False
      |right _ => True
      end
| _ => False
end.

Definition diffTProdsNode {G} {sa : GSym G} (ta: Term sa)
            {sb: GSym G} (tb : Term sb) :=
match (ta, tb) with
| (tnode pa va, tnode pb vb)
    => match (deqPr G pa pb) with
      |left _ => False
      |right _ => True
      end
| _ => False
end.

Definition diffPProdsNode {G} {sa : GSym G}
        (ta: Pattern sa)
            {sb: GSym G} (tb : Pattern sb) :=
match (ta, tb) with
| (pnode pa va, pnode pb vb)
    => match (deqPPr G pa pb) with
      |left _ => False
      |right _ => True
      end
| _ => False
end.

Definition diffEmbedNode {G} {sa : GSym G}
        (ta: Pattern sa)
            {sb: GSym G} (tb : Pattern sb) :=
match (ta, tb) with
| (embed pa va, embed pb vb)
    => match (deqEm G pa pb) with
      |left _ => False
      |right _ => True
      end
| _ => False
end.

Definition isVLeaf {G} {sa : GSym G} (ta: Term sa) :=
match ta with
| vleaf vca va
    => True
| _ => False
end.

Definition isPNode {G} {sa : GSym G}
  (ta: Pattern sa) :=
match ta with
| pnode vca va
    => True
| _ => False
end.

Definition isEmbed {G} {sa : GSym G}
  (ta: Pattern sa) :=
match ta with
| embed vca va
    => True
| _ => False
end.

Lemma alphaEqDecidable : forall {G} (vc : VarSym G),
     (  (forall (sa : GSym G) (ta: Term sa)
            (sb: GSym G) (tb : Term sb),
           decidable (tAlphaEqG vc ta tb))
         *
        (forall (sa : GSym G) (ta: Pattern sa)
            (sb: GSym G) (tb : Pattern sb),
            decidable (pAlphaEqG vc ta tb))
         *
        (forall (l : MixtureParam) (ma mb : Mixture l)
        (lbva : list (list (vType vc)))
        (lbvb : list (list (vType vc))),
           decidable
              (lAlphaEqAbs (MakeAbstractions vc ma lbva)
                           (MakeAbstractions vc mb lbvb)))).
Proof.
  intros.
  GInductionS; introns Hyp; intros;  allsimpl.
- Case "tleaf".
  destruct tb;[ | right; notAlpha | right; notAlpha];[].

  EqDec T T0; [| right; notAlpha]; subst.
  EqDec t t0; [left|right]; subst;
  unfold tAlphaEqG; try rewrite DeqTrue; allsimpl;
  eauto with Alpha;[]; notAlpha.

- Case "vleaf".
  destruct tb; [right; notAlpha | |].
  + EqDec vc0 vc1;[| right]; subst; try EqDecRefl; simpl.
    * EqDec v v0; [left|right]; subst; unfolds_base;
      try rewrite DeqTrue;
      eauto with Alpha.
      notAlpha.

    * notAlpha.
      revert Hseqd0.
      remember (vleaf vc0 v) as vvl.
      remember (vleaf vc1 v0) as vvr.
      assert ( diffVarClasses vvl vvr) as Hdd
       by (subst; unfold diffVarClasses;
          cases_if; cpx).
      clear Heqvvr Heqvvl.
      remember (vSubstType G vc0).
      remember (vSubstType G vc1).
      generalize dependent vvl.
      generalize dependent vvr.
      rewrite H0.
      intros. allsimpl.
      EqDecRefl. simpl.
      clear dependent t.
      clear Hneqvc0vc1.
      clear v0 v vc0 Heqt0 Hseqd0 vc1. introv Hc; inverts Hc;
      EqDecSndEq; subst vvl; subst vvr; repnud Hdd; allsimpl; cpx.
      rewrite DeqTrue in Hdd.
      trivial.
  + right. notAlpha.
    introv Hal. inverts Hal.
    EqDecSndEq.
    GC. clear H6. clear X. clear H0.
    generalize dependent H3.
    remember (vleaf vc0 v) as xx.
    assert (isVLeaf xx) as Hxx by (subst;simpl; auto).
    clear Heqxx.
    generalize dependent xx.
    rewrite Hseqd0.
    allsimpl.
    introv Hisv Heq.
    inverts keep Heq.
    cpx.
- Case "tnode".
  destruct tb; [right; notAlpha;fail | |].

    right. notAlpha;
    remember (vleaf vc0 v) as xx.
    assert (isVLeaf xx) as Hxx by (subst;simpl; auto).
    clear Heqxx.
    generalize dependent xx.
    rewrite <- Hseqd0.
    allsimpl.
    introv Hisv Heq.
    inverts Heq. EqDecSndEq. subst xx.
    cpx; fail.

    EqDec p p0;[| right].
    Focus 2. notAlpha.
    introv Hal.

    remember (tnode p m) as vvl.
    remember (tnode p0 m0) as vvr.
    assert (diffTProdsNode vvl vvr) as Hdd
     by (subst; unfold diffTProdsNode;
        cases_if; cpx).
    clear Heqvvr Heqvvl.
    remember (tpLhs G p).
    remember (tpLhs G p0).
    generalize dependent vvl.
    generalize dependent vvr.
    generalize Hseqd0.
    rewrite H0.
    introv. allsimpl.
    EqDecRefl. simpl.
    clear dependent t.
    introv Hta Hdd.
    clear Hseqd1 Heqt0  Hneqpp0 m0 Hyp m.
    inverts Hta;
    EqDecSndEq;
    subst vvl; subst vvr; repnud Hdd; allsimpl; cpx.
    rewrite DeqTrue in Hdd;
    trivial; fail.

  (* back to the real business *)
  subst p0. unfold tAlphaEqG.
  rewrite DeqTrue.
  simpl. rename m0 into mb.
  destruct (Hyp mb (allBndngVars vc p m) (allBndngVars vc p mb)) as
    [Hleq | Hnleq];[left; constructor;auto | right; notAlpha].

- Case "ptleaf".
  destruct tb;[ | right; notAlpha
                | right; notAlpha
                | right; notAlpha]; [].

  EqDec T T0; [| right; notAlpha]; subst;[].
  EqDec t t0; [left|right]; subst;
  unfold pAlphaEqG; try rewrite DeqTrue; allsimpl;
  eauto with Alpha;[]; notAlpha.

- Case "pvleaf".
  destruct tb;[ right; notAlpha |
                | right; notAlpha
                | right; notAlpha]; [].
  EqDec vc0 vc1;[ left;subst; try EqDecRefl; simpl;
                  unfold pAlphaEqG; rewrite DeqTrue
                  ; constructor; fail
                | right; notAlpha].

- Case "pembed".
  destruct tb;[ right; notAlpha
                | right; notAlpha |
                | right; notAlpha].

  Focus 2.
    introv Hal. inverts Hal.
    EqDecSndEq.
    GC. clear H6. clear X. clear H0.
    generalize dependent H3.
    remember (embed p t) as xx.
    assert (isEmbed xx) as Hxx by (subst;simpl; auto).
    clear Heqxx.
    generalize dependent xx.
    rewrite Hseqd0.
    allsimpl.
    introv Hisv Heq.
    inverts keep Heq.
    cpx; fail.

  EqDec p p0;[ subst p0; unfold pAlphaEqG; rewrite DeqTrue
               | right; notAlpha].
  Focus 2.
    remember (embed p t) as vvl.
    remember (embed p0 t0) as vvr.
    assert (diffEmbedNode vvl vvr) as Hdd
     by (subst; unfold diffEmbedNode;
        cases_if; cpx).
    clear Heqvvr Heqvvl.
    remember (epLhs G p).
    remember (epLhs G p0).
    generalize dependent vvl.
    generalize dependent vvr.
    generalize Hseqd0.
    rewrite H0.
    introv. allsimpl.
    EqDecRefl. simpl.
    clear dependent p.
    introv Hta Hdd.
    clear H0 Hseqd1 Hseqd0 Heqp2 p1 t0 p0.
    inverts Hdd;
    EqDecSndEq;
    subst vvl; subst vvr; repnud Hta; allsimpl; cpx.
    rewrite DeqTrue in Hta;
    trivial; fail.

  (* back to the real business *)
  simpl.
  pose proof (Hyp _ t0) as Hd.
  unfold tAlphaEqG in Hd.
  rewrite DeqTrue in Hd.
  simpl in Hd.
  destruct Hd;[left; constructor; trivial | right; notAlpha].

- Case "pnode".
  destruct tb;[ right; notAlpha
                | right; notAlpha
                | right; notAlpha| ].

    introv Hal. inverts Hal.
    EqDecSndEq.
    GC. clear H6. clear X. clear H0.
    generalize dependent H3.
    remember (pnode p m) as xx.
    assert (isPNode xx) as Hxx by (subst;simpl; auto).
    clear Heqxx.
    generalize dependent xx.
    rewrite Hseqd0.
    allsimpl.
    introv Hisv Heq.
    inverts keep Heq.
    cpx; fail.

    EqDec p p0;[| right].
    Focus 2. notAlpha.
    remember (pnode p m) as vvl.
    remember (pnode p0 m0) as vvr.
    assert (diffPProdsNode vvl vvr) as Hdd
     by (subst; unfold diffPProdsNode;
        cases_if; cpx).
    clear Heqvvr Heqvvl.
    remember (ppLhs G p).
    remember (ppLhs G p0).
    generalize dependent vvl.
    generalize dependent vvr.
    generalize Hseqd0.
    rewrite H0.
    introv. allsimpl.
    EqDecRefl. simpl.
    clear dependent p.
    introv Hta Hdd.
    clear H0 Hseqd1 Hseqd0 Heqp2 p1 m0 p0.
    inverts Hdd;
    EqDecSndEq;
    subst vvl; subst vvr; repnud Hta; allsimpl; cpx.
    rewrite DeqTrue in Hta;
    trivial; fail.

    (* back to the real business *)
  subst p0. unfold pAlphaEqG.
  rewrite DeqTrue.
  simpl. rename m0 into mb.
  destruct (Hyp mb [] []) as
  [Hleq | Hnleq];[left; constructor;auto | right; notAlpha].

- Case "mnil".
  dependent inversion mb. simpl. left.
  constructor.

- Case "mtcons".
  dependent inversion mb. simpl.
  subst.
  remember (lhead lbva) as lha.
  remember (lhead lbvb) as lhb.
  remember (tail lbva) as lta.
  remember (tail lbvb) as ltb.
  clear Heqlha Heqlhb Heqlta Heqltb.
  specialize (Hyp0 m lta ltb).
  destruct (Hyp0); [| right ; notAlpha].
  destruct (decideAbsT vc ph Hyp h t lha lhb);
    [left; constructor; auto| right; notAlpha].

- Case "mpcons".
  dependent inversion mb. simpl.
  subst.
  remember (lhead lbva) as lha.
  remember (lhead lbvb) as lhb.
  remember (tail lbva) as lta.
  remember (tail lbvb) as ltb.
  clear Heqlha Heqlhb Heqlta Heqltb.
  specialize (Hyp0 m lta ltb).
  destruct (Hyp0); [| right ; notAlpha].
  destruct (decideAbsP vc ph Hyp h p lha lhb);
    [left; constructor; auto| right; notAlpha].
Defined.

(*
Definition transpEm {G} {pl pr : EmbedProd G}
  (eqq : pl = pr)
  (tl : Term (gsymTN (epRhs G pl))) :=
(@transport _ _ _ (fun p => Term (gsymTN (epRhs G p)))  eqq tl).

Fixpoint tAlphaEqb {G} (vc : VarSym G) {gs : GSym G}
  (tl tr : Term gs) {struct tr}: bool :=
match (tl,tr) with
| (tnode pl ml, tnode pr mr) => true
| (tleaf tcl tl, tleaf tcr tr)
    => Deq2Bool (deqSigTSemType)
          (existT _ tcl tl) (existT _ tcr tr)
| (vleaf tcl tl, vleaf tcr tr)
    => Deq2Bool (deqSigVType)
          (existT _ tcl tl) (existT _ tcr tr)
| _ => false
end
with  pAlphaEqb {G} (vc : VarSym G) {gs : GSym G}
  (tl tr : Pattern gs) {struct tr} : bool :=
match (tl,tr) with
| (pnode pl ml, pnode pr mr) => true
| (ptleaf tcl tl, ptleaf tcr tr)
    => Deq2Bool (deqSigTSemType)
          (existT _ tcl tl) (existT _ tcr tr)
| (pvleaf tcl tl, pvleaf tcr tr)
    => Deq2Bool (deqSigVType)
          (existT _ tcl tl) (existT _ tcr tr)
| (embed pl tl, embed pr tr) =>
     match (deqEm G pl pr) with
     | right _ => false
     | left eqq => tAlphaEqb vc (transpEm eqq tl) tr
     end
| _ => false
end
with AlphaEqAbsb {G} (vc : VarSym G)
  (tl tr : Abstraction G vc) {struct tr}: bool :=
match (tl,tr) with
| (termAbs gsl lvl tll, termAbs gsr lvr trr) =>
    (beq_nat (length lvl) (length lvr)) &&
    match (deqGSym gsl gsr) with
    | right _ => false
    | left eqq => tAlphaEqb vc (transport eqq tll) trr
    end
| (patAbs _ lvl tl, patAbs _ lvr tr) => true
|  _ => false
end.

*)