From stdpp Require Import coPset namespaces.
From iris.bi Require Export bi updates.
From iris.bi.lib Require Import fixpoint.
From iris.proofmode Require Import coq_tactics proofmode reduction.
From iris.prelude Require Import options.
From iris.base_logic Require Import invariants.
From iris.program_logic Require Import weakestpre.

(** Conveniently split a conjunction on both assumption and conclusion. *)
Local Tactic Notation "iSplitWith" constr(H) :=
  iApply (bi.and_parallel with H); iSplit; iIntros H.

Section post_definition.
  Context `{BiFUpd PROP} {TC : tele}.
  Implicit Types
    (Eo Ei : coPset) (* outer/inner masks *)
    (Ψ : TC → PROP) (* atomic post-condition *)
    (Q : PROP) (* keep Ψ condition *)
    (Φ : PROP) (* post-condition *)
  .

  (** atomic_post_acc as the "introduction form" of atomic post-conditions: An
      accessor that can return to [Q]. *)
  Definition atomic_post_acc Eo Ei Ψ Q Φ : PROP :=
    |={Eo, Ei}=> ∃.. z, Ψ z ∗ ((Ψ z ={Ei, Eo}=∗ Q) ∧ (Ψ z ={Ei, Eo}=∗ Φ)).

  Lemma atomic_post_acc_wand Eo Ei Ψ Q1 Q2 Φ1 Φ2 :
    ((Q1 -∗ Q2) ∧ (Φ1 -∗ Φ2)) -∗
    (atomic_post_acc Eo Ei Ψ Q1 Φ1 -∗ atomic_post_acc Eo Ei Ψ Q2 Φ2).
  Proof.
    iIntros "HQΦ Hpost".
    iMod "Hpost" as (z) "[HΨ Hclose]". iModIntro.
    iExists z. iFrame "HΨ". iSplitWith "Hclose".
    + iIntros "HΨ". iMod ("Hclose" with "HΨ") as "HQ".
      iModIntro. iApply "HQΦ". done.
    + iIntros "HΨ". iMod ("Hclose" with "HΨ") as "HΦ".
      iModIntro. iApply "HQΦ". done.
  Qed.

  Lemma atomic_post_acc_mask_weaken Eo1 Eo2 Ei Ψ Q Φ :
    Eo1 ⊆ Eo2 →
    atomic_post_acc Eo1 Ei Ψ Q Φ -∗ atomic_post_acc Eo2 Ei Ψ Q Φ.
  Proof.
    iIntros (HE) "Hpost".
    iMod (fupd_mask_subseteq Eo1) as "Hclose'"; first done.
    iMod "Hpost" as (z) "[HΨ Hclose]". iModIntro.
    iExists z. iFrame "HΨ". iSplitWith "Hclose".
    + iIntros "HΨ". iMod ("Hclose" with "HΨ") as "HQ".
      iMod "Hclose'" as "_". iModIntro. done.
    + iIntros "HΨ". iMod ("Hclose" with "HΨ") as "HΦ".
      iMod "Hclose'" as "_". iModIntro. done.
  Qed.

  (** atomic_post as a fixed-point of the equation
   AP = atomic_post_acc Ψ AP Φ
  *)
  Context Eo Ei Ψ Φ.

  Definition atomic_post_pre (Θ : () → PROP) (_ : ()) : PROP :=
    atomic_post_acc Eo Ei Ψ (Θ ()) Φ.

  Local Instance atomic_post_pre_mono : BiMonoPred atomic_post_pre.
  Proof.
    constructor.
    - iIntros (Q1 Q2 ??) "#HQ12". iIntros ([]) "AP".
      iApply (atomic_post_acc_wand with "[HQ12] AP").
      iSplit; last auto. iApply "HQ12".
    - intros ??. solve_proper.
  Qed.

  Local Definition atomic_post_def :=
    bi_greatest_fixpoint atomic_post_pre ().

End post_definition.

(** Seal it *)
Local Definition atomic_post_aux : seal (@atomic_post_def).
Proof. by eexists. Qed.
Definition atomic_post := atomic_post_aux.(unseal).
Global Arguments atomic_post {PROP _ TC}.
Local Definition atomic_post_unseal :
  @atomic_post = _ := atomic_post_aux.(seal_eq).

Global Arguments atomic_post_acc {PROP _ TC} Eo Ei _ _ _ : simpl never.
Global Arguments atomic_post {PROP _ TC} Eo Ei _ _ : simpl never.

(** Notation: Atomic post-conditions *)
Notation "'AP' '<<' ∃∃ z1 .. zn , Ψ '>>' @ Eo , Ei '<<' 'COMM' Φ '>>'" :=
  (atomic_post (TC:=TeleS (λ z1, .. (TeleS (λ zn, TeleO)) .. ))
               Eo Ei
               (tele_app $ λ z1, .. (λ zn, Ψ%I) ..)
               Φ%I
  )
  (at level 20, Eo, Ei, Ψ, Φ at level 200, z1 binder, zn binder,
   format "'[hv   ' 'AP'  '<<'  '[' ∃∃  x1  ..  xn ,  '/' Ψ  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' COMM  Φ  ']' '>>' ']'") : bi_scope.

Notation "'AP' '<<' Ψ '>>' @ Eo , Ei '<<' 'COMM' Φ '>>'" :=
  (atomic_post (TC:=TeleO) Eo Ei (tele_app Ψ%I) Φ%I
  )
  (at level 20, Eo, Ei, Ψ, Φ at level 200,
   format "'[hv   ' 'AP'  '<<'  '[' Ψ  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' COMM  Φ  ']' '>>' ']'") : bi_scope.

(** Lemmas about AP *)
Section post_lemmas.
  Context `{BiFUpd PROP}.

  Local Existing Instance atomic_post_pre_mono.

  (* Can't be in the section above as that fixes the parameters *)
  Global Instance atomic_post_acc_ne {TC : tele} Eo Ei n :
    Proper (
        pointwise_relation TC (dist n) ==>
        dist n ==>
        dist n ==>
        dist n
    ) (atomic_post_acc (PROP:=PROP) Eo Ei).
  Proof. solve_proper. Qed.

  Global Instance atomic_post_ne {TC : tele} Eo Ei n :
    Proper (
        pointwise_relation TC (dist n) ==>
        dist n ==>
        dist n
    ) (atomic_post (PROP:=PROP) Eo Ei).
  Proof.
    rewrite atomic_post_unseal /atomic_post_def /atomic_post_pre. solve_proper.
  Qed.

  Lemma atomic_post_mask_weaken {TC : tele} Eo1 Eo2 Ei (Ψ : TC → PROP) Φ :
    Eo1 ⊆ Eo2 →
    atomic_post Eo1 Ei Ψ Φ -∗ atomic_post Eo2 Ei Ψ Φ.
  Proof.
    rewrite atomic_post_unseal {2}/atomic_post_def /=.
    iIntros (Heo) "HAP".
    iApply (greatest_fixpoint_coiter _ (λ _, atomic_post_def Eo1 Ei Ψ Φ)); last done.
    iIntros "!> *". rewrite {1}/atomic_post_def /= greatest_fixpoint_unfold.
    iApply atomic_post_acc_mask_weaken. done.
  Qed.

  Lemma atomic_post_wand {TC : tele} Eo Ei (Ψ : TC → PROP) Φ1 Φ2 :
    (Φ1 -∗ Φ2) -∗
    (atomic_post Eo Ei Ψ Φ1 -∗ atomic_post Eo Ei Ψ Φ2).
  Proof.
    rewrite atomic_post_unseal {2}/atomic_post_def /=.
    iIntros "HΦ Hpost".
    iApply (greatest_fixpoint_coiter _ (λ _, (Φ1 -∗ Φ2) ∗ atomic_post_def Eo Ei Ψ Φ1)%I); last iFrame.
    iIntros "!> * [HΦ Hpost]". rewrite {1}/atomic_post_def /= greatest_fixpoint_unfold.
    iApply (atomic_post_acc_wand with "[HΦ]"); last iFrame.
    iSplit; last done. iIntros; by iFrame.
  Qed.

  Lemma apst_unfold {TC : tele} Eo Ei (Ψ : TC → PROP) Φ :
    atomic_post Eo Ei Ψ Φ ⊣⊢
    atomic_post_acc Eo Ei Ψ (atomic_post Eo Ei Ψ Φ) Φ.
  Proof.
    rewrite atomic_post_unseal /atomic_post_def /=. apply: greatest_fixpoint_unfold.
  Qed.

  (* This lets you eliminate atomic updates with iMod. *)
  Global Instance elim_mod_apost {TC : tele} φ Eo Ei E (Ψ : TC → PROP) Φ Q Q' :
    (∀ R, ElimModal φ false false (|={E,Ei}=> R) R Q Q') →
    ElimModal (φ ∧ Eo ⊆ E) false false
              (atomic_post Eo Ei Ψ Φ)
              (∃.. z, Ψ z ∗ ((Ψ z ={Ei,E}=∗ atomic_post Eo Ei Ψ Φ) ∧ (Ψ z ={Ei,E}=∗ Φ)))
              Q Q'.
  Proof.
    intros ?. rewrite /ElimModal /= =>-[??]. iIntros "[AP Hcont]".
    iDestruct (apst_unfold with "AP") as "AC".
    iMod (atomic_post_acc_mask_weaken with "AC"); first done.
    iApply "Hcont". done.
  Qed.

  Local Lemma apst_intro {TC : tele} Eo Ei (Ψ : TC → PROP) Φ :
    Ei ⊆ Eo →
    (∃.. z, Ψ z ∗ (Ψ z -∗ Φ)) -∗
    atomic_post Eo Ei Ψ Φ.
  Proof.
    iIntros (HE) "(%z & HΨ & HΦ)".
    rewrite atomic_post_unseal /atomic_post_def /=.
    iApply (greatest_fixpoint_coiter _ (λ _, (Ψ z ∗ (Ψ z -∗ Φ))%I)); last iFrame.
    iIntros "!> * [HΨ HΦ]". iApply (atomic_post_acc_wand with "[HΦ]").
    + iSplit; first iIntros "?"; by iFrame.
    + iApply fupd_mask_intro; first done.
      iIntros "Hclose". iExists z. iFrame "HΨ".
      iSplit; iIntros "HΨ"; iMod "Hclose" as "_"; iModIntro; iFrame.
  Qed.

  Lemma apst_apst_sup {TC TC' : tele} E1 E1' E2 E3
        (Ψ : TC → PROP) (Φ : PROP)
        (Ψ' : TC' → PROP) (Φ' : PROP)
        (R : PROP):
    E1' ⊆ E1 → E3 ⊆ E2 →
    R -∗
    □ (∀.. z, R ∗ Ψ z -∗ ∃.. z', (Ψ' z' ∗ (Ψ' z' -∗ R ∗ Ψ z))) -∗
    atomic_post E1' E2 Ψ Φ -∗
    (R ∗ atomic_post E1' E2 Ψ Φ ={E1}=∗ Φ') -∗
    atomic_post E1 E3 Ψ' Φ'.
  Proof.
    iIntros (??) "HR #HRΨΨ' AP Hstep".
    rewrite {3} atomic_post_unseal /atomic_post_def /=.
    iApply (greatest_fixpoint_coiter _ (λ _, (R ∗ atomic_post E1' E2 Ψ Φ ∗
      (R ∗ atomic_post E1' E2 Ψ Φ ={E1}=∗ Φ')
    )%I)); last iFrame.
    iIntros "!> * [HR [AP Hstep]]".
    iMod (atomic_post_mask_weaken with "AP") as (z) "[HΨ [Hclose _]]"; first done.
    iApply fupd_mask_intro; first done. iIntros "Hclose'".
    iDestruct ("HRΨΨ'" with "[$]") as (z') "[HΨ' HRΨ]".
    iExists z'. iFrame "HΨ'".
    iSplit; iIntros "HΨ'"; iMod "Hclose'" as "_";
      iDestruct ("HRΨ" with "HΨ'") as "[HR HΨ]";
      iMod ("Hclose" with "HΨ") as "HΦ".
    + iModIntro. iFrame.
    + iApply "Hstep". iFrame.
  Qed.

  Lemma apst_apst_sub {TC TC' : tele} E1 E1' E2 E3
        (Ψ : TC → PROP) (Φ : PROP)
        (Ψ' : TC' → PROP) (Φ' : PROP) :
    E1' ⊆ E1 → E3 ⊆ E2 →
    □ (∀.. z, Ψ z -∗ ∃.. z', (Ψ' z' ∗ (Ψ' z' -∗ Ψ z))) -∗
    atomic_post E1' E2 Ψ Φ -∗
    (atomic_post E1' E2 Ψ Φ ={E1}=∗ Φ') -∗
    atomic_post E1 E3 Ψ' Φ'.
  Proof.
    iIntros (??) "#HΨΨ' AP Hstep".
    rewrite {3} atomic_post_unseal /atomic_post_def /=.
    iApply (greatest_fixpoint_coiter _ (λ _, (atomic_post E1' E2 Ψ Φ ∗
      (atomic_post E1' E2 Ψ Φ ={E1}=∗ Φ')
    )%I)); last iFrame.
    iIntros "!> * [AP Hstep]".
    iMod (atomic_post_mask_weaken with "AP") as (z) "[HΨ [Hclose _]]"; first done.
    iApply fupd_mask_intro; first done. iIntros "Hclose'".
    iDestruct ("HΨΨ'" with "HΨ") as (z') "[HΨ' HΨ]".
    iExists z'. iFrame "HΨ'".
    iSplit; iIntros "HΨ'"; iMod "Hclose'" as "_";
      iDestruct ("HΨ" with "HΨ'") as "HΨ";
      iMod ("Hclose" with "HΨ") as "HΦ".
    + iModIntro. iFrame.
    + by iApply "Hstep".
  Qed.

  Lemma apst_apst_eq {TC : tele} E1 E1' E2 E3
        (Ψ : TC → PROP) Φ
        (Φ' : PROP) :
    E1' ⊆ E1 → E3 ⊆ E2 →
    atomic_post E1' E2 Ψ Φ -∗
    (atomic_post E1' E2 Ψ Φ ={E1}=∗ Φ') -∗
    atomic_post E1 E3 Ψ Φ'.
  Proof.
    iIntros (??) "AP Hstep".
    iApply (apst_apst_sub with "[] AP"); try done.
    iIntros "!> * %z HΨ". iExists z. iFrame; iIntros; iFrame.
  Qed.

  Lemma atomic_post_commit {TC : tele} Eo Ei (Ψ : TC → PROP) Φ :
    atomic_post Eo Ei Ψ Φ ={Eo}=∗ Φ.
  Proof.
    iIntros "AP". iMod "AP" as (z) "[HΨ [_ HΦ]]".
    iMod ("HΦ" with "HΨ"). by iModIntro.
  Qed.

End post_lemmas.

Section definition.
  Context `{BiFUpd PROP} {TA TB TC : tele}.
  Implicit Types
    (Eo Ei : coPset) (* outer/inner masks *)
    (α : TA → PROP) (* atomic pre-condition *)
    (P : PROP) (* abortion condition *)
    (Ψ : TC → PROP) (* atomic post-condition *)
    (β : TA → TB → PROP)
    (Φ : TA → TB → PROP) (* post-condition *)
  .

  (** atomic_acc as the "introduction form" of atomic updates: An accessor
      that can be aborted back to [P]. *)
  Definition atomic_acc Eo Ei α P Ψ β Φ : PROP :=
    |={Eo, Ei}=> ∃.. x, α x ∗ (
          (α x ={Ei, Eo}=∗ P) ∧ (* abort *)
          (∀.. y, β x y ={Ei, Eo}=∗ atomic_post Eo Ei Ψ (Φ x y)) (* commit *)
    ).

  Lemma atomic_acc_wand Eo Ei α P1 P2 Ψ β Φ1 Φ2 :
    ((P1 -∗ P2) ∧ (∀.. x y, Φ1 x y -∗ Φ2 x y)) -∗
    (atomic_acc Eo Ei α P1 Ψ β Φ1 -∗ atomic_acc Eo Ei α P2 Ψ β Φ2).
  Proof.
    iIntros "HPΦ AS". iMod "AS" as (x) "[Hα Hclose]".
    iModIntro. iExists x. iFrame "Hα". iSplit.
    - iIntros "Hα". iDestruct "Hclose" as "[Hclose _]".
      iApply "HPΦ". iApply "Hclose". done.
    - iIntros (y) "Hβ". iDestruct "Hclose" as "[_ Hclose]".
      iMod ("Hclose" with "Hβ") as "HΦ1".
      iModIntro. iDestruct "HPΦ" as "[_ HΦ]".
      iApply (atomic_post_wand with "HΦ"). done.
  Qed.

  Lemma atomic_acc_mask_weaken Eo1 Eo2 Ei α P Ψ β Φ :
    Eo1 ⊆ Eo2 →
    atomic_acc Eo1 Ei α P Ψ β Φ -∗ atomic_acc Eo2 Ei α P Ψ β Φ.
  Proof.
    iIntros (HE) "Hstep".
    iMod (fupd_mask_subseteq Eo1) as "Hclose'"; first done.
    iMod "Hstep" as (x) "[Hα Hclose]". iModIntro. iExists x.
    iFrame. iSplitWith "Hclose".
    - iIntros "Hα". iMod ("Hclose" with "Hα") as "$". done.
    - iIntros (y) "Hβ". iMod ("Hclose" with "Hβ") as "HΦ".
      iMod "Hclose'" as "_". iModIntro.
      iApply atomic_post_mask_weaken; done.
  Qed.

  (** atomic_update as a fixed-point of the equation
   AU = atomic_acc α AU Ψ β Φ
  *)
  Context Eo Ei α Ψ β Φ.

  Definition atomic_update_pre (Θ : () → PROP) (_ : ()) : PROP :=
    atomic_acc Eo Ei α (Θ ()) Ψ β Φ.

  Local Instance atomic_update_pre_mono : BiMonoPred atomic_update_pre.
  Proof.
    constructor.
    - iIntros (P1 P2 ??) "#HP12". iIntros ([]) "AU".
      iApply (atomic_acc_wand with "[HP12] AU").
      iSplit; last by eauto. iApply "HP12".
    - intros ??. solve_proper.
  Qed.

  Local Definition atomic_update_def :=
    bi_greatest_fixpoint atomic_update_pre ().

End definition.

(** Seal it *)
Local Definition atomic_update_aux : seal (@atomic_update_def).
Proof. by eexists. Qed.
Definition atomic_update := atomic_update_aux.(unseal).
Global Arguments atomic_update {PROP _ TA TB TC}.
Local Definition atomic_update_unseal :
  @atomic_update = _ := atomic_update_aux.(seal_eq).

Global Arguments atomic_acc {PROP _ TA TB TC} Eo Ei _ _ _ _ _ : simpl never.
Global Arguments atomic_update {PROP _ TA TB TC} Eo Ei _ _ _ _ : simpl never.

(** Notation: Atomic updates *)
(* The way to read the [tele_app foo] here is that they convert the n-ary
function [foo] into a unary function taking a telescope as the argument. *)
Notation "'AU' '<<' ∃∃ x1 .. xn , α '>>' @ Eo , Ei '<<' ∀∀ y1 .. yn , β , 'POST' ∃∃ z1 .. zn , Ψ , 'COMM' Φ '>>'" :=
  (atomic_update (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
                 (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                 (TC:=TeleS (λ z1, .. (TeleS (λ zn, TeleO)) .. ))
                 Eo Ei
                 (tele_app $ λ x1, .. (λ xn, α%I) ..)
                 (tele_app $ λ z1, .. (λ zn, Ψ%I) ..)
                 (tele_app $ λ x1, .. (λ xn,
                         tele_app (λ y1, .. (λ yn, β%I) .. )
                        ) .. )
                 (tele_app $ λ x1, .. (λ xn,
                         tele_app (λ y1, .. (λ yn, Φ%I) .. )
                        ) .. )
  )
  (at level 20, Eo, Ei, α, Ψ, β, Φ at level 200, x1 binder, xn binder, y1 binder, yn binder, z1 binder, zn binder,
   format "'[hv   ' 'AU'  '<<'  '[' ∃∃  x1  ..  xn ,  '/' α  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' ∀∀  y1  ..  yn ,  '/' β ,  '/' POST  '[' ∃∃  z1  ..  zn ,  '/' Ψ  ']' ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

Notation "'AU' '<<' ∃∃ x1 .. xn , α '>>' @ Eo , Ei '<<' β , 'POST' ∃∃ z1 .. zn , Ψ , 'COMM' Φ '>>'" :=
  (atomic_update (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
                 (TB:=TeleO)
                 (TC:=TeleS (λ z1, .. (TeleS (λ zn, TeleO)) .. ))
                 Eo Ei
                 (tele_app $ λ x1, .. (λ xn, α%I) ..)
                 (tele_app $ λ z1, .. (λ zn, Ψ%I) ..)
                 (tele_app $ λ x1, .. (λ xn, tele_app β%I) .. )
                 (tele_app $ λ x1, .. (λ xn, tele_app Φ%I) .. )
  )
  (at level 20, Eo, Ei, α, Ψ, β, Φ at level 200, x1 binder, xn binder, z1 binder, zn binder,
   format "'[hv   ' 'AU'  '<<'  '[' ∃∃  x1  ..  xn ,  '/' α  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' β ,  '/' POST  '[' ∃∃  z1  ..  zn ,  '/' Ψ  ']' ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

Notation "'AU' '<<' α '>>' @ Eo , Ei '<<' ∀∀ y1 .. yn , β , 'POST' Ψ , 'COMM' Φ '>>'" :=
  (atomic_update (TA:=TeleO)
                 (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                 (TC:=TeleO)
                 Eo Ei
                 (tele_app α%I)
                 (tele_app Ψ%I)
                 (tele_app $ tele_app (λ y1, .. (λ yn, β%I) ..))
                 (tele_app $ tele_app (λ y1, .. (λ yn, Φ%I) ..))
  )
  (at level 20, Eo, Ei, α, Ψ, β, Φ at level 200, y1 binder, yn binder,
   format "'[hv   ' 'AU'  '<<'  '[' α  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' ∀∀  y1  ..  yn ,  '/' β ,  '/' POST  Ψ ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

Notation "'AU' '<<' α '>>' @ Eo , Ei '<<' β , 'POST' Ψ , 'COMM' Φ '>>'" :=
  (atomic_update (TA:=TeleO) (TB:=TeleO) (TC:=TeleO)
                 Eo Ei
                 (tele_app α%I)
                 (tele_app Ψ%I)
                 (tele_app $ tele_app β%I)
                 (tele_app $ tele_app Φ%I)
  )
  (at level 20, Eo, Ei, α, Ψ, β, Φ at level 200,
   format "'[hv   ' 'AU'  '<<'  '[' α  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' β ,  '/' POST  Ψ ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

(** Notation: Atomic accessors *)
Notation "'AACC' '<<' ∃∃ x1 .. xn , α , 'ABORT' P '>>' @ Eo , Ei '<<' ∀∀ y1 .. yn , β , 'POST' ∃∃ z1 .. zn , Ψ , 'COMM' Φ '>>'" :=
  (atomic_acc (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
              (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
              (TC:=TeleS (λ z1, .. (TeleS (λ zn, TeleO)) .. ))
              Eo Ei
              (tele_app $ λ x1, .. (λ xn, α%I) ..)
              P%I
              (tele_app $ λ z1, .. (λ zn, Ψ%I) ..)
              (tele_app $ λ x1, .. (λ xn,
                      tele_app (λ y1, .. (λ yn, β%I) .. )
                     ) .. )
              (tele_app $ λ x1, .. (λ xn,
                      tele_app (λ y1, .. (λ yn, Φ%I) .. )
                     ) .. )
  )
  (at level 20, Eo, Ei, α, P, Ψ, β, Φ at level 200, x1 binder, xn binder, y1 binder, yn binder, z1 binder, zn binder,
   format "'[hv     ' 'AACC'  '<<'  '[' ∃∃  x1  ..  xn ,  '/' α ,  '/' ABORT  P  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' ∀∀  y1  ..  yn ,  '/' β ,  '/' POST  '[' ∃∃  z1  ..  zn ,  '/' Ψ  ']' ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

Notation "'AACC' '<<' ∃∃ x1 .. xn , α , 'ABORT' P '>>' @ Eo , Ei '<<' β , 'POST' ∃∃ z1 .. zn , Ψ , 'COMM' Φ '>>'" :=
  (atomic_acc (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
              (TB:=TeleO)
              (TC:=TeleS (λ z1, .. (TeleS (λ zn, TeleO)) .. ))
              Eo Ei
              (tele_app $ λ x1, .. (λ xn, α%I) ..)
              P%I
              (tele_app $ λ z1, .. (λ zn, Ψ%I) ..)
              (tele_app $ λ x1, .. (λ xn, tele_app β%I) .. )
              (tele_app $ λ x1, .. (λ xn, tele_app Φ%I) .. )
  )
  (at level 20, Eo, Ei, α, P, Ψ, β, Φ at level 200, x1 binder, xn binder, z1 binder, zn binder,
   format "'[hv     ' 'AACC'  '<<'  '[' ∃∃  x1  ..  xn ,  '/' α ,  '/' ABORT  P  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' β ,  '/' POST  '[' ∃∃  z1  ..  zn ,  '/' Ψ  ']' ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

Notation "'AACC' '<<' α , 'ABORT' P '>>' @ Eo , Ei '<<' ∀∀ y1 .. yn , β , 'POST' Ψ , 'COMM' Φ '>>'" :=
  (atomic_acc (TA:=TeleO)
              (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
              (TC:=TeleO)
              Eo Ei
              (tele_app α%I)
              P%I
              (tele_app Ψ%I)
              (tele_app $ tele_app (λ y1, .. (λ yn, β%I) ..))
              (tele_app $ tele_app (λ y1, .. (λ yn, Φ%I) ..))
  )
  (at level 20, Eo, Ei, α, P, Ψ, β, Φ at level 200, y1 binder, yn binder,
   format "'[hv     ' 'AACC'  '<<'  '[' α ,  '/' ABORT  P  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' ∀∀  y1  ..  yn ,  '/' β ,  '/' POST  Ψ ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

Notation "'AACC' '<<' α , 'ABORT' P '>>' @ Eo , Ei '<<' β , 'POST' Ψ , 'COMM' Φ '>>'" :=
  (atomic_acc (TA:=TeleO)
              (TB:=TeleO)
              (TC:=TeleO)
              Eo Ei
              (tele_app α%I)
              P%I
              (tele_app Ψ%I)
              (tele_app $ tele_app β%I)
              (tele_app $ tele_app Φ%I)
  )
  (at level 20, Eo, Ei, α, P, Ψ, β, Φ at level 200,
   format "'[hv     ' 'AACC'  '<<'  '[' α ,  '/' ABORT  P  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' β ,  '/' POST  Ψ ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

(** Lemmas about AU *)
Section lemmas.
  Context `{BiFUpd PROP}.

  Local Existing Instance atomic_update_pre_mono.

  (* Can't be in the section above as that fixes the parameters *)
  Global Instance atomic_acc_ne {TA TB TC : tele} Eo Ei n :
    Proper (
        pointwise_relation TA (dist n) ==>
        dist n ==>
        pointwise_relation TC (dist n) ==>
        pointwise_relation TA (pointwise_relation TB (dist n)) ==>
        pointwise_relation TA (pointwise_relation TB (dist n)) ==>
        dist n
    ) (atomic_acc (PROP:=PROP) Eo Ei).
  Proof. solve_proper. Qed.

  Global Instance atomic_update_ne {TA TB TC : tele} Eo Ei n :
    Proper (
        pointwise_relation TA (dist n) ==>
        pointwise_relation TC (dist n) ==>
        pointwise_relation TA (pointwise_relation TB (dist n)) ==>
        pointwise_relation TA (pointwise_relation TB (dist n)) ==>
        dist n
    ) (atomic_update (PROP:=PROP) Eo Ei).
  Proof.
    rewrite atomic_update_unseal /atomic_update_def /atomic_update_pre. solve_proper.
  Qed.

  Lemma atomic_update_mask_weaken {TA TB TC : tele} Eo1 Eo2 Ei
      (α : TA → PROP) (Ψ : TC → PROP) (β Φ : TA → TB → PROP) :
    Eo1 ⊆ Eo2 →
    atomic_update Eo1 Ei α Ψ β Φ -∗ atomic_update Eo2 Ei α Ψ β Φ.
  Proof.
    rewrite atomic_update_unseal {2}/atomic_update_def /=.
    iIntros (Heo) "HAU".
    iApply (greatest_fixpoint_coiter _ (λ _, atomic_update_def Eo1 Ei α Ψ β Φ)); last done.
    iIntros "!> *". rewrite {1}/atomic_update_def /= greatest_fixpoint_unfold.
    iApply atomic_acc_mask_weaken. done.
  Qed.

  Lemma atomic_update_wand {TA TB TC : tele} Eo Ei
    (α : TA → PROP) (Ψ : TC → PROP) (β Φ1 Φ2 : TA → TB → PROP) :
    (∀.. x y, Φ1 x y -∗ Φ2 x y) -∗
    (atomic_update Eo Ei α Ψ β Φ1 -∗ atomic_update Eo Ei α Ψ β Φ2).
  Proof.
    rewrite atomic_update_unseal {2}/atomic_update_def /=.
    iIntros "HΦ Hupd".
    iApply (greatest_fixpoint_coiter _ (λ _, (∀.. x y, Φ1 x y -∗ Φ2 x y) ∗
      atomic_update_def Eo Ei α Ψ β Φ1
    )%I); last iFrame.
    iIntros "!> * [HΦ Hupd]". rewrite {1}/atomic_update_def /= greatest_fixpoint_unfold.
    iApply (atomic_acc_wand with "[HΦ]"); last iFrame.
    iSplit; last done. iIntros; by iFrame.
  Qed.

  Local Lemma aupd_unfold {TA TB TC : tele} Eo Ei
      (α : TA → PROP) (Ψ : TC → PROP) (β Φ : TA → TB → PROP) :
    atomic_update Eo Ei α Ψ β Φ ⊣⊢
    atomic_acc Eo Ei α (atomic_update Eo Ei α Ψ β Φ) Ψ β Φ.
  Proof.
    rewrite atomic_update_unseal /atomic_update_def /=. apply: greatest_fixpoint_unfold.
  Qed.

  (** The elimination form: an atomic accessor *)
  Lemma aupd_aacc {TA TB TC : tele} Eo Ei
      (α : TA → PROP) (Ψ : TC → PROP) (β Φ : TA → TB → PROP) :
    atomic_update Eo Ei α Ψ β Φ -∗
    atomic_acc Eo Ei α (atomic_update Eo Ei α Ψ β Φ) Ψ β Φ.
  Proof using Type*. by rewrite {1}aupd_unfold. Qed.

  (* This lets you eliminate atomic updates with iMod. *)
  Global Instance elim_mod_aupd {TA TB TC : tele} φ Eo Ei E
      (α : TA → PROP) (Ψ : TC → PROP) (β Φ : TA → TB → PROP) Q Q' :
    (∀ R, ElimModal φ false false (|={E,Ei}=> R) R Q Q') →
    ElimModal (φ ∧ Eo ⊆ E) false false
              (atomic_update Eo Ei α Ψ β Φ)
              (∃.. x, α x ∗
                       (α x ={Ei,E}=∗ atomic_update Eo Ei α Ψ β Φ) ∧
                       (∀.. y, β x y ={Ei,E}=∗ atomic_post E Ei Ψ (Φ x y)))
              Q Q'.
  Proof.
    intros ?. rewrite /ElimModal /= =>-[??]. iIntros "[AU Hcont]".
    iPoseProof (aupd_aacc with "AU") as "AC".
    iMod (atomic_acc_mask_weaken with "AC"); first done.
    iApply "Hcont". done.
  Qed.

  (** The introduction lemma for atomic_update. This should usually not be used
  directly; use the [iAuIntro] tactic instead. *)
  Local Lemma aupd_intro {TA TB TC : tele} Eo Ei
      (α : TA → PROP) P Q (Ψ : TC → PROP) (β Φ : TA → TB → PROP) :
    Absorbing P → Persistent P →
    (P ∧ Q -∗ atomic_acc Eo Ei α Q Ψ β Φ) →
    P ∧ Q -∗ atomic_update Eo Ei α Ψ β Φ.
  Proof.
    rewrite atomic_update_unseal {1}/atomic_update_def /=.
    iIntros (?? HAU) "[#HP HQ]".
    iApply (greatest_fixpoint_coiter _ (λ _, Q)); last done. iIntros "!>" ([]) "HQ".
    iApply HAU. iSplit; by iFrame.
  Qed.

  Lemma aacc_intro {TA TB TC : tele} Eo Ei
      (α : TA → PROP) P (Ψ : TC → PROP) (β Φ : TA → TB → PROP) :
    Ei ⊆ Eo → ⊢ (∀.. x, α x -∗ (
      (α x ={Eo}=∗ P) ∧
      (∀.. y, β x y ={Eo}=∗ ∃.. z, Ψ z ∗ (Ψ z -∗ Φ x y))
    ) -∗
    atomic_acc Eo Ei α P Ψ β Φ).
  Proof.
    iIntros (? x) "Hα Hclose".
    iApply fupd_mask_intro; first set_solver. iIntros "Hclose'".
    iExists x. iFrame. iSplitWith "Hclose".
    - iIntros "Hα". iMod "Hclose'" as "_". iApply "Hclose". done.
    - iIntros (y) "Hβ". iMod "Hclose'" as "_". iMod ("Hclose" with "Hβ").
      iModIntro. by iApply apst_intro.
  Qed.

  (* This lets you open invariants etc. when the goal is an atomic accessor. *)
  Global Instance elim_acc_aacc {TA TB TC : tele} {X} E1 E2 Ei
      (α' β' : X → PROP) γ'
      (α : TA → PROP) Pas (Ψ : TC → PROP) (β Φ : TA → TB → PROP) :
    ElimAcc (X:=X) True (fupd E1 E2) (fupd E2 E1) α' β' γ'
            (atomic_acc E1 Ei α Pas Ψ β Φ)
            (λ x',
              atomic_acc E2 Ei α (β' x' ∗ (γ' x' -∗? Pas))%I Ψ β
              (λ.. x y, β' x' ∗ (γ' x' -∗? atomic_post E1 Ei Ψ (Φ x y)))
            )%I.
  Proof.
    (* FIXME: Is there any way to prevent maybe_wand from unfolding?
       It gets unfolded by env_cbv in the proofmode, ideally we'd like that
       to happen only if one argument is a constructor. *)
    iIntros (_) "Hinner Hacc".
    iMod "Hacc" as (x') "[Hα' Hclose]".
    iMod ("Hinner" with "Hα'") as (x) "[Hα Hclose']".
    iModIntro. iExists x. iFrame "Hα". iSplitWith "Hclose'".
    - iIntros "Hα".
      iMod ("Hclose'" with "Hα") as "[Hβ' HPas]".
      iMod ("Hclose" with "Hβ'"). iModIntro.
      by iApply "HPas".
    - iIntros (y) "Hβ".
      iMod ("Hclose'" with "Hβ") as "AP"; rewrite ->!tele_app_bind.
      iMod (atomic_post_commit with "AP") as "[Hβ' HAP]".
      iMod ("Hclose" with "Hβ'"). iModIntro.
      by iApply "HAP".
  Qed.

  (* Everything that fancy updates can eliminate without changing, atomic
  accessors can eliminate as well.  This is a forwarding instance needed because
  atomic_acc is becoming opaque. *)
  Global Instance elim_modal_acc {TA TB TC : tele} p q φ P P' Eo Ei
      (α : TA → PROP) Pas (Ψ : TC → PROP) (β Φ : TA → TB → PROP) :
    (∀ Q, ElimModal φ p q P P' (|={Eo,Ei}=> Q) (|={Eo,Ei}=> Q)) →
    ElimModal φ p q P P'
              (atomic_acc Eo Ei α Pas Ψ β Φ)
              (atomic_acc Eo Ei α Pas Ψ β Φ).
  Proof. intros Helim. apply Helim. Qed.

  (** Lemmas for directly proving one atomic accessor in terms of another (or an
      atomic update).  These are only really useful when the atomic accessor you
      are trying to prove exactly corresponds to an atomic update/accessor you
      have as an assumption -- which is not very common. *)
  Lemma aacc_aacc {TA TB TC TA' TB' TC' : tele} E1 E1' E2 E3
      (α : TA → PROP) P (Ψ : TC → PROP) (β Φ : TA → TB → PROP)
      (α' : TA' → PROP) P' (Ψ' : TC' → PROP) (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 →
    atomic_acc E1' E2 α P Ψ β Φ -∗
    (∀.. x, α x -∗ atomic_acc E2 E3 α' (α x ∗ (P ={E1}=∗ P')) Ψ' β'
      (λ.. x' y',
        (α x ∗ (P ={E1}=∗ atomic_post E1 E3 Ψ' (Φ' x' y')))
        ∨
        (∃.. y, β x y ∗ (atomic_post E1 E2 Ψ (Φ x y) ={E1}=∗ atomic_post E1 E3 Ψ' (Φ' x' y')))
      )) -∗
    atomic_acc E1 E3 α' P' Ψ' β' Φ'.
  Proof.
    iIntros (?) "Hupd Hstep".
    iMod (atomic_acc_mask_weaken with "Hupd") as (x) "[Hα Hclose]"; first done.
    iMod ("Hstep" with "Hα") as (x') "[Hα' Hclose']".
    iModIntro. iExists x'. iFrame "Hα'". iSplitWith "Hclose'".
    - iIntros "Hα'".
      iMod ("Hclose'" with "Hα'") as "[Hα Hupd]".
      iDestruct "Hclose" as "[Hclose _]".
      iMod ("Hclose" with "Hα"). iApply "Hupd". done.
    - iIntros (y') "Hβ'".
      iMod ("Hclose'" with "Hβ'") as "HAP". rewrite ->!tele_app_bind.
      iMod "HAP" as (x'') "[HΨ' [_ HAP]]".
      iMod ("HAP" with "HΨ'") as "[[Hα HAP']|Hcont]".
      + (* Abort the step we are eliminating *)
        iDestruct "Hclose" as "[Hclose _]".
        iMod ("Hclose" with "Hα") as "HP". by iApply "HAP'".
      + (* Complete the step we are eliminating *)
        iDestruct "Hclose" as "[_ Hclose]". iDestruct "Hcont" as (y) "[Hβ HAP']".
        iMod ("Hclose" with "Hβ") as "HAP". by iApply "HAP'".
  Qed.

  Lemma aacc_aupd {TA TB TC TA' TB' TC' : tele} E1 E1' E2 E3
      (α : TA → PROP) (Ψ : TC → PROP) (β Φ : TA → TB → PROP)
      (α' : TA' → PROP) P' (Ψ' : TC' → PROP) (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 →
    atomic_update E1' E2 α Ψ β Φ -∗
    (∀.. x, α x -∗ atomic_acc E2 E3 α' (α x ∗ (atomic_update E1' E2 α Ψ β Φ ={E1}=∗ P')) Ψ' β'
      (λ.. x' y',
        (α x ∗ (atomic_update E1' E2 α Ψ β Φ ={E1}=∗ atomic_post E1 E3 Ψ' (Φ' x' y')))
        ∨
        ∃.. y, β x y ∗ (atomic_post E1 E2 Ψ (Φ x y) ={E1}=∗ atomic_post E1 E3 Ψ' (Φ' x' y'))
      )) -∗
    atomic_acc E1 E3 α' P' Ψ' β' Φ'.
  Proof.
    iIntros (?) "Hupd Hstep". iApply (aacc_aacc _ E1' with "[Hupd] Hstep"); try done.
    iApply aupd_aacc; done.
  Qed.

  Lemma aacc_aupd_commit {TA TB TC TA' TB' TC' : tele} E1 E1' E2 E3
      (α : TA → PROP) (Ψ : TC → PROP) (β Φ : TA → TB → PROP)
      (α' : TA' → PROP) P' (Ψ' : TC' → PROP) (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 →
    atomic_update E1' E2 α Ψ β Φ -∗
    (∀.. x, α x -∗ atomic_acc E2 E3 α' (α x ∗ (atomic_update E1' E2 α Ψ β Φ ={E1}=∗ P')) Ψ' β'
      (λ.. x' y',
        ∃.. y, β x y ∗ (atomic_post E1 E2 Ψ (Φ x y) ={E1}=∗ atomic_post E1 E3 Ψ' (Φ' x' y'))
      )) -∗
    atomic_acc E1 E3 α' P' Ψ' β' Φ'.
  Proof.
    iIntros (?) "Hupd Hstep". iApply (aacc_aupd with "Hupd"); try done.
    iIntros (x) "Hα". iApply atomic_acc_wand; last first.
    { iApply "Hstep". done. }
    (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
    iSplit; first by eauto. iIntros (??) "?". rewrite ->!tele_app_bind. by iRight.
  Qed.

  Lemma aacc_aupd_abort {TA TB TC TA' TB' TC' : tele} E1 E1' E2 E3
      (α : TA → PROP) (Ψ : TC → PROP) (β Φ : TA → TB → PROP)
      (α' : TA' → PROP) P' (Ψ' : TC' → PROP) (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 →
    atomic_update E1' E2 α Ψ β Φ -∗
    (∀.. x, α x -∗ atomic_acc E2 E3 α' (α x ∗ (atomic_update E1' E2 α Ψ β Φ ={E1}=∗ P')) Ψ' β'
      (λ.. x' y',
        (α x ∗ (atomic_update E1' E2 α Ψ β Φ ={E1}=∗ atomic_post E1 E3 Ψ' (Φ' x' y')))
      )) -∗
    atomic_acc E1 E3 α' P' Ψ' β' Φ'.
  Proof.
    iIntros (?) "Hupd Hstep". iApply (aacc_aupd with "Hupd"); try done.
    iIntros (x) "Hα". iApply atomic_acc_wand; last first.
    { iApply "Hstep". done. }
    (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
    iSplit; first by eauto. iIntros (??) "?". rewrite ->!tele_app_bind. by iLeft.
  Qed.

  Lemma apst_aupd_sup {TA TB TC TC' : tele} E1 E1' E2 E3
      (α : TA → PROP) (Ψ : TC → PROP) (β Φ : TA → TB → PROP)
      (Ψ' : TC' → PROP) (Φ' : PROP)
      (R : PROP) :
    E1' ⊆ E1 → E3 ⊆ E2 →
    R -∗
    □ (∀.. x, R ∗ α x -∗ ∃.. z', (Ψ' z' ∗ (Ψ' z' -∗ R ∗ α x))) -∗
    atomic_update E1' E2 α Ψ β Φ -∗
    (R ∗ atomic_update E1' E2 α Ψ β Φ ={E1}=∗ Φ') -∗
    atomic_post E1 E3 Ψ' Φ'.
  Proof.
    iIntros (??) "HR #HRαΨ' AU Hstep".
    rewrite atomic_post_unseal /atomic_post_def /=.
    iApply (greatest_fixpoint_coiter _ (λ _, (R ∗ atomic_update E1' E2 α Ψ β Φ ∗
      (R ∗ atomic_update E1' E2 α Ψ β Φ ={E1}=∗ Φ')
    )%I)); last iFrame.
    iIntros "!> * [HR [AU Hstep]]".
    iMod (atomic_update_mask_weaken with "AU") as (x) "[Hα [Hclose _]]"; first done.
    iApply fupd_mask_intro; first done. iIntros "Hclose'".
    iDestruct ("HRαΨ'" with "[$]") as (z') "[HΨ' HRα]".
    iExists z'. iFrame "HΨ'".
    iSplit; iIntros "HΨ'"; iMod "Hclose'" as "_";
      iDestruct ("HRα" with "HΨ'") as "[HR Hα]"; iMod ("Hclose" with "Hα");
      last iApply "Hstep"; by iFrame.
  Qed.

  Lemma apst_aupd_sub {TA TB TC TC' : tele} E1 E1' E2 E3
      (α : TA → PROP) (Ψ : TC → PROP) (β Φ : TA → TB → PROP)
      (Ψ' : TC' → PROP) (Φ' : PROP) :
    E1' ⊆ E1 → E3 ⊆ E2 →
    □ (∀.. x, α x -∗ ∃.. z', (Ψ' z' ∗ (Ψ' z' -∗ α x))) -∗
    atomic_update E1' E2 α Ψ β Φ -∗
    (atomic_update E1' E2 α Ψ β Φ ={E1}=∗ Φ') -∗
    atomic_post E1 E3 Ψ' Φ'.
  Proof.
    iIntros (??) "#HαΨ' AU Hstep".
    rewrite atomic_post_unseal /atomic_post_def /=.
    iApply (greatest_fixpoint_coiter _ (λ _, (atomic_update E1' E2 α Ψ β Φ ∗
      (atomic_update E1' E2 α Ψ β Φ ={E1}=∗ Φ')
    )%I)); last iFrame.
    iIntros "!> * [AU Hstep]".
    iMod (atomic_update_mask_weaken with "AU") as (x) "[Hα [Hclose _]]"; first done.
    iApply fupd_mask_intro; first done. iIntros "Hclose'".
    iDestruct ("HαΨ'" with "Hα") as (z') "[HΨ' Hα]".
    iExists z'. iFrame "HΨ'".
    iSplit; iIntros "HΨ'"; iMod "Hclose'" as "_";
      iDestruct ("Hα" with "HΨ'") as "Hα"; iMod ("Hclose" with "Hα");
      last iApply "Hstep"; by iFrame.
  Qed.

  Lemma aacc_aupd_sup {TA TB TA' TB' TC' : tele} E1 E1' E2 E3
      (α : TA → PROP) (β Φ : TA → TB → PROP)
      (α' : TA' → PROP) P' (Ψ' : TC' → PROP) (β' Φ' : TA' → TB' → PROP)
      (R : PROP) :
    E1' ⊆ E1 → E3 ⊆ E2 →
    R -∗
    □ (∀.. x, R ∗ α x -∗ ∃.. z', (Ψ' z' ∗ (Ψ' z' -∗ R ∗ α x))) -∗
    atomic_update E1' E2 α α β Φ -∗
    (∀.. x, R ∗ α x -∗ atomic_acc E2 E3 α' (α x ∗ (atomic_update E1' E2 α α β Φ ={E1}=∗ P')) Ψ' β'
      (λ.. x' y',
        (R ∗ α x ∗ (R ∗ atomic_update E1' E2 α α β Φ ={E1}=∗ Φ' x' y'))
        ∨
        ∃.. y, R ∗ β x y ∗ (R ∗ atomic_post E1 E2 α (Φ x y) ={E1}=∗ Φ' x' y')
      )) -∗
    atomic_acc E1 E3 α' P' Ψ' β' Φ'.
  Proof.
    iIntros (??) "HR #HRαΨ' Hupd Hstep".
    iMod (atomic_update_mask_weaken with "Hupd") as (x) "[Hα Hclose]"; first done.
    iMod ("Hstep" with "[$]") as (x') "[Hα' Hclose']".
    iModIntro. iExists x'. iFrame "Hα'". iSplitWith "Hclose'".
    - iIntros "Hα'".
      iMod ("Hclose'" with "Hα'") as "[Hα Hupd]".
      iDestruct "Hclose" as "[Hclose _]".
      iMod ("Hclose" with "Hα"). iApply "Hupd". iFrame.
    - iIntros (y') "Hβ'".
      iMod ("Hclose'" with "Hβ'") as "HAP". rewrite ->!tele_app_bind.
      iMod "HAP" as (z') "[HΨ' [_ HAP]]".
      iMod ("HAP" with "HΨ'") as "[[HR [Hα HAP']]|Hcont]".
      + (* Abort the step we are eliminating *)
        iDestruct "Hclose" as "[Hclose _]".
        iMod ("Hclose" with "Hα") as "HAP". iModIntro.
        iApply (apst_aupd_sup with "HR [] HAP"); try done.
      + (* Complete the step we are eliminating *)
        iDestruct "Hclose" as "[_ Hclose]". iDestruct "Hcont" as (y) "[HR [Hβ HAP']]".
        iMod ("Hclose" with "Hβ") as "HAP". iModIntro.
        iApply (apst_apst_sup with "HR [] HAP"); try done.
  Qed.

  Lemma aacc_aupd_sub {TA TB TA' TB' TC' : tele} E1 E1' E2 E3
      (α : TA → PROP) (β Φ : TA → TB → PROP)
      (α' : TA' → PROP) P' (Ψ' : TC' → PROP) (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 → E3 ⊆ E2 →
    □ (∀.. x, α x -∗ ∃.. z', (Ψ' z' ∗ (Ψ' z' -∗ α x))) -∗
    atomic_update E1' E2 α α β Φ -∗
    (∀.. x, α x -∗ atomic_acc E2 E3 α' (α x ∗ (atomic_update E1' E2 α α β Φ ={E1}=∗ P')) Ψ' β'
      (λ.. x' y',
        (α x ∗ (atomic_update E1' E2 α α β Φ ={E1}=∗ Φ' x' y'))
        ∨
        ∃.. y, β x y ∗ (atomic_post E1 E2 α (Φ x y) ={E1}=∗ Φ' x' y')
      )) -∗
    atomic_acc E1 E3 α' P' Ψ' β' Φ'.
  Proof.
    iIntros (??) "#HαΨ' Hupd Hstep".
    iMod (atomic_update_mask_weaken with "Hupd") as (x) "[Hα Hclose]"; first done.
    iMod ("Hstep" with "Hα") as (x') "[Hα' Hclose']".
    iModIntro. iExists x'. iFrame "Hα'". iSplitWith "Hclose'".
    - iIntros "Hα'".
      iMod ("Hclose'" with "Hα'") as "[Hα Hupd]".
      iDestruct "Hclose" as "[Hclose _]".
      iMod ("Hclose" with "Hα"). iApply "Hupd". iFrame.
    - iIntros (y') "Hβ'".
      iMod ("Hclose'" with "Hβ'") as "HAP". rewrite ->!tele_app_bind.
      iMod "HAP" as (z') "[HΨ' [_ HAP]]".
      iMod ("HAP" with "HΨ'") as "[[Hα HAP']|Hcont]".
      + (* Abort the step we are eliminating *)
        iDestruct "Hclose" as "[Hclose _]".
        iMod ("Hclose" with "Hα") as "HAP". iModIntro.
        iApply (apst_aupd_sub with "[] HAP"); try done.
      + (* Complete the step we are eliminating *)
        iDestruct "Hclose" as "[_ Hclose]". iDestruct "Hcont" as (y) "[Hβ HAP']".
        iMod ("Hclose" with "Hβ") as "HAP". iModIntro.
        iApply (apst_apst_sub with "[] HAP"); try done.
  Qed.

  Lemma aacc_aupd_eq {TA TB TB' : tele} E1 E1' E2 E3
      (α : TA → PROP) (β Φ : TA → TB → PROP)
      P' (β' Φ' : TA → TB' → PROP) :
    E1' ⊆ E1 → E3 ⊆ E2 →
    atomic_update E1' E2 α α β Φ -∗
    (∀.. x, α x -∗ atomic_acc E2 E3 α (α x ∗ (atomic_update E1' E2 α α β Φ ={E1}=∗ P')) α β'
      (λ.. x' y',
        (α x ∗ (atomic_update E1' E2 α α β Φ ={E1}=∗ Φ' x' y'))
        ∨
        ∃.. y, β x y ∗ (atomic_post E1 E2 α (Φ x y) ={E1}=∗ Φ' x' y')
      )) -∗
    atomic_acc E1 E3 α P' α β' Φ'.
  Proof.
    iIntros (??) "AU Hstep".
    iApply (aacc_aupd_sub with "[] AU Hstep"); try done.
    iIntros "!> %x Hα". iExists x. iFrame; by iIntros.
  Qed.

  Lemma aacc_apst_sub {TC TA' TB' TC' : tele} E1 E1' E2 E3
      (Ψ : TC → PROP) Φ
      (α' : TA' → PROP) P (Ψ' : TC' → PROP) (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 → E3 ⊆ E2 →
    □ (∀.. z, Ψ z -∗ ∃.. z', (Ψ' z' ∗ (Ψ' z' -∗ Ψ z))) -∗
    atomic_post E1' E2 Ψ Φ -∗
    (∀.. z, Ψ z -∗ atomic_acc E2 E3 α' (Ψ z ∗ (atomic_post E1' E2 Ψ Φ ={E1}=∗ P)) Ψ' β'
      (λ.. x' y',
        (Ψ z ∗ (atomic_post E1' E2 Ψ Φ ={E1}=∗ Φ' x' y'))
      )) -∗
    atomic_acc E1 E3 α' P Ψ' β' Φ'.
  Proof.
    iIntros (??) "#HαΨ' Hpst Hstep".
    iMod (atomic_post_mask_weaken with "Hpst") as (x) "[HΨ Hclose]"; first done.
    iMod ("Hstep" with "HΨ") as (x') "[Hα' Hclose']".
    iModIntro. iExists x'. iFrame "Hα'". iSplitWith "Hclose'".
    - iIntros "Hα'".
      iMod ("Hclose'" with "Hα'") as "[Hα Hupd]".
      iDestruct "Hclose" as "[Hclose _]".
      iMod ("Hclose" with "Hα"). iApply "Hupd". iFrame.
    - iIntros (y') "Hβ'".
      iMod ("Hclose'" with "Hβ'") as "HAP". rewrite ->!tele_app_bind.
      iMod "HAP" as (z') "[HΨ' [_ HAP]]".
      iMod ("HAP" with "HΨ'") as "[HΨ HAP']".
      iDestruct "Hclose" as "[Hclose _]".
      iMod ("Hclose" with "HΨ") as "HAP". iModIntro.
      iApply (apst_apst_sub with "[] HAP"); try done.
  Qed.

  Lemma aacc_apst_eq {TC TA' TB' TC' : tele} E1 E1' E2 E3
      (Ψ : TC → PROP) Φ
      (α' : TA' → PROP) P (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 → E3 ⊆ E2 →
    atomic_post E1' E2 Ψ Φ -∗
    (∀.. z, Ψ z -∗ atomic_acc E2 E3 α' (Ψ z ∗ (atomic_post E1' E2 Ψ Φ ={E1}=∗ P)) Ψ β'
      (λ.. x' y',
        (Ψ z ∗ (atomic_post E1' E2 Ψ Φ ={E1}=∗ Φ' x' y'))
      )) -∗
    atomic_acc E1 E3 α' P Ψ β' Φ'.
  Proof.
    iIntros (??) "Hpst Hstep".
    iApply (aacc_apst_sub with "[] Hpst Hstep"); try done.
    iIntros "!> %z HΨ". iExists z. iFrame; by iIntros.
  Qed.

End lemmas.

(** ProofMode support for atomic updates. *)
Section proof_mode.
  Context `{BiFUpd PROP} {TA TB TC : tele}.
  Implicit Types (α : TA → PROP) (β Φ : TA → TB → PROP) (Ψ : TC → PROP) (P : PROP).

  Lemma tac_aupd_intro Γp Γs n α β Ψ Eo Ei Φ P :
    P = env_to_prop Γs →
    envs_entails (Envs Γp Γs n) (atomic_acc Eo Ei α P Ψ β Φ) →
    envs_entails (Envs Γp Γs n) (atomic_update Eo Ei α Ψ β Φ).
  Proof.
    intros ->. rewrite envs_entails_unseal of_envs_eq /atomic_acc /=.
    setoid_rewrite env_to_prop_sound =>HAU.
    rewrite assoc. apply: aupd_intro. by rewrite -assoc.
  Qed.
End proof_mode.

(** * Now the coq-level tactics *)

Tactic Notation "iAuIntro" :=
  match goal with
  | |- envs_entails (Envs ?Γp ?Γs _) (atomic_update _ _ _ _ _ ?Φ) =>
      notypeclasses refine (tac_aupd_intro Γp Γs _ _ _ _ _ _ Φ _ _ _); [
        (* P = ...: make the P pretty *) pm_reflexivity
      | (* the new proof mode goal *) ]
  end.

(** Tactic to apply [aacc_intro]. This only really works well when you have
[α ?] already and pass it as [iAaccIntro with "Hα"]. Doing
[rewrite /atomic_acc /=] is an entirely legitimate alternative. *)
Tactic Notation "iAaccIntro" "with" constr(sel) :=
  iStartProof; lazymatch goal with
  | |- envs_entails _ (@atomic_acc ?PROP ?H ?TA ?TB ?TC ?Eo ?Ei ?α ?P ?Ψ ?β ?Φ) =>
    iApply (@aacc_intro PROP H TA TB TC Eo Ei α P Ψ β Φ with sel);
    first try solve_ndisj; last iSplit
  | _ => fail "iAaccIntro: Goal is not an atomic accessor"
  end.

Lemma aupd_inv `{!irisGS_gen hlc Λ Σ} {TA TB : tele} E
  (α : TA → iProp Σ) (β Q Φ : TA → TB → iProp Σ)
  I N :
  ↑N ⊆ E →
  inv N I -∗
  atomic_update (E ∖ ↑N) ∅
    α
    α
    β
    (λ.. x y, Q x y ={E ∖ ↑N}=∗ Φ x y) -∗
  atomic_update E ∅
    (λ.. x, ▷I ∗ α x)
    (λ.. x, ▷I ∗ α x)
    (λ.. x y, ▷I ∗ β x y)
    (λ.. x y, Q x y ={E}=∗ Φ x y).
Proof.
  iIntros (HN) "#Hinv AU".
  rewrite {2}atomic_update_unseal /atomic_update_def /=.
  iApply (greatest_fixpoint_coiter _ (
    λ _, (atomic_update (E ∖ ↑N) ∅ α α β (λ.. x y, Q x y ={E ∖ ↑N}=∗ Φ x y))%I
  )); last iFrame.
  iIntros "!> * AU". iInv N as "HI" "Hclose'".
  iMod "AU" as (x) "[Hα Hclose]".
  iModIntro. iExists x. rewrite ->!tele_app_bind.
  iFrame. iSplitWith "Hclose".
  + iIntros "[HI Hα]". iMod ("Hclose" with "Hα") as "AU".
    by iMod ("Hclose'" with "HI") as "_".
  + clear y; iIntros (y). rewrite ->!tele_app_bind.
    iIntros "[HI Hβ]". iMod ("Hclose" with "Hβ") as "AP".
    rewrite ->!tele_app_bind.
    iMod ("Hclose'" with "HI") as "_". iModIntro.

    rewrite {2}atomic_post_unseal /atomic_post_def /=.
    iApply (greatest_fixpoint_coiter _ (
      λ _, (atomic_post (E ∖ ↑N) ∅ α (Q x y ={E ∖ ↑N}=∗ Φ x y))%I
    )); last iFrame.
    iIntros "!> * AP". iInv N as "HI" "Hclose'".
    iMod "AP" as (z) "[Hα Hclose]".
    iModIntro. iExists z. rewrite ->!tele_app_bind.
    iFrame. iSplitWith "Hclose"; iIntros "[HI Hα]";
      iMod ("Hclose" with "Hα") as "HΦ";
      iMod ("Hclose'" with "HI") as "_"; first done.
    iModIntro. iIntros "HQ".
    iApply fupd_mask_mono; last by iApply "HΦ". solve_ndisj.
Qed.

Lemma aupd_inv_timeless `{!irisGS_gen hlc Λ Σ} {TA TB : tele} E
  (α : TA → iProp Σ) (β Q Φ : TA → TB → iProp Σ)
  I N `{!Timeless I} :
  ↑N ⊆ E →
  inv N I -∗
  atomic_update (E ∖ ↑N) ∅
    α
    α
    β
    (λ.. x y, Q x y ={E ∖ ↑N}=∗ Φ x y) -∗
  atomic_update E ∅
    (λ.. x, I ∗ α x)
    (λ.. x, I ∗ α x)
    (λ.. x y, I ∗ β x y)
    (λ.. x y, Q x y ={E}=∗ Φ x y).
Proof.
  iIntros (HN) "#Hinv AU".
  rewrite {2}atomic_update_unseal /atomic_update_def /=.
  iApply (greatest_fixpoint_coiter _ (
    λ _, (atomic_update (E ∖ ↑N) ∅ α α β (λ.. x y, Q x y ={E ∖ ↑N}=∗ Φ x y))%I
  )); last iFrame.
  iIntros "!> * AU". iInv N as ">HI" "Hclose'".
  iMod "AU" as (x) "[Hα Hclose]".
  iModIntro. iExists x. rewrite ->!tele_app_bind.
  iFrame. iSplitWith "Hclose".
  + iIntros "[HI Hα]". iMod ("Hclose" with "Hα") as "AU".
    by iMod ("Hclose'" with "HI") as "_".
  + clear y; iIntros (y). rewrite ->!tele_app_bind.
    iIntros "[HI Hβ]". iMod ("Hclose" with "Hβ") as "AP".
    rewrite ->!tele_app_bind.
    iMod ("Hclose'" with "HI") as "_". iModIntro.

    rewrite {2}atomic_post_unseal /atomic_post_def /=.
    iApply (greatest_fixpoint_coiter _ (
      λ _, (atomic_post (E ∖ ↑N) ∅ α (Q x y ={E ∖ ↑N}=∗ Φ x y))%I
    )); last iFrame.
    iIntros "!> * AP". iInv N as ">HI" "Hclose'".
    iMod "AP" as (z) "[Hα Hclose]".
    iModIntro. iExists z. rewrite ->!tele_app_bind.
    iFrame. iSplitWith "Hclose"; iIntros "[HI Hα]";
      iMod ("Hclose" with "Hα") as "HΦ";
      iMod ("Hclose'" with "HI") as "_"; first done.
    iModIntro. iIntros "HQ".
    iApply fupd_mask_mono; last by iApply "HΦ". solve_ndisj.
Qed.


Require Import VST.floyd.proofauto.
Require Import listfree.
From SSL_VST Require Import core.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition free_spec :=
  DECLARE _free
          WITH ty: type, x: val
                              PRE  [ (tptr tvoid) ]
                              PROP()
                              PARAMS(x)
                              SEP (data_at_ Tsh ty x)
                              POST [ Tvoid ]
                              PROP()
                              LOCAL()
                              SEP (emp).

Inductive lseg_card : Set :=
    | lseg_card_0 : lseg_card
    | lseg_card_1 : lseg_card -> lseg_card.

Fixpoint lseg (x: val) (s: (list Z)) (self_card: lseg_card) {struct self_card} : mpred := match self_card with
    | lseg_card_0  =>  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp
    | lseg_card_1 _alpha_513 =>
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (lseg (nxt : val) (s1 : list Z) (_alpha_513 : lseg_card))
end.

Inductive lseg2_card : Set :=
    | lseg2_card_0 : lseg2_card
    | lseg2_card_1 : lseg2_card -> lseg2_card.

Fixpoint lseg2 (x: val) (y: val) (s: (list Z)) (self_card: lseg2_card) {struct self_card} : mpred := match self_card with
    | lseg2_card_0  =>  !!((x : val) = (y : val)) && !!((s : list Z) = ([] : list Z)) && emp
    | lseg2_card_1 _alpha_514 =>
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = (y : val))) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (lseg2 (nxt : val) (y : val) (s1 : list Z) (_alpha_514 : lseg2_card))
end.

Definition listfree_spec :=
  DECLARE _listfree
   WITH x: val, s: (list Z), _alpha_515: lseg_card
   PRE [ (tptr (Tunion _sslval noattr)) ]
   PROP( is_pointer_or_null((x : val)) )
   PARAMS(x)
   SEP ((lseg (x : val) (s : list Z) (_alpha_515 : lseg_card)))
   POST[ tvoid ]
   PROP(  )
   LOCAL()
   SEP ().

Lemma lseg_x_valid_pointerP x s self_card: lseg x s self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve lseg_x_valid_pointerP : valid_pointer.
Lemma lseg_local_factsP x s self_card :
  lseg x s self_card|-- !!(((((x : val) = nullval)) -> (self_card = lseg_card_0))/\(((~ ((x : val) = nullval))) -> (exists _alpha_513, self_card = lseg_card_1 _alpha_513))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve lseg_local_factsP : saturate_local.
Lemma unfold_lseg_card_0  (x: val) (s: (list Z)) : lseg x s (lseg_card_0 ) =  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp. Proof. auto. Qed.
Lemma unfold_lseg_card_1 (_alpha_513 : lseg_card) (x: val) (s: (list Z)) : lseg x s (lseg_card_1 _alpha_513) =
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (lseg (nxt : val) (s1 : list Z) (_alpha_513 : lseg_card)). Proof. auto. Qed.
Lemma lseg2_local_factsP x y s self_card :
  lseg2 x y s self_card|-- !!(((((x : val) = (y : val))) -> (self_card = lseg2_card_0))/\(((~ ((x : val) = (y : val)))) -> (exists _alpha_514, self_card = lseg2_card_1 _alpha_514))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve lseg2_local_factsP : saturate_local.
Lemma unfold_lseg2_card_0  (x: val) (y: val) (s: (list Z)) : lseg2 x y s (lseg2_card_0 ) =  !!((x : val) = (y : val)) && !!((s : list Z) = ([] : list Z)) && emp. Proof. auto. Qed.
Lemma unfold_lseg2_card_1 (_alpha_514 : lseg2_card) (x: val) (y: val) (s: (list Z)) : lseg2 x y s (lseg2_card_1 _alpha_514) =
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = (y : val))) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (lseg2 (nxt : val) (y : val) (s1 : list Z) (_alpha_514 : lseg2_card)). Proof. auto. Qed.
Definition Gprog : funspecs :=
  ltac:(with_library prog [listfree_spec; free_spec]).

Lemma body_listfree : semax_body Vprog Gprog f_listfree listfree_spec.
Proof.
start_function.
ssl_open_context.
forward_if.

 - {
assert_PROP (_alpha_515 = lseg_card_0) as ssl_card_assert. { entailer!; ssl_dispatch_card. }
ssl_card lseg ssl_card_assert .
assert_PROP (((x : val) = nullval)). { entailer!. }
let ssl_var := fresh in assert_PROP(s = ([] : list Z)) as ssl_var; try rewrite ssl_var in *. { entailer!. }
forward; entailer!.

}
 - {
assert_PROP (exists _alpha_513, _alpha_515 = lseg_card_1 _alpha_513) as ssl_card_assert. { entailer!; ssl_dispatch_card. }
ssl_card lseg ssl_card_assert _alpha_513x.
assert_PROP ((~ ((x : val) = nullval))). { entailer!. }
Intros vx s1x nxtx.
let ssl_var := fresh in assert_PROP(s = (([(vx : Z)] : list Z) ++ (s1x : list Z))) as ssl_var; try rewrite ssl_var in *. { entailer!. }
try rename vx into vx2.
forward.
try rename nxtx into nxtx2.
forward.
assert_PROP(is_pointer_or_null((nxtx2 : val))). { entailer!. }
forward_call ((nxtx2 : val), (s1x : list Z), (_alpha_513x : lseg_card)).
forward_call (tarray (Tunion _sslval noattr) 2, x).
forward; entailer!.

}
Qed.


(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto.
Require Import VST.progs64.append.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Definition t_struct_list := Tstruct _list noattr.

Fixpoint listrep (sh: share)
            (contents: list val) (x: val) : mpred :=
 match contents with
 | h::hs =>
              EX y:val,
                data_at sh t_struct_list (h,y) x * listrep sh hs y
 | nil => !! (x = nullval) && emp
 end.

Arguments listrep sh contents x : simpl never.

Lemma listrep_local_facts:
  forall sh contents p,
     listrep sh contents p |--
     !! (is_pointer_or_null p /\ (p=nullval <-> contents=nil)).
Proof.
intros.
revert p; induction contents;
  unfold listrep; fold listrep; intros. entailer!. intuition.
Intros y. entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

#[export] Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sh contents p,
   sepalg.nonidentity sh ->
   listrep sh contents p |-- valid_pointer p.
Proof.
 destruct contents; unfold listrep; fold listrep; intros; Intros; subst.
 auto with valid_pointer.
 Intros y.
 apply sepcon_valid_pointer1.
 apply data_at_valid_ptr; auto.
 simpl;  computable.
Qed.

#[export] Hint Resolve listrep_valid_pointer : valid_pointer.

Lemma listrep_null: forall sh contents,
    listrep sh contents nullval = !! (contents=nil) && emp.
Proof.
destruct contents; unfold listrep; fold listrep.
autorewrite with norm. auto.
apply pred_ext.
Intros y. entailer. destruct H; contradiction.
Intros. discriminate.
Qed.

Lemma is_pointer_or_null_not_null:
 forall x, is_pointer_or_null x -> x <> nullval -> isptr x.
Proof.
intros.
 destruct x; try contradiction. hnf in H; subst i. contradiction H0; reflexivity.
 apply I.
Qed.

Definition append_spec :=
 DECLARE _append
  WITH sh : share, x: val, y: val, s1: list val, s2: list val
  PRE [ tptr t_struct_list , tptr t_struct_list]
     PROP(writable_share sh)
     PARAMS (x; y) GLOBALS()
     SEP (listrep sh s1 x; listrep sh s2 y)
  POST [ tptr t_struct_list ]
    EX r: val,
     PROP()
     RETURN (r)
     SEP (listrep sh (s1++s2) r).

Definition Gprog : funspecs :=   ltac:(with_library prog [ append_spec ]).

Module Proof1.

Definition lseg (sh: share) (contents: list val) (x z: val) : mpred :=
  ALL cts2:list val, listrep sh cts2 z -* listrep sh (contents++cts2) x.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if.
*
 subst x. rewrite listrep_null.  Intros.  subst.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold listrep at 1; fold listrep.
 Intros.  contradiction.
 Intros u.
 remember (v::s1') as s1.
 forward.
 forward_while
      ( EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP ()
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (listrep sh (a::s1b++s2) t -* listrep sh (s1++s2) x;
                   data_at sh t_struct_list (a,u) t;
                   listrep sh s1b u;
                   listrep sh s2 y))%assert.
+ (* current assertion implies loop invariant *)
   Exists v s1' x u.
   subst s1. entailer!. simpl. cancel_wand.
+ (* loop test is safe to execute *)
   entailer!.
+ (* loop body preserves invariant *)
   clear v Heqs1.
   destruct s1b; unfold listrep at 3; fold listrep. Intros. contradiction.
   Intros z.
   forward.
   forward.
   Exists (v,s1b,u0,z). unfold fst, snd.
   simpl app.
   entailer!.
   rewrite sepcon_comm.
   apply RAMIF_PLAIN.trans''.
   apply wand_sepcon_adjoint.
   forget (v::s1b++s2) as s3.
   unfold listrep; fold listrep; Exists u0; auto.
+ (* after the loop *)
   clear v s1' Heqs1.
   forward.
   forward.
   rewrite (proj1 H2 (eq_refl _)).
   Exists x.
   simpl app.
   clear.
   entailer!.
   unfold listrep at 3; fold listrep. Intros.
   pull_right (listrep sh (a :: s2) t -* listrep sh (s1 ++ s2) x).
   apply modus_ponens_wand'.
   unfold listrep at 2; fold listrep. Exists y; cancel.
Qed.

End Proof1.

Module Proof2.

Definition lseg (sh: share) (contents: list val) (x z: val) : mpred :=
  ALL cts2:list val, listrep sh cts2 z -* listrep sh (contents++cts2) x.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if.
*
 subst x. rewrite listrep_null. Intros; subst.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold listrep; fold listrep. Intros; contradiction.
 Intros u.
 remember (v::s1') as s1.
 forward.
 forward_while
      (EX s1a: list val,  EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP (s1 = s1a ++ a :: s1b)
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (lseg sh s1a x t;
                   data_at sh t_struct_list (a,u) t;
                   listrep sh s1b u;
                   listrep sh s2 y))%assert.
+ (* current assertion implies loop invariant *)
   Exists (@nil val) v s1' x u.  entailer!.
   unfold lseg. apply allp_right; intro. simpl. cancel_wand.
+ (* loop test is safe to execute *)
   entailer!.
+ (* loop body preserves invariant *)
   clear v Heqs1. subst s1.
   destruct s1b; unfold listrep; fold listrep. Intros; contradiction.
   Intros z.
   forward.
   forward.
   Exists (s1a++[a],v,s1b,u0,z). unfold fst, snd.
   rewrite !app_ass. simpl app.
   entailer!.
   unfold lseg.
   rewrite sepcon_comm.
   clear.
   apply RAMIF_Q.trans'' with (cons a).
   extensionality cts; simpl; rewrite app_ass; reflexivity.
   apply allp_right; intro. apply wand_sepcon_adjoint.
   unfold listrep at 2; fold listrep; Exists u0.  apply derives_refl.
 + (* after the loop *)
   forward. forward.
   Exists x. entailer!.
   destruct H3 as [? _]. specialize (H3 (eq_refl _)). subst s1b.
   unfold listrep at 1.  Intros. autorewrite with norm.  rewrite H0. rewrite app_ass. simpl app.
   unfold lseg.
   rewrite sepcon_assoc.
   eapply derives_trans; [apply allp_sepcon1 | ]. apply allp_left with (a::s2).
   rewrite sepcon_comm.
   eapply derives_trans; [ | apply modus_ponens_wand].
   apply sepcon_derives; [ | apply derives_refl].
   unfold listrep at 2; fold listrep. Exists y; auto.
Qed.

End Proof2.

Module Proof3.  (*************** inductive lseg *******************)

Fixpoint lseg (sh: share)
            (contents: list val) (x z: val) : mpred :=
 match contents with
 | h::hs => !! (x<>z) &&
              EX y:val,
                data_at sh t_struct_list (h,y) x * lseg sh hs y z
 | nil => !! (x = z /\ is_pointer_or_null x) && emp
 end.

Arguments lseg sh contents x z : simpl never.

Lemma lseg_local_facts:
  forall sh contents p q,
     lseg sh contents p q |--
     !! (is_pointer_or_null p /\ is_pointer_or_null q /\ (p=q <-> contents=nil)).
Proof.
intros.
apply derives_trans with (lseg sh contents p q && !! (is_pointer_or_null p /\
        is_pointer_or_null q /\ (p = q <-> contents = []))).
2: entailer!.
revert p; induction contents; intros; simpl; unfold lseg; fold lseg.
entailer!.
intuition.
Intros y. Exists y.
eapply derives_trans.
apply sepcon_derives.
apply derives_refl.
apply IHcontents.
entailer!.
intuition congruence.
Qed.

#[export] Hint Resolve lseg_local_facts : saturate_local.

Lemma lseg_valid_pointer:
  forall sh contents p ,
   sepalg.nonidentity sh ->
   lseg sh contents p nullval |-- valid_pointer p.
Proof.
 destruct contents; unfold lseg; fold lseg; intros. entailer!.
 Intros. Intros y.
 auto with valid_pointer.
Qed.

#[export] Hint Resolve lseg_valid_pointer : valid_pointer.

Lemma lseg_eq: forall sh contents x,
    lseg sh contents x x = !! (contents=nil /\ is_pointer_or_null x) && emp.
Proof.
intros.
destruct contents; unfold lseg; fold lseg.
f_equal. f_equal. f_equal. apply prop_ext; intuition.
apply pred_ext.
Intros y. contradiction.
Intros. discriminate.
Qed.

Lemma lseg_null: forall sh contents,
    lseg sh contents nullval nullval = !! (contents=nil) && emp.
Proof.
intros.
 rewrite lseg_eq.
 apply pred_ext.
 entailer!.
 entailer!.
Qed.

Lemma lseg_cons: forall sh (v u x: val) s,
   readable_share sh ->
 data_at sh t_struct_list (v, u) x * lseg sh s u nullval
 |-- lseg sh [v] x u * lseg sh s u nullval.
Proof.
intros.
     unfold lseg at 2. Exists u.
     entailer.
     destruct s; unfold lseg at 1; fold lseg; entailer.
Qed.

Lemma lseg_cons': forall sh (v u x a b: val) ,
   readable_share sh ->
 data_at sh t_struct_list (v, u) x * data_at sh t_struct_list (a,b) u
 |-- lseg sh [v] x u * data_at sh t_struct_list (a,b) u.
Proof.
intros.
     unfold lseg. Exists u.
     entailer.
Qed.

Lemma lseg_app': forall sh s1 s2 (a w x y z: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x y * data_at sh t_struct_list (a,z) y |--
   lseg sh (s1++s2) w y * data_at sh t_struct_list (a,z) y.
Proof.
 intros.
 revert w; induction s1; intro; simpl.
 unfold lseg at 1. entailer!.
 unfold lseg at 1 3; fold lseg. Intros j; Exists j.
 entailer.
 sep_apply (IHs1 j).
 cancel.
Qed.

Lemma lseg_app_null: forall sh s1 s2 (w x: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x nullval |--
   lseg sh (s1++s2) w nullval.
Proof.
 intros.
 revert w; induction s1; intro; simpl.
 unfold lseg at 1. entailer!.
 unfold lseg at 1 3; fold lseg. Intros j; Exists j.
 entailer.
 sep_apply (IHs1 j).
 cancel.
Qed.

Lemma lseg_app: forall sh s1 s2 a s3 (w x y z: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x y * lseg sh (a::s3) y z |--
   lseg sh (s1++s2) w y * lseg sh (a::s3) y z.
Proof.
 intros.
 unfold lseg at 3 5; fold lseg.
 Intros u; Exists u. rewrite prop_true_andp by auto.
 sep_apply (lseg_app' sh s1 s2 a w x y u); auto.
 cancel.
Qed.

Lemma listrep_lseg_null :
 listrep = fun sh s p => lseg sh s p nullval.
Proof.
extensionality sh s p.
revert p.
induction s; intros.
unfold lseg, listrep; apply pred_ext; entailer!.
unfold lseg, listrep; fold lseg; fold listrep.
apply pred_ext; Intros y; Exists y; rewrite IHs; entailer!.
Qed.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
revert POSTCONDITION; rewrite listrep_lseg_null; intro.
forward_if.
*
 subst x. rewrite lseg_null. Intros. subst.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold lseg at 1; fold lseg.
 Intros. contradiction H.
 Intros u.
 clear - SH.
 remember (v::s1') as s1.
 forward.
 forward_while
      (EX s1a: list val, EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP (s1 = s1a ++ a :: s1b)
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (lseg sh s1a x t;
                   data_at sh t_struct_list (a,u) t;
                   lseg sh s1b u nullval;
                   lseg sh s2 y nullval))%assert.
 + (* current assertion implies loop invariant *)
     Exists (@nil val) v s1' x u.
     subst s1. rewrite lseg_eq.
     entailer.
(*     sep_apply (lseg_cons sh v u x s1'); auto. *)
 + (* loop test is safe to execute *)
     entailer!.
 + (* loop body preserves invariant *)
    destruct s1b; unfold lseg at 2; fold lseg.
    Intros. contradiction.
    Intros z.
    forward.
    forward.
    Exists (s1a++a::nil, v0, s1b,u0,z). unfold fst, snd.
    simpl app; rewrite app_ass.
    entailer.
    sep_apply (lseg_cons' sh a u0 t v0 z); auto.
    sep_apply (lseg_app' sh s1a [a] v0 x t u0 z); auto.
    cancel.
 + (* after the loop *)
    clear v s1' Heqs1.
    subst. rewrite lseg_eq. Intros. subst.
    forward.
    forward.
    Exists x.
    entailer!.
    sep_apply (lseg_cons sh a y t s2); auto.
    sep_apply (lseg_app_null sh [a] s2 t y); auto.
    rewrite app_ass.
    sep_apply (lseg_app_null sh s1a ([a]++s2) x t); auto.
Qed.

End Proof3.


Require Import RelationClasses.
Require Import List.
Require Import Omega.
Require Import sflib.
From Paco Require Import paco.
Require Import Basics.

Require Import Basic.
Require Import Axioms.
Require Import Loc.
Require Import Language.
Require Import ZArith.
Require Import Maps.

Require Import FSets.
Require Import FSetInterface.
Require Import Lattice.
Require Import Event.
Require Import Syntax.
Require Import Semantics.
Require Import Kildall.
Require Import Coqlib.

Require Import Integers.
Require Import LibTactics.
Require Import ValAnalysis.
Require Import CorrectOpt.
Set Implicit Arguments.

(** * Constant Propagation *)

(** Constant propagation first uses value analysis to analyze program and
    then translates program according to the result of analysis. *)

(** ** Transformation for the Single Instruction *)
Definition transform_inst (inst: Inst.t) (ae: ValLat.t) : Inst.t :=
  match inst with
  | Inst.assign r e =>
    match (eval_expr_ae e (fst ae)) with
    | LVal.VAL v => Inst.assign r (Inst.expr_val v)
    | _ => Inst.assign r e
    end
  | Inst.load r loc or =>
    match or with
    | Ordering.plain =>
      match (VALSET.get loc (snd ae)) with
      | LVal.VAL v => Inst.assign r (Inst.expr_val v)
      | _ => Inst.load r loc or
      end
    | _ => Inst.load r loc or
    end
  | _ => inst
  end.

Lemma eval_expr_ae_bot_to_val_false:
  forall expr n,
    eval_expr_ae expr VALSET.bot = LVal.VAL n -> False.
Proof.
  induction expr; ss; eauto.
Qed.

Lemma transform_inst_bot
      inst:
  transform_inst inst ValDS.AI.bot = inst.
Proof.
  destruct inst; eauto.
  ss. destruct (eval_expr_ae rhs VALSET.bot) eqn:Heqe; ss; eauto.
  eapply eval_expr_ae_bot_to_val_false in Heqe; eauto. ss.
  ss. destruct or; ss; eauto.
Qed.

(** ** Transformation for the basic block *)
Fixpoint transform_blk (ae_blk: ValDS.AI.b) (b_s: BBlock.t) {struct b_s}: BBlock.t :=
  match b_s, ae_blk with
  | i##b_s', ValDS.AI.Cons ae ae_blk' =>
    (transform_inst i ae)##(transform_blk ae_blk' b_s')
  | _, _ => b_s
  end.

Lemma transform_blk_bot':
  forall BB,
    transform_blk ValDS.AI.bots BB = BB.
Proof.
  destruct BB; ss; eauto.
Qed.

Lemma transform_blk_bot:
  forall BB,
    transform_blk (transf_blk ValDS.AI.bot BB) BB = transform_blk ValDS.AI.bots BB.
Proof.
  induction BB; try solve [ss; eauto].
  assert (transf_blk ValDS.AI.bot (c ## BB) =
          ValDS.AI.Cons ValDS.AI.bot (transf_blk (transf_instr c ValDS.AI.bot) BB)). eauto.
  assert (transf_instr c ValDS.AI.bot = ValDS.AI.bot).
  eapply transf_instr_bot; eauto.
  rewrite H0 in H; clear H0.
  rewrite H. clear H.
  simpl. rewrite IHBB.
  rewrite transform_inst_bot.
  rewrite transform_blk_bot'. eauto.
Qed.

(** ** Transformation for the code heap *)
Definition transform_cdhp (cdhp: CodeHeap) (analysis: ValDS.AI.ACdhp): CodeHeap :=
  PTree.map (fun (i: positive) (b: BBlock.t) => transform_blk (analysis!!i) b) cdhp.

Lemma transform_cdhp_prop
      C_src BB_src f afunc
      (GET: C_src ! f = Some BB_src):
  exists BB_tgt, (transform_cdhp C_src afunc) ! f = Some BB_tgt.
Proof.
  unfold transform_cdhp.
  rewrite PTree.gmap. unfold option_map.
  rewrite GET. eauto.
Qed.

(** ** Code transformation for a function *)
Definition transform_func (func: Func): option Func :=
  match ValDS.analyze_func func succ ValLat.top transf_blk with
  | Some analysis =>
    let (cdhp, fid) := func in Some (transform_cdhp cdhp analysis, fid)
  (* transformation error, since there is no analysis result *)
  | None => None
  end.

(** ** Code transformation for a program *)
(** [transform_prog] translates each function in the program according to [transform_func]. *)
Fixpoint transform_prog (prog: Code): option Code :=
  match prog with
  | PTree.Leaf => Some PTree.Leaf
  | PTree.Node prog1 None prog2 =>
    match (transform_prog prog1), (transform_prog prog2) with
    | Some progt1, Some progt2 => Some (PTree.Node progt1 None progt2)
    | _, _ => None
    end
  | PTree.Node prog1 (Some func) prog2 =>
    match transform_func func with
    | Some func_t =>
      match (transform_prog prog1), (transform_prog prog2) with
      | Some progt1, Some progt2 => Some (PTree.Node progt1 (Some func_t) progt2)
      | _, _ => None
      end
    | None => None
    end
  end.

Lemma transform_prog_proper:
  forall prog_s prog_t fid func_s
    (TRANS_FORM: transform_prog prog_s = Some prog_t)
    (FUNC: prog_s ! fid = Some func_s),
  exists func_t, prog_t ! fid = Some func_t /\ transform_func func_s = Some func_t.
Proof.
  induction prog_s; ss; ii.
  - rewrite PTree.gleaf in FUNC. tryfalse.
  - destruct fid; ss.
    + destruct o; ss.
      destruct (transform_func f) eqn:TRANS_FUNC; ss.
      destruct (transform_prog prog_s1) eqn:TRANS_PROG1; ss.
      destruct (transform_prog prog_s2) eqn:TRANS_PROG2; ss.
      inv TRANS_FORM.
      eapply IHprog_s2 in FUNC; eauto.
      destruct (transform_prog prog_s1) eqn:TRANS_PROG1; ss.
      destruct (transform_prog prog_s2) eqn:TRANS_PROG2; ss.
      inv TRANS_FORM.
      eapply IHprog_s2 in FUNC; eauto.
    + destruct o; ss.
      destruct (transform_func f) eqn:TRANS_FUNC; ss.
      destruct (transform_prog prog_s1) eqn:TRANS_PROG1; ss.
      destruct (transform_prog prog_s2) eqn:TRANS_PROG2; ss.
      inv TRANS_FORM.
      eapply IHprog_s1 in FUNC; eauto.
      destruct (transform_prog prog_s1) eqn:TRANS_PROG1; ss.
      destruct (transform_prog prog_s2) eqn:TRANS_PROG2; ss.
      inv TRANS_FORM.
      eapply IHprog_s1 in FUNC; eauto.
    + subst; ss.
      destruct (transform_func func_s) eqn:TRANS_FUNC; ss.
      destruct (transform_prog prog_s1) eqn:TRANS_PROG1; ss.
      destruct (transform_prog prog_s2) eqn:TRANS_PROG2; ss.
      inv TRANS_FORM.
      exists f. split; eauto.
Qed.

Lemma transform_prog_proper_none:
  forall prog_s prog_t fid
    (TRANS_FORM: transform_prog prog_s = Some prog_t)
    (FUNC: prog_s ! fid = None),
    prog_t ! fid = None.
Proof.
  induction prog_s; ss; ii.
  - inv TRANS_FORM. rewrite PTree.gleaf; eauto.
  - destruct fid; ss.
    + destruct o; ss.
      destruct (transform_func f) eqn:TRANS_FUNC; ss.
      destruct (transform_prog prog_s1) eqn:TRANS_PROG1; ss.
      destruct (transform_prog prog_s2) eqn:TRANS_PROG2; ss.
      inv TRANS_FORM; eauto.
      destruct (transform_prog prog_s1) eqn:TRANS_PROG1; ss.
      destruct (transform_prog prog_s2) eqn:TRANS_PROG2; ss.
      inv TRANS_FORM; eauto.
    + destruct o; ss.
      destruct (transform_func f) eqn:TRANS_FUNC; ss.
      destruct (transform_prog prog_s1) eqn:TRANS_PROG1; ss.
      destruct (transform_prog prog_s2) eqn:TRANS_PROG2; ss.
      inv TRANS_FORM; eauto.
      destruct (transform_prog prog_s1) eqn:TRANS_PROG1; ss.
      destruct (transform_prog prog_s2) eqn:TRANS_PROG2; ss.
      inv TRANS_FORM; eauto.
    + destruct o; ss.
      destruct (transform_prog prog_s1) eqn:TRANS_PROG1; ss.
      destruct (transform_prog prog_s2) eqn:TRANS_PROG2; ss.
      inv TRANS_FORM; eauto.
Qed.

Lemma transform_func_init
      c_s f_s c_t f_t B_t
      (TRANS_FUNC: transform_func (c_s, f_s) = Some (c_t, f_t))
      (ENTRY_BB_T: c_t ! f_t = Some B_t):
  exists B_s ab, c_s ! f_s = Some B_s /\
            ValDS.analyze_func (c_s, f_s) succ ValLat.top transf_blk = Some ab /\
            transform_cdhp c_s ab = c_t /\ f_s = f_t.
Proof.
  unfold transform_func in *.
  destruct (ValDS.analyze_func (c_s, f_s) succ ValLat.top transf_blk) eqn:ANALYSIS; tryfalse.
  inv TRANS_FUNC. unfold transform_cdhp in ENTRY_BB_T.
  rewrite PTree.gmap in ENTRY_BB_T.
  unfold option_map in ENTRY_BB_T.
  destruct (c_s ! f_t) eqn:Heqe; tryfalse.
  exists t a. split; eauto.
Qed.

Lemma transf_cdhp_prop
      C_src C_tgt afunc BB_tgt f f_s ep
      (ANALYSIS_FUNC: ValDS.analyze_func (C_src, f_s) succ ep transf_blk = Some afunc)
      (TRANS_CDHP: transform_cdhp C_src afunc = C_tgt)
      (BB: C_tgt ! f = Some BB_tgt):
  exists BB_src ae_pblk,
    C_src ! f = Some BB_src /\
    transf_blk (ValDS.AI.getFirst (afunc !! f)) BB_src = ae_pblk /\
    transform_blk ae_pblk BB_src = BB_tgt /\
    (forall s BB_src',
        In s (succ BB_src) -> C_src ! s = Some BB_src' ->
        ValDS.L.ge (ValDS.AI.getFirst (afunc !! s)) (ValDS.AI.getLast ae_pblk)).
Proof.
  unfold transform_cdhp in TRANS_CDHP.
  subst. rewrite PTree.gmap in BB.
  unfold option_map in BB. destruct (C_src ! f) eqn:BB_SRC; ss.
  inv BB. renames t to BB_src.
  do 2 eexists. splits; eauto.
  - exploit ValDS.analyze_func_solution_get; [ | | eapply ANALYSIS_FUNC | eauto..].
    eapply transf_blk_first; eauto.
    eapply transf_blk_bot; eauto.
    i. des1. rewrite H. eauto.
    rewrite H; ss.
    rewrite transform_blk_bot. eauto.
  - ii.
    eapply ValDS.analyze_func_solution1 in ANALYSIS_FUNC; eauto.
    ii. eapply transf_blk_first; eauto.
    ii. eapply transf_blk_bot; eauto.
Qed.

(** ** The Implementation of Constant propagation *)
Definition constprop_optimizer: Optimizer rtl_lang :=
  fun (lo: Ordering.LocOrdMap) (prog_s: Code) => transform_prog prog_s.