(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Relational specification of expression simplification. *)

Require Import Coqlib (* Maps  *)Errors Integers Floats.
Require Import AST Linking Memory.
Require Import Ctypes Cop Csyntax Clight SimplExpr.
Require Import MoSel.
Import Maps.PTree.
Export weakestpre_gensym.

Section SPEC.

  Local Open Scope gensym_monad_scope.
  Notation "a ! b" := (get b a) (at level 1).
  (** * Relational specification of the translation. *)

  (** ** Translation of expressions *)

  (** This specification covers:
- all cases of [transl_lvalue] and [transl_rvalue];
- two additional cases for [Csyntax.Eparen], so that reductions of [Csyntax.Econdition]
  expressions are properly tracked;
- three additional cases allowing [Csyntax.Eval v] C expressions to match
  any Clight expression [a] that evaluates to [v] in any environment
  matching the given temporary environment [le].
   *)

  Ltac tac2 :=
    match goal with
    | |- bi_emp_valid ({{ _ }} bind2 _ (fun _ _ => _) {{ _, RET _; _ }}) =>
      eapply bind_spec; intros; tac2
    | _ => tac
    end.

  Notation "\s l" := (∃ t, l ↦ t) (at level 10).
  Definition final (dst: destination) (a: expr) : list statement :=
    match dst with
    | For_val => nil
    | For_effects => nil
    | For_set sd => do_set sd a
    end.

  Definition dest_below (dst: destination) : iProp :=
    match dst with
    | For_set sd => \s (sd_temp sd)
    | _ => \⌜True⌝
    end.

  (** Iris version *)
  Definition tr_rvalof (ty : type) (e1 : expr) (lse : list statement * expr) : iProp :=
    if type_is_volatile ty
    then
      (∃ t, \⌜ lse = (make_set t e1 :: nil ,Etempvar t ty)⌝ ∗ t ↦ ty )%I
    else
      \⌜lse = (nil,e1)⌝%I.

  Fixpoint tr_expr (le : temp_env) (dst : destination) (e : Csyntax.expr)
           (sla : list statement * expr) : iProp := ⌜ True ⌝ ∗
    match e with
    | Csyntax.Evar id ty =>
      dest_below dst ∗
                 \⌜ sla = (final dst (Evar id ty),Evar id ty) ⌝
    | Csyntax.Ederef e1 ty =>
      ∃ sla2, tr_expr le For_val e1 sla2 ∗
                      dest_below dst ∗
                      \⌜sla = (sla2.1 ++ final dst (Ederef' sla2.2 ty),Ederef' sla2.2 ty)⌝
| Csyntax.Efield e1 f ty =>
  ∃ sla2, tr_expr le For_val e1 sla2 ∗
                  dest_below dst ∗
                  \⌜ sla = (sla2.1 ++ final dst (Efield sla2.2 f ty),Efield sla2.2 f ty) ⌝

| Csyntax.Eval v ty =>
  match dst with
  | For_effects => ⌜sla.1 = nil⌝
  | For_val =>
    (∀ tge e le' m, (∀ id, \s id -∗ ⌜ le'!id = le!id ⌝) -∗ ⌜ eval_expr tge e le' m sla.2 v ⌝) ∗ ⌜ typeof sla.2 = ty /\ sla.1 = nil ⌝
  | For_set sd => ∃ a,
    (∀ tge e le' m, (∀ id, \s id -∗ ⌜ le'!id = le!id ⌝) -∗ ⌜ eval_expr tge e le' m a v ⌝) ∗ ⌜ typeof a = ty /\ sla.1 = do_set sd a ⌝
  end
| Csyntax.Esizeof ty' ty =>
  dest_below dst ∗
             \⌜ sla = (final dst (Esizeof ty' ty), Esizeof ty' ty)⌝
| Csyntax.Ealignof ty' ty =>
  dest_below dst ∗
             \⌜ sla = (final dst (Ealignof ty' ty), Ealignof ty' ty) ⌝
| Csyntax.Evalof e1 ty =>
  ∃ sla2 sl3, tr_expr le For_val e1 sla2  ∗
                      tr_rvalof (Csyntax.typeof e1) sla2.2 (sl3,sla.2)  ∗
                      dest_below dst ∗
                      \⌜ sla.1 = (sla2.1 ++ sl3 ++ final dst sla.2) ⌝
| Csyntax.Eaddrof e1 ty =>
  ∃ sla2, tr_expr le For_val e1 sla2  ∗
                  dest_below dst ∗
                  \⌜ sla = (sla2.1 ++ final dst (Eaddrof' sla2.2 ty), Eaddrof' sla2.2 ty) ⌝
| Csyntax.Eunop ope e1 ty =>
  ∃ sla2, tr_expr le For_val e1 sla2  ∗
                  dest_below dst ∗
                  \⌜ sla = (sla2.1 ++ final dst (Eunop ope sla2.2 ty), Eunop ope sla2.2 ty) ⌝
| Csyntax.Ebinop ope e1 e2 ty =>
  ∃ sla2 sla3, tr_expr le For_val e1 sla2  ∗
                       tr_expr le For_val e2 sla3  ∗
                       dest_below dst ∗
                       \⌜ sla = (sla2.1 ++ sla3.1 ++ final dst (Ebinop ope sla2.2 sla3.2 ty), Ebinop ope sla2.2 sla3.2 ty) ⌝
| Csyntax.Ecast e1 ty =>
  ∃ sla2, tr_expr le For_val e1 sla2  ∗
                  dest_below dst ∗
                  \⌜ sla = (sla2.1 ++ final dst (Ecast sla2.2 ty), Ecast sla2.2 ty ) ⌝
| Csyntax.Eseqand e1 e2 ty =>
  match dst with
  | For_val =>
    ∃ sla2 sla3 t, tr_expr le For_val e1 sla2  ∗
                           (\s t -∗ tr_expr le (For_set (sd_seqbool_val t ty)) e2 sla3)  ∗
                           \s t ∗
                           \⌜ sla = (sla2.1 ++ makeif sla2.2 (makeseq sla3.1) (Sset t (Econst_int Int.zero ty)) :: nil, Etempvar t ty ) ⌝
| For_effects =>
  ∃ sla2 sla3, tr_expr le For_val e1 sla2  ∗
                       tr_expr le For_effects e2 sla3  ∗
                       \⌜  sla.1 = sla2.1 ++ makeif sla2.2 (makeseq sla3.1) Sskip :: nil ⌝
| For_set sd =>
  ∃ sla2 sla3, tr_expr le For_val e1 sla2  ∗
                       (\s (sd_temp sd) -∗ tr_expr le (For_set (sd_seqbool_set ty sd)) e2 sla3)  ∗
                       \s (sd_temp sd)  ∗
                       ⌜ sla.1 = sla2.1 ++ makeif sla2.2 (makeseq sla3.1) (makeseq (do_set sd (Econst_int Int.zero ty))) :: nil ⌝
  end
| Csyntax.Eseqor e1 e2 ty =>
  match dst with
  | For_val =>
    ∃ sla2 sla3 t, tr_expr le For_val e1 sla2  ∗
                           (\s t -∗ tr_expr le (For_set (sd_seqbool_val t ty)) e2 sla3)  ∗
                           \s t ∗
                           \⌜ sla = (sla2.1 ++ makeif sla2.2 (Sset t (Econst_int Int.one ty)) (makeseq sla3.1) :: nil, Etempvar t ty) ⌝
| For_effects =>
  ∃ sla2 sla3, tr_expr le For_val e1 sla2  ∗
                       tr_expr le For_effects e2 sla3  ∗
                       \⌜ sla.1 = sla2.1 ++ makeif sla2.2 Sskip (makeseq sla3.1) :: nil ⌝
| For_set sd =>
  ∃ sla2 sla3, tr_expr le For_val e1 sla2  ∗
                       (\s (sd_temp sd) -∗ tr_expr le (For_set (sd_seqbool_set ty sd)) e2 sla3)  ∗
                       \s (sd_temp sd)  ∗
                       ⌜ sla.1 = sla2.1 ++ makeif sla2.2 (makeseq (do_set sd (Econst_int Int.one ty))) (makeseq sla3.1) :: nil ⌝
  end

| Csyntax.Econdition e1 e2 e3 ty =>
  match dst with
  | For_val =>
    ∃ sla2 sla3 sla4 t,
    tr_expr le For_val e1 sla2 ∗
    \s t ∗
    (\s t -∗ (tr_expr le (For_set (SDbase ty ty t)) e2 sla3 ∧
    tr_expr le (For_set (SDbase ty ty t)) e3 sla4)) ∗
    \⌜ sla = (sla2.1 ++ makeif sla2.2 (makeseq sla3.1) (makeseq sla4.1) :: nil,Etempvar t ty)⌝
| For_effects =>
  ∃ sla2 sla3 sla4,
    tr_expr le For_val e1 sla2  ∗
    tr_expr le For_effects e2 sla3 ∗
    tr_expr le For_effects e3 sla4 ∗
    \⌜ sla.1 = sla2.1 ++ makeif sla2.2 (makeseq sla3.1) (makeseq sla4.1) :: nil ⌝
| For_set sd =>
  ∃ sla2 sla3 sla4 t,
    tr_expr le For_val e1 sla2  ∗
    \s t ∗
    (\s t -∗ (tr_expr le (For_set (SDcons ty ty t sd)) e2 sla3 ∧
    tr_expr le (For_set (SDcons ty ty t sd)) e3 sla4)) ∗
    ⌜ sla.1 = sla2.1 ++ makeif sla2.2 (makeseq sla3.1) (makeseq sla4.1) :: nil ⌝
  end
| Csyntax.Eassign e1 e2 ty =>
  ∃ sla2 sla3,
  tr_expr le For_val e1 sla2  ∗
  tr_expr le For_val e2 sla3  ∗
  (⌜ sla.1 = sla2.1 ++ sla3.1 ++ make_assign sla2.2 sla3.2 :: nil /\  dst = For_effects ⌝ ∨ (∃ t, \s t ∗ ⌜ sla.1 = sla2.1 ++ sla3.1 ++ Sset t (Ecast sla3.2 (Csyntax.typeof e1)) :: make_assign sla2.2 (Etempvar t (Csyntax.typeof e1)) :: final dst (Etempvar t (Csyntax.typeof e1)) ⌝))
| Csyntax.Eassignop ope e1 e2 tyres ty =>
  ∃ sla2 sla3 sla4,
    tr_expr le For_val e1 sla2  ∗
    tr_expr le For_val e2 sla3  ∗
    tr_rvalof (Csyntax.typeof e1) sla2.2 sla4  ∗
    (⌜ dst = For_effects /\
     sla.1 = sla2.1 ++ sla3.1 ++ sla4.1 ++ make_assign sla2.2 (Ebinop ope sla4.2 sla3.2 tyres) :: nil ⌝ ∨ (∃ t, \s t ∗ ⌜ sla = (sla2.1 ++ sla3.1 ++ sla4.1 ++ Sset t (Ecast (Ebinop ope sla4.2 sla3.2 tyres) (Csyntax.typeof e1)) :: make_assign sla2.2 (Etempvar t (Csyntax.typeof e1)) :: final dst (Etempvar t (Csyntax.typeof e1)), (Etempvar t (Csyntax.typeof e1))) ⌝))
| Csyntax.Epostincr id e1 ty =>
  ((∃ sla2 sla3,
        tr_expr le For_val e1 sla2  ∗
                tr_rvalof (Csyntax.typeof e1) sla2.2 sla3  ∗
                ⌜ sla.1 = sla2.1 ++ sla3.1 ++
                                 make_assign sla2.2 (transl_incrdecr id sla3.2 (Csyntax.typeof e1)) :: nil ⌝) ∨
                                                                                (∃ sla2 t,
                                                                                tr_expr le For_val e1 sla2  ∗
                                                                                \s t  ∗
                                                                                ⌜ sla = (sla2.1 ++ make_set t sla2.2 ::
                                                                                make_assign sla2.2 (transl_incrdecr id (Etempvar t (Csyntax.typeof e1)) (Csyntax.typeof e1)) ::
                                                                                final dst (Etempvar t (Csyntax.typeof e1)),Etempvar t (Csyntax.typeof e1))⌝))

| Csyntax.Ecomma e1 e2 ty =>
  ∃ sla2 sl3,
    tr_expr le For_effects e1 sla2  ∗
            (dest_below dst -∗ tr_expr le dst e2 (sl3,sla.2))  ∗
            dest_below dst ∗
            \⌜ sla.1 = sla2.1 ++ sl3 ⌝

| Csyntax.Ecall e1 el2 ty =>
  match dst with
  | For_effects =>
    ∃ sla2 slal3,
    tr_expr le For_val e1 sla2  ∗
            tr_exprlist le el2 slal3  ∗
            \⌜  sla.1 = sla2.1 ++ slal3.1 ++ Scall None sla2.2 slal3.2 :: nil ⌝
| _ =>
  ∃ sla2 slal3 t,
    tr_expr le For_val e1 sla2  ∗
            tr_exprlist le el2 slal3  ∗
            \s t  ∗
            dest_below dst ∗
            \⌜ sla = (sla2.1 ++ slal3.1 ++ Scall (Some t) sla2.2 slal3.2 :: final dst (Etempvar t ty), Etempvar t ty)⌝
  end

| Csyntax.Ebuiltin ef tyargs el ty =>
  match dst with
  | For_effects =>
    ∃ slal2,
    tr_exprlist le el (slal2)  ∗
                \⌜ sla.1 = slal2.1 ++ Sbuiltin None ef tyargs slal2.2 :: nil ⌝
| _ =>
  ∃ slal2 t,
    tr_exprlist le el slal2  ∗
                \s t  ∗
                dest_below dst ∗
                \⌜ sla = (slal2.1 ++ Sbuiltin (Some t) ef tyargs slal2.2 :: final dst (Etempvar t ty), Etempvar t ty)⌝
  end

| Csyntax.Eparen e1 tycast ty =>
  match dst with
  | For_val =>
    ∃ a2 t,
    (\s t  -∗ tr_expr le (For_set (SDbase tycast ty t)) e1 (sla.1,a2))  ∗
            \s t  ∗
            ⌜ sla.2 = Etempvar t ty ⌝
| For_effects =>
  ∃ a2, tr_expr le For_effects e1 (sla.1,a2)
| For_set sd =>
  ∃ a2 t,
    (\s t -∗ tr_expr le (For_set (SDcons tycast ty t sd)) e1 (sla.1,a2))  ∗ \s t
  end

| _ => False
  end
  with tr_exprlist (le : temp_env) (e : Csyntax.exprlist) (sla : list statement * list expr) : iProp := ⌜ True ⌝ ∗
         match e with
         | Csyntax.Enil => \⌜ sla = (nil,nil)⌝
         | Csyntax.Econs e1 el2 =>
           ∃ sla2 slal3,
    tr_expr le For_val e1 sla2  ∗
            tr_exprlist le el2 slal3  ∗
            \⌜ sla = (sla2.1 ++ slal3.1, sla2.2 :: slal3.2) ⌝
  end.

  Lemma transl_valof_meets_spec ty a :
    {{ emp }} transl_valof ty a {{ r, RET r; tr_rvalof ty a r }}.
  Proof.
    unfold transl_valof. unfold tr_rvalof.
    destruct (type_is_volatile ty); tac.
    frameR. iApply ret_spec_bis.
    iPureIntro; reflexivity.
  Qed.

  (** ** Top-level translation *)

  (** The "top-level" translation is equivalent to [tr_expr] above
  for source terms.  It brings additional flexibility in the matching
  between Csyntax values and Cminor expressions: in the case of
  [tr_expr], the Cminor expression must not depend on memory,
  while in the case of [tr_top] it can depend on the current memory
  state. *)

  Scheme expr_ind2 := Induction for Csyntax.expr Sort Prop
    with exprlist_ind2 := Induction for Csyntax.exprlist Sort Prop.
  Combined Scheme tr_expr_exprlist from expr_ind2, exprlist_ind2.

  Lemma tr_expr_abs : forall (Q : iProp) le dst r res,
      tr_expr le dst r res ∗ Q -∗ tr_expr le dst r res.
  Proof.
    induction r; iIntros "* [[HC HA] HB]"; iSplitL "HC HB"; trivial.
  Qed.

  Lemma transl_meets_spec :
    (forall r dst,
        {{ emp }} transl_expr dst r {{ res, RET res; (∀ le, dest_below dst -∗ tr_expr le dst r res)}})
    /\
    (forall rl,
        {{ emp }} transl_exprlist rl {{ res, RET res; (∀ le, tr_exprlist le rl res) }}).
  Proof.
    pose transl_valof_meets_spec.
    apply tr_expr_exprlist; intros; rewrite /transl_expr; rewrite /transl_exprlist;
      fold transl_exprlist; fold transl_expr; tac2; rewrite /tr_expr; fold tr_expr; tac2.
    - destruct v; tac2; iApply ret_spec_complete; destruct dst; iIntros; eauto; iSplitR; auto;
        try (iExists _); try iSplit; eauto; iIntros; simpl;
          iPureIntro; eauto; intros; constructor; reflexivity.
    - iApply ret_spec_complete. iIntros "[HA HB]"; iFrame.
      destruct dst; iIntros; iPureIntro; auto.
    - apply forall_wand_true_pre. iApply ret_spec_complete. iIntros "HA" (?) "HB". iSplit; auto.
      iExists v. iFrame.
      iSplitL "HA". iApply "HA". iPureIntro.
      destruct dst; simpl; eauto; rewrite app_nil_r; reflexivity.
    - frameR; apply b.
    - iApply ret_spec_complete.
      iIntros "[HA HB]" (?) "HC". iSplit; auto. iExists v; iExists v0.1. iFrame. iSplitL "HB". iApply "HB". trivial.
      destruct dst; iSimpl; iSplitL "HA"; try(rewrite <- surjective_pairing; iApply "HA");
        iPureIntro; try(rewrite app_nil_r; reflexivity); rewrite app_assoc; reflexivity.
    - iApply ret_spec_complete.
      iIntros "HA" (le) "HB". iSplit; auto. iExists v. iSplitL "HA". iApply "HA". trivial. iFrame.
      iPureIntro. destruct dst; simpl; try (rewrite app_nil_r); reflexivity.
    - iApply ret_spec_complete.
      iIntros "HA" (le) "HB". iSplit; auto. iExists v. iFrame. iSplitL "HA". iApply "HA". trivial.
      iPureIntro. destruct dst; simpl; try (rewrite app_nil_r); reflexivity.
    - iApply ret_spec_complete.
      iIntros "HA" (le) "HB". iSplit; auto. iExists v. iSplitL "HA". iApply "HA". trivial. iFrame.
      iPureIntro. destruct dst; simpl; try (rewrite app_nil_r); reflexivity.
    - frameR. apply H0.
    - iApply ret_spec_complete.
      iIntros "[HA HC]" (le) "HB". iSplit; auto.
      repeat iExists _. iFrame.
      iSplitL "HC". iApply "HC". trivial.
      iSplitL "HA". iApply "HA". trivial.
      iPureIntro. destruct dst; simpl; try (rewrite app_nil_r; reflexivity).
      rewrite app_assoc. reflexivity.
    - iApply ret_spec_complete.
      iIntros "HA" (le) "HB". iSplit; auto. iExists _. iSplitL "HA". iApply "HA". trivial. iFrame.
      iPureIntro. destruct dst; simpl; try (rewrite app_nil_r); reflexivity.
    - destruct dst; repeat tac2.
      + frameR. apply H0.
      + iApply ret_spec_complete.
        iIntros "[HA [HC HD]]" (?) "_". iSplit; auto. repeat iExists _.
        iSplitL "HD". iApply "HD". trivial.
        iSplitL "HA". iIntros "HB". iApply "HA". iSimpl. iApply "HB".
        iSplitL "HC". iExists ty. iApply "HC".
        iPureIntro. reflexivity.
      + frameR. apply H0.
      + iApply ret_spec_complete.
        iIntros "[HA HC]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HA". iApply "HA".  trivial.
        iPureIntro. reflexivity.
      + frameR. apply H0.
      + iApply ret_spec_complete. iIntros "[HA HC]" (le) "HB". iFrame.
        repeat iExists _.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HA". iApply "HA".
        iPureIntro. reflexivity.
    - destruct dst; repeat tac2.
      + frameR. apply H0.
      + iApply ret_spec_complete.
        iIntros "[HA [HC HD]]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HD". iApply "HD". trivial.
        iSplitL "HA". iIntros "HB". iApply "HA". simpl. iApply "HB".
        iSplitL "HC". iExists ty. iApply "HC".
        iPureIntro. reflexivity.
      + frameR. apply H0.
      + iApply ret_spec_complete.
        iIntros "[HA HC]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HA". iApply "HA".  trivial.
        iPureIntro. reflexivity.
      + frameR. apply H0.
      + iApply ret_spec_complete. iIntros "[HA HC]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HA". iApply "HA". iFrame.
        iPureIntro. reflexivity.
    - destruct dst; repeat tac2.
      + frameR. apply H0.
      + frameR. apply H1.
      + iApply ret_spec_complete.
        iIntros "[HA [HC [HE HD]]]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HD". iApply "HD". trivial.
        iSplitL "HE". iExists ty. iFrame.
        iSplitL "HC HA".
        iIntros "HB".
        iSplit.
        * iDestruct ("HC" $! le with "HB") as "HC". iApply tr_expr_abs. iFrame. iApply "HA".
        * iDestruct ("HA" $! le with "HB") as "HA". iApply tr_expr_abs. iFrame. iApply "HC".
        * iPureIntro. reflexivity.
      + frameR. apply H0.
      + frameR. apply H1.
      + iApply ret_spec_complete.
        iIntros "[HA [HC HD]]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HD". iApply "HD". trivial.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HA". iApply "HA". trivial.
        iPureIntro. reflexivity.
      + frameR. apply H0.
      + frameR. apply H1.
      + iApply ret_spec_complete.
        iIntros "[HA [HD [HE HC]]]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HE". iExists ty. iFrame.
        iSplitL "HD HA".
        iIntros "HB".
        iSplit.
        * iDestruct ("HD" $! le with "HB") as "HC". iApply tr_expr_abs. iFrame.
          iApply "HA".
        * iDestruct ("HA" $! le with "HB") as "HA". iApply tr_expr_abs. iFrame.
          iApply "HD".
        * iPureIntro. reflexivity.
    - iApply ret_spec_complete. iIntros "[HA HB]". iSplit; auto. iFrame. iPureIntro. destruct dst; reflexivity.
    - iApply ret_spec_complete. iIntros "[HA HB]". iSplit; auto. iFrame. iPureIntro. destruct dst; reflexivity.
    - frameR. eapply H0.
    - destruct dst; tac2.
      + iApply ret_spec_complete.
        iIntros "[HA [HD HC]]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HD". iApply "HD". trivial.
        iRight. iExists v1.
        iSplitL "HA". iExists (Csyntax.typeof l). iApply "HA".
        iPureIntro. reflexivity.
      + iApply ret_spec_complete.
        iIntros "[HA HC]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HA". iApply "HA". trivial.
        iLeft. iPureIntro. split; reflexivity.
      + iApply ret_spec_complete.
        iIntros "[HA [HD HC]]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HD". iApply "HD". trivial. iRight.
        iExists v1. iSplitL "HA". iExists (Csyntax.typeof l). iApply "HA".
        iPureIntro. simpl. admit.
    - frameR. apply H0.
    - frameR. apply transl_valof_meets_spec.
    - destruct dst; tac2.
      + iApply ret_spec_complete.
        iIntros "[HA [HD [HE HC]]]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HE". iApply "HE". trivial.
        iSplitL "HD". iApply "HD".
        iRight. iExists v2.
        iSplitL "HA". iExists (Csyntax.typeof l). iApply "HA".
        iPureIntro. reflexivity.
      + iApply ret_spec_complete.
        iIntros "[HA [HD HC]]" (le) "HB". iSplit; auto. repeat iExists _.
         iSplitL "HC". iApply "HC". trivial.
         iSplitL "HD". iApply "HD". trivial.
         iFrame. iLeft.
         iPureIntro. split; reflexivity.
      + iApply ret_spec_complete.
        iIntros "[HA [HD [HE HC]]]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HE". iApply "HE". trivial.
        iSplitL "HD". iApply "HD".
        iRight. iExists v2.
        iSplitL "HA". iExists (Csyntax.typeof l). iApply "HA".
        iPureIntro. simpl. admit.
    - destruct dst; tac2.
      + iApply ret_spec_complete.
        iIntros "[HA HC]" (le) "HB". iSplit; auto.
        iRight. iExists v. iExists v0.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HA". iExists (Csyntax.typeof l). iApply "HA".
        iPureIntro. reflexivity.
      + frameR. apply b.
      + iApply ret_spec_complete.
        iIntros "[HA HC]" (le)  "HB". iSplit; auto.
        iLeft. iExists v. iExists v0.
        iSplitL "HC". iApply "HC". trivial.
        iFrame.
        iPureIntro. reflexivity.
      + iApply ret_spec_complete.
        iIntros "[HA HC]" (le) "HB". iSplit; auto.
        iRight.
        iExists v. iExists v0.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HA". iExists (Csyntax.typeof l). iApply "HA".
        iPureIntro. simpl. admit.
    - frameR. apply H0.
    - iApply ret_spec_complete.
      iIntros "[HA HC]" (le) "HB". iSplit; auto. repeat iExists _.
      iSplitL "HC". iApply "HC". trivial.
      iSplitL "HA". iIntros "HC". iSimpl. rewrite <- surjective_pairing.
      iApply "HA". iApply "HC".
      iFrame. iPureIntro. reflexivity.
    - destruct dst; tac2; fold tr_exprlist; fold tr_expr.
      + iApply ret_spec_complete.
        iIntros "[HA [HD HC]]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HC". iApply "HC". trivial.
        iFrame.
        iSplitL "HD". iApply "HD".
        iSplitL. iExists ty. iApply "HA".
        iPureIntro. reflexivity.
      + iApply ret_spec_complete.
        iIntros "[HA HD]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HD". iApply "HD". trivial.
        iSplitL "HA". iApply "HA". trivial.
      + iApply ret_spec_complete.
        iIntros "[HA [HD HC]]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HC". iApply "HC". trivial.
        iSplitL "HD". iApply "HD".
        iSplitL "HA". iExists ty. iApply "HA".
        iFrame.
        iPureIntro. simpl. admit.
    - fold tr_exprlist. destruct dst; tac2.
      + iApply ret_spec_complete.
        iIntros "[HA HC]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HC". iApply "HC".
        iSplitL "HA". iExists ty. iApply "HA".
        iFrame.
        iPureIntro. reflexivity.
      + iApply ret_spec_complete.
        iIntros "HA" (le) "HB". iSplit; auto.
      + iApply ret_spec_complete.
        iIntros "[HA HC]" (le) "HB". iSplit; auto. repeat iExists _.
        iSplitL "HC". iApply "HC".
        iSplitL "HA". iExists ty. iApply "HA".
        iFrame.
        iPureIntro. simpl. admit.
    - iApply ret_spec_bis. eauto.
    - rewrite /tr_exprlist; fold tr_exprlist; fold tr_expr; tac2.
      iApply ret_spec_complete.
      iIntros "[HA HB]" (le). iSplit; auto. repeat iExists _.
      iSplitL "HB". iApply "HB". trivial.
      iSplitL "HA". iApply "HA".
      iPureIntro. reflexivity.
  Admitted.

  Section TR_TOP.

    Variable ge: genv.
    Variable e: Clight.env.
    Variable le: temp_env.
    Variable m: mem.

    Definition tr_top_base dst r sl a := tr_expr le dst r (sl,a).

    Definition tr_top_val_val (dst : destination) expr (sl : list statement) a : Prop :=
      match sl with
      | nil => exists v ty, typeof a = ty /\ eval_expr ge e le m a v /\ dst = For_val
                  /\ expr = Csyntax.Eval v ty
      | _ => False
    end.

    Definition tr_top dst expr sl a := tr_top_base dst expr sl a ∨ \⌜tr_top_val_val dst expr sl a⌝.

  End TR_TOP.

(** ** Translation of statements *)

  Lemma transl_expr_meets_spec:
    forall r dst,
      {{ emp }} transl_expr dst r {{ res, RET res;  dest_below dst -∗ ∀ ge e le m, tr_top  ge e le m dst r res.1 res.2 }}.
  Proof.
    intros. exploit (proj1 transl_meets_spec); eauto. intro. iIntros (?) "_ HA".
    iApply H; eauto. iIntros (res) "HB". iApply "HA". iIntros. rewrite /tr_top.
    iLeft. rewrite /tr_top_base.
    rewrite (surjective_pairing res). iApply "HB". iFrame.
  Qed.

  Lemma test : forall (P : iProp) Q, (P -∗ ⌜Q⌝) -> (exists tmps, P () tmps -> Q).
  Proof.
    MonPred.unseal. intros. destruct H. repeat red in monPred_in_entails.
    pose (monPred_in_entails () heap_empty).
    destruct e with (a := ()).
    + MonPred.unseal. split; auto.
    + exists heap_empty; exists heap_empty. repeat split; eauto.
    + exists ∅. intro. inversion_star H h P. destruct P2. red in H1.
      destruct (H1 ∅).
      * exists ∅. exists ∅. repeat split; eauto. inversion H2. subst. rewrite heap_union_empty_r in P0.
        subst. apply P1.
      * repeat destruct H3. apply H3.
  Qed.

  Lemma test2 : forall (P : iProp) (Q : Prop), (forall tmps, P () tmps -> Q) -> (P -∗ ⌜Q⌝).
  Proof.
    intros. split. red. red. MonPred.unseal. intros. repeat red.
    intros. exists emp. red. exists ∅. exists ∅. repeat split; auto.
    - repeat red. intros. inversion_star H h P. inversion P1. inversion H4. subst.
      exists ∅. exists h0.
      repeat split; auto.
      + apply (H h0). destruct a. apply P2.
    - inversion H0. inversion H3. rewrite heap_union_empty_l. reflexivity.
  Qed.

  Inductive tr_expression: Csyntax.expr -> statement -> expr -> Prop :=
  | tr_expression_intro: forall r sl a tmps,
      (forall ge e le m, tr_top ge e le m For_val r sl a () tmps) ->
      tr_expression r (makeseq sl) a.

  Import adequacy.
  Lemma transl_expression_meets_spec: forall r,
      {{ emp }} transl_expression r {{ res, RET res; ⌜ tr_expression r res.1 res.2 ⌝ }}.
  Proof.
    intro. unfold transl_expression. epose transl_meets_spec. destruct a. tac2.
    - apply (H r For_val).
    - iApply ret_spec_complete. iStopProof. apply test2. intros.
      apply (tr_expression_intro _ _ _ tmps). intros. apply soundness2. apply soundness3 in H1.
      iIntros "HA". iDestruct (H1 with "HA") as "HA". unfold tr_top.
      iLeft. unfold tr_top_base. simpl. rewrite <- surjective_pairing. iApply "HA".
      trivial.
  Qed.

  Inductive tr_expr_stmt: Csyntax.expr -> statement -> Prop :=
  | tr_expr_stmt_intro: forall r sl a tmps,
      (forall ge e le m, tr_top ge e le m For_effects r sl a () tmps) ->
      tr_expr_stmt r (makeseq sl).

  Lemma transl_expr_stmt_meets_spec: forall r,
      {{ emp }} transl_expr_stmt r {{ res, RET res; ⌜ tr_expr_stmt r res ⌝}}.
  Proof.
    intro. unfold transl_expr_stmt. epose transl_meets_spec. destruct a; tac2.
    - apply H.
    - iApply ret_spec_complete. iStopProof. apply test2. intros.
      apply (tr_expr_stmt_intro _ _ v.2 tmps). intros.
      apply soundness3 in H1. apply soundness2.
      iIntros "HA". iDestruct (H1 with "HA") as "HA". unfold tr_top. iLeft.
      unfold tr_top_base. simpl. rewrite <- surjective_pairing. iApply "HA".
      trivial.
  Qed.

  Inductive tr_if: Csyntax.expr -> statement -> statement -> statement -> Prop :=
  | tr_if_intro: forall r s1 s2 sl a tmps,
      (forall ge e le m, tr_top ge e le m For_val r sl a () tmps) ->
      tr_if r s1 s2 (makeseq (sl ++ makeif a s1 s2 :: nil)).

  Lemma transl_if_meets_spec: forall r s1 s2,
      {{ emp }} transl_if r s1 s2 {{ res, RET res; ⌜ tr_if r s1 s2 res ⌝ }}.
  Proof.
    intros. epose transl_meets_spec. destruct a; unfold transl_if; tac2.
    - apply H.
    - iApply ret_spec_complete. iStopProof. apply test2. intros.
      apply (tr_if_intro _ _ _ _ _ tmps). intros.
      apply soundness3 in H1. apply soundness2.
      iIntros "HA". iDestruct (H1 with "HA") as "HA". unfold tr_top. iLeft.
      unfold tr_top_base. simpl. rewrite <- surjective_pairing. iApply "HA".
      trivial.
  Qed.

  Inductive tr_stmt: Csyntax.statement -> statement -> Prop :=
  | tr_skip:
      tr_stmt Csyntax.Sskip Sskip
  | tr_do: forall r s,
      tr_expr_stmt r s ->
      tr_stmt (Csyntax.Sdo r) s
  | tr_seq: forall s1 s2 ts1 ts2,
      tr_stmt s1 ts1 -> tr_stmt s2 ts2 ->
      tr_stmt (Csyntax.Ssequence s1 s2) (Ssequence ts1 ts2)
  | tr_ifthenelse_empty: forall r s' a,
      tr_expression r s' a ->
      tr_stmt (Csyntax.Sifthenelse r Csyntax.Sskip Csyntax.Sskip) (Ssequence s' Sskip)
  | tr_ifthenelse: forall r s1 s2 s' a ts1 ts2,
      tr_expression r s' a ->
      tr_stmt s1 ts1 -> tr_stmt s2 ts2 ->
      tr_stmt (Csyntax.Sifthenelse r s1 s2) (Ssequence s' (Sifthenelse a ts1 ts2))
  | tr_while: forall r s1 s' ts1,
      tr_if r Sskip Sbreak s' ->
      tr_stmt s1 ts1 ->
      tr_stmt (Csyntax.Swhile r s1)
              (Sloop (Ssequence s' ts1) Sskip)
  | tr_dowhile: forall r s1 s' ts1,
      tr_if r Sskip Sbreak s' ->
      tr_stmt s1 ts1 ->
      tr_stmt (Csyntax.Sdowhile r s1)
              (Sloop ts1 s')
  | tr_for_1: forall r s3 s4 s' ts3 ts4,
      tr_if r Sskip Sbreak s' ->
      tr_stmt s3 ts3 ->
      tr_stmt s4 ts4 ->
      tr_stmt (Csyntax.Sfor Csyntax.Sskip r s3 s4)
              (Sloop (Ssequence s' ts4) ts3)
  | tr_for_2: forall s1 r s3 s4 s' ts1 ts3 ts4,
      tr_if r Sskip Sbreak s' ->
      s1 <> Csyntax.Sskip ->
      tr_stmt s1 ts1 ->
      tr_stmt s3 ts3 ->
      tr_stmt s4 ts4 ->
      tr_stmt (Csyntax.Sfor s1 r s3 s4)
              (Ssequence ts1 (Sloop (Ssequence s' ts4) ts3))
  | tr_break:
      tr_stmt Csyntax.Sbreak Sbreak
  | tr_continue:
      tr_stmt Csyntax.Scontinue Scontinue
  | tr_return_none:
      tr_stmt (Csyntax.Sreturn None) (Sreturn None)
  | tr_return_some: forall r s' a,
      tr_expression r s' a ->
      tr_stmt (Csyntax.Sreturn (Some r)) (Ssequence s' (Sreturn (Some a)))
  | tr_switch: forall r ls s' a tls,
      tr_expression r s' a ->
      tr_lblstmts ls tls ->
      tr_stmt (Csyntax.Sswitch r ls) (Ssequence s' (Sswitch a tls))
  | tr_label: forall lbl s ts,
      tr_stmt s ts ->
      tr_stmt (Csyntax.Slabel lbl s) (Slabel lbl ts)
  | tr_goto: forall lbl,
      tr_stmt (Csyntax.Sgoto lbl) (Sgoto lbl)

with tr_lblstmts: Csyntax.labeled_statements -> labeled_statements -> Prop :=
  | tr_ls_nil:
      tr_lblstmts Csyntax.LSnil LSnil
  | tr_ls_cons: forall c s ls ts tls,
      tr_stmt s ts ->
      tr_lblstmts ls tls ->
      tr_lblstmts (Csyntax.LScons c s ls) (LScons c ts tls).

  Lemma transl_stmt_meets_spec : forall s,
      {{ emp }} transl_stmt s {{ res, RET res; ⌜ tr_stmt s res ⌝}}
  with transl_lblstmt_meets_spec:
         forall s,
           {{ emp }} transl_lblstmt s {{ res, RET res; ⌜ tr_lblstmts s res ⌝ }}.
  Proof.
    pose transl_expression_meets_spec. pose transl_if_meets_spec. pose transl_expr_stmt_meets_spec.
    clear transl_stmt_meets_spec.
    intro. induction s; rewrite /transl_stmt; fold transl_stmt; tac2.
    - iApply ret_spec_bis. iPureIntro. constructor.
    - apply (post_weaker _ _ _ _ (b1 e)). iIntros. iPureIntro. apply (tr_do _ _ a).
    - iApply ret_spec_complete. iIntros "[% %]".
      iPureIntro. apply (tr_seq _ _  _ _ H0 H).
    - tac2. frameR. apply transl_expression_meets_spec.
      destruct (is_Sskip s1); destruct (is_Sskip s2) eqn:?; iApply ret_spec_complete;
        iIntros "[% [% %]]"; iPureIntro; subst.
      1 : apply (tr_ifthenelse_empty _ _ _ H).
      all : apply (tr_ifthenelse _ _ _ _ _ _ _ H H1 H0).
    - iApply ret_spec_complete.
      iIntros "[% %]". iPureIntro. apply (tr_while _ _ _ _ H0 H).
    - iApply ret_spec_complete.
      iIntros "[% %]". iPureIntro. apply (tr_dowhile _ _ _ _ H0 H).
    - frameR. apply transl_if_meets_spec.
    - destruct (is_Sskip); iApply ret_spec_complete;
        iIntros "[% [% [% %]]]"; iPureIntro; subst.
      + apply (tr_for_1 _ _ _ _ _ _ H1 H0 H).
      + apply (tr_for_2 _ _ _ _ _ _ _ _ H1 n H2 H0 H).
    - iApply ret_spec_bis. iPureIntro. constructor.
    - iApply ret_spec_bis. iPureIntro. constructor.
    - destruct o; tac2.
      + iApply ret_spec_complete. iIntros. iPureIntro. apply (tr_return_some _ _ _ a).
      + iApply ret_spec_bis. iPureIntro. constructor.
    - fold transl_lblstmt. frameR. apply transl_lblstmt_meets_spec.
    - iApply ret_spec_complete. iIntros "[% %]". iPureIntro. constructor; auto.
    - iApply ret_spec_complete. iIntros "%". iPureIntro. constructor; auto.
    - iApply ret_spec_bis. iPureIntro. constructor.
    - induction s; rewrite /transl_lblstmt; fold transl_lblstmt; fold transl_stmt; tac2.
      + iApply ret_spec_bis. iPureIntro. constructor.
      + iApply ret_spec_complete. iIntros "[% %]". iPureIntro. constructor; auto.
  Qed.

  (** Relational presentation for the transformation of functions, fundefs, and variables. *)

  Inductive tr_function: Csyntax.function -> Clight.function -> Prop :=
  | tr_function_intro: forall f tf,
      tr_stmt f.(Csyntax.fn_body) tf.(fn_body) ->
      fn_return tf = Csyntax.fn_return f ->
      fn_callconv tf = Csyntax.fn_callconv f ->
      fn_params tf = Csyntax.fn_params f ->
      fn_vars tf = Csyntax.fn_vars f ->
      tr_function f tf.

  Inductive tr_fundef: Csyntax.fundef -> Clight.fundef -> Prop :=
  | tr_internal: forall f tf,
      tr_function f tf ->
      tr_fundef (Internal f) (Internal tf)
  | tr_external: forall ef targs tres cconv,
      tr_fundef (External ef targs tres cconv) (External ef targs tres cconv).

  Lemma transl_function_spec:
    forall f tf,
      transl_function f = OK tf ->
      tr_function f tf.
  Proof.
    unfold transl_function; intros.
    destruct (run (transl_stmt (Csyntax.fn_body f)) ∅) eqn:?. rewrite Heqe in H. inversion H.
    destruct p.
    rewrite Heqe in H. simpl in *. inversion H.
    apply tr_function_intro; auto; simpl.
    eapply (adequacy_pure (transl_stmt (Csyntax.fn_body f)) _ ∅ s0 s emp).
    2: apply Heqe.
    iIntros "HA". iSplitL; eauto.
    iApply (transl_stmt_meets_spec (Csyntax.fn_body f)).
  Qed.

  Lemma transl_fundef_spec:
    forall fd tfd,
      transl_fundef fd = OK tfd ->
      tr_fundef fd tfd.
  Proof.
    unfold transl_fundef; intros.
    destruct fd; Errors.monadInv H.
    + constructor. eapply transl_function_spec; eauto.
    + constructor.
  Qed.

End SPEC.


From ExtLib Require Import
     Data.List
     Structures.Monad.

From Paco Require Import paco.

From ITree Require Import
     ITree
     ITreeFacts
     Events.MapDefault
     Events.State
     Events.StateFacts.

From ITree.Extra Require Import
     Dijkstra.DijkstraMonad
     Dijkstra.PureITreeBasics
     Dijkstra.DelaySpecMonad
     Dijkstra.StateSpecT.

Import Monads.
Import MonadNotation.
#[local] Open Scope monad_scope.
#[local] Open Scope delayspec_scope.

(* Defines a specification monad for the state transform of the Delay monad. Also includes encodings for pre post condition specifications. *)

Section StateDelaySpec.

  Context (St : Type).

  Definition StateDelaySpec := StateSpecT St DelaySpec.

  Definition StateDelaySpecOrder := StateSpecTOrder St DelaySpec.

  Definition StateDelaySpecOrderedLaws := StateSpecTOrderedLaws St DelaySpec.

  Definition StateDelaySpecEq := StateSpecTEq St DelaySpec.

  Definition StateDelaySpecMonadLaws := StateSpecTMonadLaws St DelaySpec.

  Definition StateDelay := StateSpecT St Delay.

  Definition StateDelayObs := EffectObsStateT St DelaySpec Delay.

  Definition StateDelayMonadMorph := MonadMorphimStateT St DelaySpec Delay.

  Definition PrePost A : Type := (Delay (St * A) -> Prop ) * (St -> Prop).

  Definition PrePostRef {A : Type} (m : StateDelay A) (pp : PrePost A) : Prop :=
    let '(post,pre) := pp in
    forall s, pre s -> post (m s).

  Program Definition encode {A : Type} (pp : PrePost A) : StateDelaySpec A :=
    let '(post,pre) := pp in
    fun s p => pre s /\ (forall r, post r -> p r).

  Definition verify_cond {A : Type} := DijkstraProp StateDelay StateDelaySpec StateDelayObs A.

  Lemma encode_correct : forall (A : Type) (pre : St -> Prop) (post : Delay (St * A) -> Prop)
                                (m : StateDelay A),
      resp_eutt post -> (PrePostRef m (post,pre) <-> verify_cond (encode (post,pre)) m).
  Proof.
    intros. cbn. unfold verify_cond, DijkstraProp.
    split; intros.
    - repeat red. simpl. intros. destruct p as [p Hp]. simpl in H1. destruct H1 as [Hpre Himp].
      auto.
    - repeat red in H0. simpl in H0.
      set (exist _ post H) as p. enough ((m s) ∈ p); auto.
      apply H0. auto.
  Qed.

  Definition PrePostPair A : Type := PrePost A * PrePost A.

  Definition PrePostPairRef {A : Type} (pppp : PrePostPair A) (m : StateDelay A) :=
    let '((post0, pre0), (post1, pre1)) := pppp in
    forall s, (pre0 s -> post0 (m s)) /\ (pre1 s -> post1 (m s)) .

  Program Definition encode_pair {A : Type} (pppp : PrePostPair A) : StateDelaySpec A:=
    let '((post0, pre0), (post1, pre1)) := pppp in
    fun s (p : DelaySpecInput (St * A)) =>
      (pre0 s /\ (forall r, post0 r -> p r)) \/ (pre1 s /\ forall r, post1 r -> p r).
  Next Obligation.
  destruct H0 as [H0 | H1].
  - destruct H0 as [Hp Hr]. left. auto.
  - destruct H1 as [Hp Hr]. right. auto.
  Qed.

  Lemma encode_pair_correct : forall (A : Type) (pre0 pre1 : St -> Prop)
                                          (post0 post1 : Delay (St * A) -> Prop ) (m : StateDelay A),
      let pp : PrePostPair A := ((post0,pre0),(post1,pre1)) in
      resp_eutt post0 -> resp_eutt post1 ->
      (PrePostPairRef pp m <-> verify_cond (encode_pair pp) m).
  Proof.
    intros. cbn. unfold verify_cond, DijkstraProp. split; intros.
    - repeat red. simpl. intros. destruct p as [p Hrp].
      specialize (H1 s). destruct H1.
      destruct H2 as [ [Hs Hp] | [Hs Hp]  ]; simpl in *; auto.
    - repeat red in H1. simpl in *.
      split; intros.
      + set (exist _ post0 H) as p. enough ((m s) ∈ p ); auto.
        apply H1. left. split; auto.
      + set (exist _ post1 H0) as p. enough ((m s) ∈ p ); auto.
        apply H1. right. split; auto.
  Qed.

  Definition PrePostList A : Type := list (PrePost A).

  Definition PrePostListRef {A : Type} (ppl : PrePostList A) (m : StateDelay A) :=
    forall s, List.Forall (fun pp : PrePost A=> let (post,pre) := pp in pre s -> post (m s) ) ppl.

  Program Definition encode_list {A : Type} (ppl : PrePostList A) : StateDelaySpec A :=
    fun s (p : DelaySpecInput (St * A) ) =>
      List.Exists (fun pp : PrePost A => let (post,pre) := pp in pre s /\ forall r, post r -> p r) ppl.
  Next Obligation.
    induction H0; eauto.
    destruct x as [post pre]. destruct H0 as [Hs Hr]. left. auto.
  Qed.

  Lemma enocde_list_correct : forall (A : Type) (ppl : PrePostList A) (m : StateDelay A),
      List.Forall (fun pp => resp_eutt (fst pp) ) ppl->
      (PrePostListRef ppl m <-> verify_cond (encode_list ppl) m).
  Proof.
    intros. unfold verify_cond, DijkstraProp. split; intros.
    - repeat red. intros. destruct p as [p Hp]. red in H0.
      specialize (H0 s) as Hrefine. unfold encode_list in H1. simpl in *.
      induction ppl.
      + inversion H1.
      + destruct a as [post pre].
        inversion H1; subst.
        * destruct H3. auto.
          assert ((pre s -> post (m s)) ); auto.
          intros. inversion Hrefine; subst; auto.
        * apply IHppl; auto.
          -- inversion H; auto.
          -- intros. specialize (H0 s0). inversion H0. auto.
          -- specialize (H0 s). inversion H0. auto.
    - unfold encode_list in H0. simpl in *. repeat red. repeat red in H0. simpl in *. intros.
      induction ppl; auto.
      destruct a as [post pre]. specialize (H0 s) as Henc.
      assert (Heutt : resp_eutt post).
      { inversion H. auto. }
      set (exist _ post Heutt) as p. specialize (Henc p) as Hencp.
      constructor; intros.
      + enough ((m s) ∈ p ); auto. apply Hencp.
        left. split; auto.
      + apply IHppl; auto.
        * inversion H. auto.
        * clear IHppl. intros. apply H0. eauto.
  Qed.

  Definition DynPrePost A : Type := (St -> Prop) * (St -> Delay (St * A) -> Prop).

  Definition DynPrePostRef {A : Type} (pp : DynPrePost A) (m : StateDelay A) :=
    let (pre,post) := pp in
    forall s, pre s -> post s (m s).

  Program Definition encode_dyn {A : Type} (pp : DynPrePost A) : StateDelaySpec A :=
    let (pre,post) := pp in
    fun s p => pre s /\ forall r, post s r -> p r.

  Lemma encode_dyn_correct : forall (A : Type) (pre : St -> Prop) (post : St -> Delay (St * A) -> Prop ) (m : StateDelay A),
      (forall s, resp_eutt (post s)) -> (DynPrePostRef (pre,post) m <-> verify_cond (encode_dyn (pre,post) ) m).
    Proof.
      intros. unfold verify_cond, DijkstraProp. split; intros.
      - repeat red. red in H0. intros. destruct p as [p Hp]. simpl in *.
        destruct H1 as [Hs Hr]. auto.
      - repeat red in H0. red. intros.
        set (exist _ (post s) (H s) ) as p. specialize (H0 s p).
        unfold p in H0. simpl in *. auto.
    Qed.

  Definition DynPrePostListRef {A : Type} (ppl : list (DynPrePost A)) (m : StateDelay A) : Prop :=
    Forall (fun pp => DynPrePostRef pp m) ppl.

  Program Definition encode_list_dyn {A : Type} (ppl : list (DynPrePost A)) : StateDelaySpec A :=
    fun s p => List.Exists (fun pp : DynPrePost A => let (pre,post) := pp in pre s /\ forall r, post s r -> p r ) ppl.
  Next Obligation.
    induction H0; eauto. left. destruct x as [pre post]. destruct H0 as [Hs Hr].
    split; auto.
  Qed.

  Lemma enocde_list_dyn_correct : forall (A : Type) (ppl : list (DynPrePost A) ) (m : StateDelay A),
      List.Forall (fun pp => forall s, resp_eutt (snd pp s) ) ppl->
      (DynPrePostListRef ppl m <-> verify_cond (encode_list_dyn ppl) m).
  Proof.
    intros. unfold verify_cond, DijkstraProp. split; intros.
    - repeat red. intros. destruct p as [p Hp]. simpl in H1. red in H0. rename H0 into Hrefine.
      unfold DynPrePostRef in Hrefine.
      induction ppl.
      + inversion H1.
      + destruct a as [pre post].
        inversion H1; subst.
        * destruct H2.
          assert ((pre s -> post s (m s)) ); auto.
          intros. inversion Hrefine; subst; auto.
        * apply IHppl; auto.
          -- inversion H; auto.
          -- intros. inversion Hrefine; auto.
    - unfold encode_list in H0. simpl in *. repeat red. repeat red in H0. simpl in *. intros.
      induction ppl; auto.
      destruct a as [pre post].
      assert (Heutt : forall s, resp_eutt (post s)).
      { inversion H. auto. }
      constructor; intros.
      + red. intros. set (exist _ (post s) (Heutt s)) as p.
        specialize (H0 s p). enough ((m s) ∈ p); auto. apply H0.
        left. split; auto.
      + apply IHppl; auto.
        * inversion H. auto.
        * clear IHppl. intros.
          specialize (H0 s p). apply H0. eauto.
  Qed.

  Lemma combine_prepost_aux : forall (A B : Type) (pre1 pre2 : St -> Prop)
                (post1 : Delay (St * A) -> Prop ) (post2 : Delay (St * B) -> Prop)
    (m : StateDelay A) (f : A -> StateDelay B),
    verify_cond (encode (post1,pre1) ) m ->
    (forall (a : A) (s : St), (* this condition is not exactly what i want*)
        post1 (Ret (s,a) ) -> post2 (f a s) ) ->
    (post1 ITree.spin -> post2 ITree.spin) ->
    resp_eutt post1 ->
    verify_cond (encode (post2, pre1) ) (bind m f).
  Proof.
    intros. repeat red in H. repeat red. intros.
    destruct p as [p Hp]. simpl in *.
    destruct H3.
    destruct (eutt_reta_or_div (m s)); basic_solve.
    - destruct a as [s' a].
      cbn in H5. rewrite <- H5, bind_ret_l; cbn. apply H4, H0. rewrite H5.
      apply (H s (exist _ post1 H2)); auto.
    - apply div_spin_eutt in H5.
      rewrite H5, <- spin_bind. apply H4, H1. rewrite <- H5. apply (H s (exist _ post1 H2)); auto.
  Qed.

  Lemma combine_prepost : forall (A B : Type) (pre1 pre2 : St -> Prop)
                (post1 : Delay (St * A) -> Prop ) (post2 : Delay (St * B) -> Prop)
    (m : StateDelay A) (f : A -> StateDelay B),
    verify_cond (encode (post1,pre1) ) m ->
    (forall a s, post1 (Ret (s,a)) -> pre2 s)  ->
    (forall a, verify_cond (encode (post2,pre2) ) (f a)  ) ->
    (post1 ITree.spin -> post2 ITree.spin) ->
    resp_eutt post1 ->
    resp_eutt post2 ->
    verify_cond (encode (post2, pre1) ) (bind m f).
  Proof.
    intros.
    eapply combine_prepost_aux; eauto.
    intros.
    specialize (H1 a) as Hpp2. repeat red in Hpp2.
    specialize (Hpp2 s (exist _ post2 H4) ). simpl in *.
    apply Hpp2. split; eauto.
  Qed.

End StateDelaySpec.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import FulfillStep.

Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import SimThread.
Require Import iCompatibility.
Require Import SplitAcqCommon.

Require Import ITreeLang.

Set Implicit Arguments.

Inductive split_acquire: forall R (i1: MemE.t R) (i2: MemE.t R), Prop :=
| split_acquire_load
    l:
    split_acquire (MemE.read l Ordering.acqrel) (MemE.read l Ordering.relaxed)
| split_acquire_update
    l rmw ow
    (OW: Ordering.le ow Ordering.strong_relaxed):
    split_acquire (MemE.update l rmw Ordering.acqrel ow) (MemE.update l rmw Ordering.relaxed ow)
.

Inductive sim_acquired: forall R
                          (st_src:(Language.state (lang R))) (lc_src:Local.t) (sc1_src:TimeMap.t) (mem1_src:Memory.t)
                          (st_tgt:(Language.state (lang R))) (lc_tgt:Local.t) (sc1_tgt:TimeMap.t) (mem1_tgt:Memory.t), Prop :=
| sim_acquired_intro
    R
    lc1_src sc1_src mem1_src
    lc1_tgt sc1_tgt mem1_tgt
    (LOCAL: sim_local SimPromises.bot lc1_src (local_acquired lc1_tgt))
    (SC: TimeMap.le sc1_src sc1_tgt)
    (MEMORY: sim_memory mem1_src mem1_tgt)
    (WF_SRC: Local.wf lc1_src mem1_src)
    (WF_TGT: Local.wf lc1_tgt mem1_tgt)
    (SC_SRC: Memory.closed_timemap sc1_src mem1_src)
    (SC_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
    (MEM_SRC: Memory.closed mem1_src)
    (MEM_TGT: Memory.closed mem1_tgt)
    (r: R):
    sim_acquired
      (Ret r) lc1_src sc1_src mem1_src
      (Vis (MemE.fence Ordering.acqrel Ordering.plain) (fun _ => Ret r)) lc1_tgt sc1_tgt mem1_tgt
.

Lemma sim_local_sim_acquired
      R (r: R)
      lc_src sc_src mem_src
      lc_tgt sc_tgt mem_tgt
      (SIM: sim_local SimPromises.bot lc_src lc_tgt)
      (SC1: TimeMap.le sc_src sc_tgt)
      (MEM1: sim_memory mem_src mem_tgt)
      (WF_SRC: Local.wf lc_src mem_src)
      (WF_TGT: Local.wf lc_tgt mem_tgt)
      (SC_SRC: Memory.closed_timemap sc_src mem_src)
      (SC_TGT: Memory.closed_timemap sc_tgt mem_tgt)
      (MEM_SRC: Memory.closed mem_src)
      (MEM_TGT: Memory.closed mem_tgt):
  sim_acquired (Ret r) lc_src sc_src mem_src
               (Vis (MemE.fence Ordering.acqrel Ordering.plain) (fun _ => Ret r)) lc_tgt sc_tgt mem_tgt.
Proof.
  econs; eauto.
  inv SIM. econs; ss. etrans; eauto.
  apply TViewFacts.read_fence_tview_incr. apply WF_TGT.
Qed.

Lemma sim_acquired_mon
      R
      st_src lc_src sc1_src mem1_src
      st_tgt lc_tgt sc1_tgt mem1_tgt
      sc2_src mem2_src
      sc2_tgt mem2_tgt
      (SIM1: sim_acquired st_src lc_src sc1_src mem1_src
                          st_tgt lc_tgt sc1_tgt mem1_tgt)
      (SC_FUTURE_SRC: TimeMap.le sc1_src sc2_src)
      (SC_FUTURE_TGT: TimeMap.le sc1_tgt sc2_tgt)
      (MEM_FUTURE_SRC: Memory.future_weak mem1_src mem2_src)
      (MEM_FUTURE_TGT: Memory.future_weak mem1_tgt mem2_tgt)
      (SC1: TimeMap.le sc2_src sc2_tgt)
      (MEM1: sim_memory mem2_src mem2_tgt)
      (WF_SRC: Local.wf lc_src mem2_src)
      (WF_TGT: Local.wf lc_tgt mem2_tgt)
      (SC_SRC: Memory.closed_timemap sc2_src mem2_src)
      (SC_TGT: Memory.closed_timemap sc2_tgt mem2_tgt)
      (MEM_SRC: Memory.closed mem2_src)
      (MEM_TGT: Memory.closed mem2_tgt):
  @sim_acquired R
                st_src lc_src sc2_src mem2_src
                st_tgt lc_tgt sc2_tgt mem2_tgt.
Proof.
  destruct SIM1. econs; eauto.
Qed.

Lemma sim_acquired_step R
      st1_src lc1_src sc1_src mem1_src
      st1_tgt lc1_tgt sc1_tgt mem1_tgt
      (SIM: sim_acquired st1_src lc1_src sc1_src mem1_src
                         st1_tgt lc1_tgt sc1_tgt mem1_tgt):
  @_sim_thread_step (lang R) (lang R)
                    ((@sim_thread (lang R) (lang R) (sim_terminal eq)) \8/ @sim_acquired R)
                    st1_src lc1_src sc1_src mem1_src
                    st1_tgt lc1_tgt sc1_tgt mem1_tgt.
Proof.
  destruct SIM. ii.
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
    try (inv STATE; inv INSTR; inv SPLIT); ss.
  - (* promise *)
    right.
    exploit Local.promise_step_future; eauto. i. des.
    exploit sim_local_promise_acquired; try exact LOCAL; eauto. i. des.
    exploit Local.promise_step_future; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs. econs; eauto.
    + eauto.
    + right. econs; eauto.
  - (* fence *)
    right.
    exploit Local.fence_step_future; eauto. i. des.
    dependent destruction STATE. inv LOCAL1. ss.
    esplits; (try by econs 1); eauto; ss.
    left. eapply paco11_mon; [apply sim_itree_ret|]; ss. econs; ss.
    + rewrite TViewFacts.write_fence_tview_strong_relaxed; ss. apply LOCAL.
    + apply LOCAL.
Qed.

Lemma sim_acquired_sim_thread R:
  @sim_acquired R <8= @sim_thread (lang R) (lang R) (sim_terminal eq).
Proof.
  pcofix CIH. i. pfold. ii. ss. splits; ss; ii.
  - inv TERMINAL_TGT. inv PR; ss.
  - right. esplits; eauto.
    inv PR. eapply sim_local_memory_bot; eauto.
  - exploit sim_acquired_mon; eauto. i.
    exploit sim_acquired_step; eauto. i. des; eauto.
    + right. esplits; eauto.
      left. eapply paco11_mon; eauto. ss.
    + right. esplits; eauto.
Qed.

Lemma split_acquire_sim_itree R
      (i_src i_tgt: MemE.t R)
      (SPLIT: split_acquire i_src i_tgt):
  sim_itree eq
            (ITree.trigger i_src)
            (r <- ITree.trigger i_tgt;; ITree.trigger (MemE.fence Ordering.acqrel Ordering.plain);; Ret r).
Proof.
  replace (ITree.trigger i_src) with (Vis i_src (fun r => Ret r)).
  2: { unfold ITree.trigger. grind. }
  replace (r <- ITree.trigger i_tgt;; ITree.trigger (MemE.fence Ordering.acqrel Ordering.plain);; Ret r) with
      (Vis i_tgt (fun r => Vis (MemE.fence Ordering.acqrel Ordering.plain) (fun _ => Ret r))).
  2: { unfold ITree.trigger. grind. repeat f_equal. extensionality r. grind.
       repeat f_equal. extensionality u. grind. }
  pcofix CIH. ii. subst. pfold. ii. splits; ii.
  { inv TERMINAL_TGT. eapply f_equal with (f:=observe) in H; ss. }
  { right. esplits; eauto.
    inv LOCAL. apply SimPromises.sem_bot_inv in PROMISES; auto. rewrite PROMISES. auto.
  }
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0]; ss;
    try (dependent destruction STATE; inv SPLIT); ss.
  - (* promise *)
    right.
    exploit sim_local_promise; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    econs 2. econs 1; eauto. econs; eauto. eauto.
  - dependent destruction H.
    (* load *)
    right.
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read_acquired; eauto. i. des.
    exploit Local.read_step_future; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs 2. econs; cycle 1.
      * econs 2. eauto.
      * econs. econs.
    + auto.
    + left. eapply paco11_mon; [apply sim_acquired_sim_thread|]; ss.
  - dependent destruction H.
    (* update-load *)
    right.
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read_acquired; eauto. i. des.
    exploit Local.read_step_future; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs 2. econs; cycle 1.
      * econs 2. eauto.
      * econs; eauto.
    + auto.
    + left. eapply paco11_mon; [apply sim_acquired_sim_thread|]; ss.
  - dependent destruction H.
    (* update *)
    right.
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read_acquired; eauto. i. des.
    exploit Local.read_step_future; eauto. i. des.
    exploit Local.write_step_future; eauto. i. des.
    hexploit sim_local_write_acquired; try exact LOCAL2; try exact SC; eauto; try refl.
    { inv LOCAL1. inv MEM_TGT. exploit CLOSED; eauto. i. des.
      inv MSG_TS. ss. }
    { inv STEP_SRC. inv LOCAL1. ss. repeat (condtac; aggrtac).
      - rewrite <- ? View.join_l. apply LOCAL.
      - apply WF_TGT.
      - unfold TimeMap.join. rewrite <- Time.join_l. rewrite <- Time.join_l. rewrite <- Time.join_r.
        unfold View.singleton_ur_if. condtac; ss. unfold TimeMap.singleton, LocFun.add.
        condtac; ss. refl.
    }
    i. des.
    exploit Local.write_step_future; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs 2. econs; cycle 1.
      * econs 4; eauto.
      * econs; eauto.
    + auto.
    + left. eapply paco11_mon; [apply sim_acquired_sim_thread|]; ss.
  - (* racy read *)
    right.
    dependent destruction H.
    exploit sim_local_racy_read_acquired; try exact LOCAL1; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs 2. econs; cycle 1.
      * econs 9; eauto.
      * econs; eauto.
    + ss.
    + left. eapply paco11_mon; [apply sim_acquired_sim_thread|]; ss.
      apply sim_local_sim_acquired; eauto.
  - (* racy read *)
    right.
    dependent destruction H.
    exploit sim_local_racy_read_acquired; try exact LOCAL1; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs 2. econs; [|econs 9]; eauto. econs; eauto.
    + ss.
    + left. eapply paco11_mon; [apply sim_acquired_sim_thread|]; ss.
      apply sim_local_sim_acquired; eauto.
  - (* racy update *)
    left.
    dependent destruction H.
    exploit sim_local_racy_update_acquired; try exact LOCAL1; eauto. i. des.
    unfold Thread.steps_failure.
    esplits; try refl.
    + econs 2. econs; [|econs 11]; eauto. econs; eauto.
    + ss.
Qed.


(*
 * Copyright (c) 2020 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
(* This file contains intensional functions necessary to
 * describe the semantics of our AST.
 *
 * It would be great if we could eliminate this, but it
 * requires some more thought.
 *
 * Another option would be to completely pre-process the
 * AST and remove these nodes.
 *)
Require Import Coq.ZArith.ZArith_base.
Require Import bedrock.lang.cpp.ast.

(* this function determines whether the type is an aggregate type, i.e.
 * arrays and objects.
 *)
Fixpoint is_aggregate (t : type) : bool :=
  match t with
  | Tnamed _
  | Tarray _ _ => true
  | Tqualified _ t => is_aggregate t
  | _ => false
  end.

Fixpoint is_void (t : type) : bool :=
  match t with
  | Tqualified _ t => is_void t
  | Tvoid => true
  | _ => false
  end.

(* this determines whether a type is initializable from a primitive.
 *)
Fixpoint prim_initializable (t : type) : bool :=
  match t with
  | Tpointer _
  | Tnum _ _
  | Tbool
  | Tenum _
  | Tnullptr => true
  | Tqualified _ t => prim_initializable t
  | _ => false
  end.


Require Import Raft.

Section NoAppendEntriesToSelfInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition no_append_entries_to_self (net : network) : Prop :=
    forall p t n pli plt es ci,
      In p (nwPackets net) ->
      pBody p = AppendEntries t n pli plt es ci ->
      pDst p = pSrc p ->
      False.

  Class no_append_entries_to_self_interface : Prop :=
    {
      no_append_entries_to_self_invariant :
        forall net,
          raft_intermediate_reachable net ->
          no_append_entries_to_self net
    }.
End NoAppendEntriesToSelfInterface.


Require Import VST.concurrency.conclib.
Require Import VST.floyd.proofauto.
Require Import VST.atomics.general_locks.
Require Import Coq.Sets.Ensembles.
Require Import bst.puretree.
Require Import bst.bst_template_coupling.
Require Import bst.coupling_lib.
Require Import bst.coupling_traverse.
Require Import VST.floyd.library.

Definition treebox_new_spec :=
  DECLARE _treebox_new
  WITH gv: globals
  PRE  [  ]
    PROP () PARAMS () GLOBALS (gv) SEP (mem_mgr gv)
  POST [ tptr (tptr t_struct_tree_t) ]
    EX p: val, EX newt: val, EX lock: val,
    PROP ()
    LOCAL (temp ret_temp p)
    SEP (mem_mgr gv; atomic_int_at Ews (vint 0) lock;
         malloc_token Ews t_struct_tree_t newt;
         data_at Ews t_struct_tree_t (Vlong (Int64.repr 0), lock) newt;
         malloc_token Ews (tptr t_struct_tree_t) p;
         data_at Ews (tptr t_struct_tree_t) newt p).

Lemma body_treebox_new: semax_body Vprog Gprog f_treebox_new treebox_new_spec.
Proof.
  start_function.
  forward_call (tptr t_struct_tree_t, gv).
  Intros p. (* treebox p *)
  forward_call (t_struct_tree_t, gv).
  Intros newt. (* tree_t *newt *)
  forward.
  forward_call (gv).
  Intros l. (* lock_t *l *)
  forward.
  forward.
  sep_apply atomic_int_isptr.
  Intros.
  forward_call release_nonatomic (l).
  forward.
  Exists p. Exists newt. Exists l.
  entailer !.
Qed.

Definition turn_left_spec :=
 DECLARE _turn_left
  WITH l: val, tl: val, x: Z, vx: val, tll: val,
       r: val, tr: val, y: Z, vy: val, mid: val, trr: val
  PRE  [tptr t_struct_tree_t, tptr t_struct_tree_t]
    PROP (is_pointer_or_null mid)
    PARAMS (l; r) GLOBALS ()
    SEP (field_at Ews (t_struct_tree_t) [StructField _t] tl l;
         field_at Ews (t_struct_tree_t) [StructField _t] tr r;
         data_at Ews t_struct_tree (Vint (Int.repr x), (vx, (tll, r))) tl;
         data_at Ews t_struct_tree (Vint (Int.repr y), (vy, (mid, trr))) tr)
  POST [ Tvoid ]
    PROP ()
    LOCAL ()
    SEP (field_at Ews (t_struct_tree_t) [StructField _t] tr l;
         field_at Ews (t_struct_tree_t) [StructField _t] tl r;
         data_at Ews t_struct_tree (Vint (Int.repr x), (vx, (tll, mid))) tl;
         data_at Ews t_struct_tree (Vint (Int.repr y), (vy, (r, trr))) tr).

Lemma body_turn_left: semax_body Vprog Gprog f_turn_left turn_left_spec.
Proof.
  start_function.
  forward.
  forward.
  forward.
  forward.
  forward.
  forward.
  forward.
  entailer!.
Qed.

Program Definition pushdown_left_spec :=
 DECLARE _pushdown_left
 ATOMIC TYPE (rmaps.ConstType
                (val * val * lock_handle * share * Z * val *
                 lock_handle * lock_handle * val * val *
                   gname * gname * globals * range *
                   gname * gname * gname))
 OBJ M INVS ∅
 WITH p, tp, lockp, gsh, x, vx,
      locka, lockb, ta, tb,
       g, g_root, gv, r,
       g_del, ga, gb
  PRE [ tptr t_struct_tree_t ]
    PROP (Int.min_signed <= x <= Int.max_signed;
          tc_val (tptr Tvoid) vx;
          key_in_range x r = true)
    PARAMS (p) GLOBALS (gv)
    SEP (mem_mgr gv;
         in_tree g g_del;
         my_half g_del gsh (r, Some (Some (x, vx, ga, gb)));
         field_at Ews t_struct_tree_t [StructField _t] tp p;
         data_at Ews t_struct_tree (Vint (Int.repr x), (vx, (ta, tb))) tp;
         ltree g g_del lsh2 gsh2 gsh p lockp;
         ltree g ga lsh1 gsh1 gsh1 ta locka;
         ltree g gb lsh1 gsh1 gsh1 tb lockb;
         malloc_token Ews t_struct_tree tp;
         (* malloc_token Ews t_lock (ptr_of lockp); *)
         malloc_token Ews t_struct_tree_t p) | (tree_rep g g_root M)
  POST [ Tvoid ]
    PROP ()
    LOCAL ()
    SEP (mem_mgr gv) | (tree_rep g g_root (base.delete x M)).

Program Definition delete_spec :=
 DECLARE _delete
 ATOMIC TYPE (rmaps.ConstType (_ * _ * _ * _ * _ * _ * _))
         OBJ M INVS ∅
 WITH b, x, lock, gv, sh, g, g_root
 PRE  [ tptr (tptr t_struct_tree_t), tint]
    PROP (Int.min_signed <= x <= Int.max_signed; writable_share sh)
    PARAMS (b; Vint (Int.repr x)) GLOBALS (gv)
    SEP (mem_mgr gv; nodebox_rep g g_root sh lock b) | (tree_rep g g_root M)
  POST [ Tvoid ]
    PROP ()
    LOCAL ()
    SEP (mem_mgr gv; nodebox_rep g g_root sh lock b) | (tree_rep g g_root (base.delete x M)).

Definition Gprog : funspecs :=
    ltac:(with_library prog [acquire_spec; release_spec; makelock_spec;
     surely_malloc_spec; traverse_spec; findnext_spec; pushdown_left_spec; turn_left_spec;
                             delete_spec; freelock_spec ]).

(* Proving delete function satisfies spec *)
Lemma body_delete: semax_body Vprog Gprog f_delete delete_spec.
Proof.
  start_function.
  unfold nodebox_rep, ltree.
  Intros np.
  forward_call (t_struct_pn, gv).
  Intros nb.
  forward.
  forward.
  forward.
  forward.
  set (AS := atomic_shift _ _ _ _ _).
  (* acquire(pn->n->lock); *)
  forward_call acquire_inv_simple (sh, lock, node_lock_inv (Share.split gsh1).1 g np g_root lock).
  {
    set Q1:= fun (b : (bool * ( val * (val * (lock_handle * (share * (gname * node_info))))))%type) =>
              if b.1 then AS else AS.
    (* traverse(pn, x, nullval) *)
    (* we assign value to nullval*)
    forward_call (nb, np, sh, lock, x, nullval, gv, g, g_root, Q1).
    {
      unfold pn_rep_1, node_lock_inv'.
      Exists (default_val t_struct_pn).1.
      unfold node_lock_inv.
      sep_apply self_part_eq.
      assert (lsh2 <> Share.bot).
      { apply readable_not_bot. apply readable_lsh2. }
      auto.
      entailer !.
      rewrite -> 2sepcon_assoc. rewrite sepcon_comm.
      rewrite -> sepcon_assoc; apply sepcon_derives; [|cancel].
      unfold atomic_shift; iIntros "AU"; iAuIntro; unfold atomic_acc; simpl.
      iMod "AU" as (m) "[Hm HClose]".
      iModIntro.
      iExists m.
      iFrame "Hm".
      iSplit; iFrame.
      { by iApply bi.and_elim_l. }
      {
        iDestruct "HClose" as "[HClose _]".
        iIntros (pt) "[H _]".
        iMod ("HClose" with "H") as "H".
        iModIntro.
        unfold Q1.
        destruct (decide (pt.1 = true)). { rewrite e; iFrame. }
        { apply not_true_is_false in n; rewrite n; iFrame. }
      }
    }
    Intros pt.
    destruct pt as (fl & (p1 & (tp & (lock_in & (gsh & (g_in & r)))))).
    simpl in H1, H2.
    destruct fl.
    simpl.
    change emp with seplog.emp.
    - destruct H2.
      forward_if (
          PROP ( )
            LOCAL (temp _t'4 (ptr_of lock_in); temp _t'3 p1; temp _t'2 Vtrue;
                   temp _t'7 (ptr_of lock); temp _t'6 np; temp _t'8 np;
                   temp _pn__2 nb; gvars gv; temp _t b; temp _x (vint x))
            SEP (Q; mem_mgr gv; data_at Ews t_struct_pn (p1, p1) nb;
                 my_half g_root (Share.split gsh1).2 (Neg_Infinity, Pos_Infinity, None);
                 data_at sh (tptr t_struct_tree_t) np b;
                 field_at sh t_struct_tree_t (DOT _lock) (ptr_of lock) np;
                 lock_inv sh lock
                   (selflock (node_lock_inv_pred (Share.split gsh1).1 g np g_root (ptr_of lock))
                      gsh2 lock);
                 malloc_token Ews t_struct_pn nb)); unfold node_lock_inv_new.
      + pose proof (Int.one_not_zero); easy.
      + (* prove satisfies if_condition*)
        Intros.
        forward.
        forward.
        rewrite H3.
        unfold tree_rep_R, Q1.
        rewrite -> if_true by auto.
        simpl.
        Intros.
        gather_SEP AS (my_half g_in _ _) (in_tree g _).
        viewshift_SEP 0 (Q * (in_tree g g_in * my_half g_in gsh r)).
        {
          go_lower.
          unfold AS.
          simpl.
          apply sync_commit_same1.
          intros t.
          unfold tree_rep at 1.
          Intros tg.
          assert_PROP (Ensembles.In (find_ghost_set tg g_root) g_in) as Hin.
          { sep_apply node_exist_in_tree. entailer!. }
          sep_apply (ghost_tree_rep_public_half_ramif _ _ (Neg_Infinity, Pos_Infinity) _ Hin).
          Intros r0.
          iIntros "([[? ?] Hclose] & ? & ?) !>".
          iExists r0; iFrame.
          iIntros "% !> [? ?] !>".
          apply node_info_incl' in H12 as [].
          iExists tt; iFrame.
          unfold tree_rep; iExists tg; iFrame.
          destruct r, r0; simpl in *; subst.
          iSplit.
          { iPureIntro; repeat (split; auto).
            rewrite delete_notin; auto; subst.
            eapply range_info_not_in_gmap; last eassumption; auto.
            eapply key_in_range_incl; eauto.
          }
          iApply "Hclose"; iFrame.
        }
        (*  (_release2(_t'4); *)
        change emp with seplog.emp.
        forward_call release_self (gsh2, lock_in,
                    node_lock_inv_pred gsh g p1 g_in (ptr_of lock_in)).
        {
          unfold node_lock_inv_pred at 3, sync_inv.
          Exists r.
          rewrite node_rep_def.
          unfold node_lock_inv, tree_rep_R.
          Exists nullval.
          rewrite -> if_true by auto.
          entailer !.
        }
        entailer !.
      + forward_call (t_struct_pn, nb, gv).
        { assert_PROP (nb <> nullval) by entailer !. rewrite if_false; auto. cancel. }
        forward.
        unfold nodebox_rep, ltree.
        Exists np.
        entailer !.
   - (* _pushdown_left(_t'5);) *)
     unfold Q1.
     destruct H2 as ( ?  & v2 & g21 & g22 & ?).
      simpl.
      forward_if(
          PROP ( )
            LOCAL (temp _t'5 p1; temp _t'2 Vfalse; temp _t'7 (ptr_of lock); temp _t'6 np;
                   temp _t'8 np; temp _pn__2 nb; gvars gv; temp _t b; temp _x (vint x))
            SEP (Q; mem_mgr gv; data_at Ews t_struct_pn (p1, p1) nb;
                 my_half g_root (Share.split gsh1).2 (Neg_Infinity, Pos_Infinity, None);
                 data_at sh (tptr t_struct_tree_t) np b;
                 field_at sh t_struct_tree_t (DOT _lock) (ptr_of lock) np;
                 lock_inv sh lock
                   (selflock (node_lock_inv_pred (Share.split gsh1).1 g np g_root (ptr_of lock))
                      gsh2 lock);
                 malloc_token Ews t_struct_pn nb)).
      + unfold node_lock_inv_new, tree_rep_R.
        rewrite -> if_false; auto.
        Intros g1 g2 x1 v p1' p2' l1 l2.
        forward.
        destruct r as (x0 & y0).
        simpl in H8.
        simpl in H5. subst y0.
        injection H3.
        intros. subst x1. subst v2. subst g21. subst g22.
        assert_PROP (field_compatible t_struct_tree_t [] p1) by entailer !.
        forward_call (p1, tp, lock_in, gsh, x, v, l1, l2, p1', p2',
                       g, g_root, gv, x0, g_in, g1, g2, Q).
        {
          unfold AS.
          unfold ltree.
          entailer !.
          rewrite ->  5sepcon_assoc; apply sepcon_derives; [|cancel].
          unfold atomic_shift; iIntros "AU"; iAuIntro; unfold atomic_acc; simpl.
          iMod "AU" as (m) "[Hm HClose]".
          iModIntro.
          iExists m.
          iFrame "Hm".
          iSplit; iFrame.
          { by iApply bi.and_elim_l. }
          {
            iDestruct "HClose" as "[_ HClose]".
            done.
          }
        }
        entailer !.
      + (* contradiction, since  Int.one = Int.zero *)
       pose proof Int.one_not_zero; contradiction.
      + (* _free(_pn__2); *)
        forward_call (t_struct_pn, nb, gv).
        { assert_PROP (nb <> nullval) by entailer !. rewrite if_false; auto. cancel. }
        forward.
        unfold nodebox_rep, ltree.
        Exists np.
        entailer !.
     }
Qed.

Lemma body_pushdown_left: semax_body Vprog Gprog f_pushdown_left pushdown_left_spec.
Proof.
  start_function.
  forward_loop (
    EX p : val, EX lockp: lock_handle, EX tb : val, EX lockb: lock_handle,
              EX gb : gname, EX g_del : gname, EX r : range, EX gsh : share,
    PROP (key_in_range x r = true)
    LOCAL (temp _tgp p;  gvars gv)
    SEP (atomic_shift (λ M, tree_rep g g_root M) ⊤ ∅ (λ M (_ : ()),
             fold_right_sepcon [tree_rep g g_root (delete x M)]) (λ _ : (), Q);
        mem_mgr gv;
        in_tree g g_del; my_half g_del gsh (r, Some (Some (x, vx, ga, gb)));
        field_at Ews t_struct_tree_t [StructField _t] tp p;
        data_at Ews t_struct_tree (vint x, (vx, (ta, tb))) tp;
         ltree g g_del lsh2 gsh2 gsh p lockp;
         ltree g ga lsh1 gsh1 gsh1 ta locka;
         ltree g gb lsh1 gsh1 gsh1 tb lockb;
        malloc_token Ews t_struct_tree tp;
        (* malloc_token Ews t_lock (ptr_of lockp); *)
         malloc_token Ews t_struct_tree_t p))%assert.
  { Exists p lockp tb lockb gb g_del r gsh.
    entailer!.
  }
  clear dependent g_del r gsh.
  Intros p' lockp' tb' lockb' gb' g_del r gsh.
  unfold ltree at 1; Intros.
  change emp with seplog.emp.
  forward.
  forward.
  forward.
  unfold ltree at 2; Intros.
  forward.
  forward_call acquire_inv_simple  (gsh1, lockb', node_lock_inv gsh1 g tb' gb' lockb').
  Local Typeclasses eauto := 5.
  rewrite later_sepcon.
  rewrite later_sepcon.
  unfold sync_inv at 1.
  rewrite <- sepcon_assoc.
  rewrite sepcon_assoc.
  rewrite later_exp'; [ |apply (Neg_Infinity, Pos_Infinity, None)].
  Intros b; destruct b as (rangeb, g_infob).
  rewrite later_sepcon.
  rewrite node_rep_def.
  rewrite later_exp'; last apply ta.
  Intros tbv; simpl.
  rewrite later_sepcon.
  rewrite later_sepcon.
  rewrite later_sepcon.
  Intros.
  forward.
  forward_if.
  { subst.
    unfold tree_rep_R.
    if_tac; [| contradiction].
    Intros.
    change emp with seplog.emp.
    forward.
    unfold ltree at 1; Intros.
    forward.
    forward_call acquire_inv_simple (gsh1, locka, node_lock_inv gsh1 g ta ga locka).
    rewrite later_sepcon.
    rewrite later_sepcon.
    unfold sync_inv at 1.
    rewrite <- sepcon_assoc.
    rewrite sepcon_assoc.
    rewrite later_exp'; [ |apply (Neg_Infinity, Pos_Infinity, None)].
    Intros a; destruct a as (rangea, g_infoa).
    rewrite later_sepcon.
    rewrite node_rep_def.
    rewrite -> later_exp'; last apply ta.
    Intros tav; simpl.
    rewrite later_sepcon.
    rewrite later_sepcon.
    rewrite later_sepcon.
    Intros.
    forward.
    forward.
    assert_PROP (tp <> nullval) by entailer !.
    forward_call (t_struct_tree, tp, gv).
    { rewrite if_false; auto. cancel. }
    forward_call freelock_self (gsh1, gsh2, lockb',
        node_lock_inv_pred gsh1 g tb' gb' (ptr_of lockb')).
    { unfold node_lock_inv at 2; cancel. }
    assert_PROP (tb' <> nullval) by entailer !.
    forward_call (t_struct_tree_t, tb', gv).
    {
      rewrite if_false; auto.
      unfold_data_at (data_at_ Ews t_struct_tree_t tb'); simpl; cancel.
      rewrite <- (field_at_share_join _ _ Ews _ [StructField _lock] _ tb') by eauto; cancel.
    }
    forward.
    forward_call freelock_self (gsh1, gsh2, locka, node_lock_inv_pred gsh1 g ta ga (ptr_of locka)).
    { unfold node_lock_inv; cancel. }
    assert_PROP (ta <> nullval) by entailer !.
    forward_call (t_struct_tree_t, ta, gv).
    {
      rewrite -> if_false; auto.
      unfold_data_at (data_at_ Ews t_struct_tree_t ta); simpl; cancel.
      rewrite <- (field_at_share_join _ _ Ews _ [StructField _lock] _ ta) by eauto; cancel.
    }
    destruct r as (n, n0).
    assert_PROP (g_infoa <> None) as infoa.
    {
      unfold tree_rep_R.
      if_tac.
      change emp with seplog.emp.
      Intros.
      entailer!.
      Intros a' b' c' d' e' a1 a2 a3. entailer!.
    }
    gather_SEP (atomic_shift _ _ _ _ _) (my_half g_del _ _) (in_tree g g_del)
      (in_tree g ga) (in_tree g gb') (my_half gb' _ _) (my_half ga _ _) (tree_rep_R tav _ g_infoa g).
    rewrite -> 5sepcon_assoc.
    viewshift_SEP 0 (Q * (EX o2, EX n1 n2: number, !!(key_in_range x (n1,n2) = true) &&
      my_half g_del gsh ((n1, n2), o2) * in_tree g g_del * tree_rep_R tav (n1, n2) o2 g)).
    {
      go_lower. eapply sync_commit_gen1. rewrite <- sepcon_assoc.
      - intros. iIntros "[Ha Hb]".
        iDestruct "Ha" as "((H1 & H3) & (H2 & (H4 & H5 & H6)))".
        iPoseProof ((ghost_tree_pushdown_left _ _ _ g_del ga gb') with "[$H1 $H2 $Hb]") as "Hadd".
        iDestruct "Hadd" as (n1 n2 o) "[[Hmya Ha] Hb]".
        iExists (n1, n2, Some o).
        instantiate (1 := vx). instantiate (1 := x). iFrame.
        iIntros "!> %".
        apply node_info_incl' in H13 as [? Heq]; inv Heq.
        iSpecialize ("Hb" with "[% //]").
        iDestruct "Hb" as (o3) "[Ha Hb]".
        iDestruct ("Hb" with "H3") as (o2) "(Hb & Hd)".
        iDestruct (public_sub with "[$Hb $H5]") as %[? J1].
        iDestruct (public_sub with "[$Ha $H4]") as %[? J2].
        iPoseProof (public_update with "[$Hb $H5]") as ">Hga".
        iPoseProof (public_update with "[$Ha $H4]") as ">Hgb".
        instantiate (1:= (Finite_Integer x, n2, Some o3)).
        instantiate (1:= (n1, Finite_Integer x, Some o2)).
        inv J2.
        iIntros "!>".
        iExists ((n, n0), Some o2), ((n1, n2), Some o2); iSplit.
        { iPureIntro. intros (?, ?) H_sep. destruct H_sep; split; auto; simpl in *.
          inv H16; [constructor|].
          simpl in *. auto. simpl in *.
          apply sepalg.join_unit2.
          apply psepalg.None_unit; eauto. auto.
          inversion H20. intros; inversion H17; subst. auto.
        }
        iIntros "[He Hf]".
        destruct g_infoa; try contradiction; inv J1.
        repeat logic_to_iris.
        iPoseProof (public_part_update(P := node_ghost) _ _ _ _ (n1, n2, Some o) (n1, n2, Some o)
                     with "[$He $Hf]") as "[_ >[He Hf]]".
        { intros. destruct H15. split. split; auto; simpl.
          hnf in H15; hnf.
          symmetry; rewrite puretree.merge_comm; eapply merge_again.
          symmetry; rewrite puretree.merge_comm; eauto.
          intros; subst; auto.
        }
        rewrite exp_sepcon1; iExists tt.
        assert (key_in_range x (n1, n2) = true) by (eapply key_in_range_incl; eauto).
        iMod ("Hd" with "[$Hmya $Hf]") as "[$ Hf]"; first auto.
        iDestruct "Hga" as "(Hga1 & (Hga2 & Hga3))".
        iDestruct "Hgb" as "(Hgb1 & (Hgb2 & Hgb3))".
        iModIntro; iExists (Some o), n1, n2; iFrame "Hf".
        iFrame "He".
        iSplit; first auto.
        rewrite range_incl_tree_rep_R; last first.
        eapply range_incl_trans, key_in_range_l; eauto.
        simpl in *. apply H5. iFrame; iClear "∗"; done.
    }
    forward_call release_self (gsh2, lockp',
                    node_lock_inv_pred gsh g p' g_del (ptr_of lockp')).
    {
      Intros o2 n1 n2.
      unfold node_lock_inv.
      unfold node_lock_inv_pred.
      unfold sync_inv.
      Exists (n1, n2, o2).
      rewrite node_rep_def.
      simpl.
      Exists tav.
      cancel.
    }
    forward.
  }
  abbreviate_semax.
  unfold tree_rep_R at 1.
  assert_PROP (tbv <> nullval) by entailer !.
  rewrite -> if_false; auto.
  Intros gbl gbr k v tbl tbr ltbl ltbr.
  forward_call (p', tp, x, vx, ta, tb', tbv, k, v, tbl, tbr).
  forward.
  destruct r as (rangel, rangeh).
  gather_SEP (atomic_shift _ _ _ _ _) (my_half g_del _ _) (my_half gb' _ _)
    (in_tree g gb') (in_tree g g_del).
  repeat rewrite sepcon_assoc. do 2 rewrite <- sepcon_assoc.
  replace_SEP 0 (|={⊤}=> atomic_shift (λ M, tree_rep g g_root M) ⊤ ∅
          (λ M (_ : ()), tree_rep g g_root (delete x M) * emp) (λ _ : (), Q) *
                   EX rangedell, EX rangedelh: _,
        !!(range_incl (rangel, rangeh) (rangedell, rangedelh) = true /\
             range_incl rangeb (rangedell, rangedelh) = true /\ x < k) &&
      my_half g_del gsh ((rangedell, rangedelh), Some (Some (k, v, gb', gbr))) *
          my_half gb' gsh1 ((rangedell, Finite_Integer k), Some (Some (x, vx, ga, gbl))) *
          (in_tree g gb' * in_tree g g_del)).
  {
    go_lower.
    rewrite !sepcon_assoc.
    eapply atomic_rollback_fupd.
    - intros.
      iIntros "((g_del & (gb & (in_gb & in_gdel))) & tree_rep)".
      iPoseProof ((ghost_tree_pushdown_left _ _ _ g_del ga gb')
                   with "[$tree_rep $in_gb $in_gdel]") as (n1 n2 o) "[Ha Hb]".
      iDestruct (public_sub with "[$g_del $Ha]") as %[? J]; inv J.
      instantiate (1 := vx). instantiate (1 := x).
      iPoseProof ("Hb" with "[% //]") as (o3) "[Hpubb Hb]".
      iPoseProof (bi.and_elim_r with "Hb") as "Hb".
      iSpecialize ("Hb" $! gbl gbr k v).
      logic_to_iris.
      iDestruct (public_sub with "[$g_del $Ha]") as %[? J1].
      iDestruct (public_sub with "[$gb $Hpubb]") as %[Hincl J2].
      iDestruct "Ha" as "[Hmya Ha]".
      iPoseProof (public_part_update(P := node_ghost) _ _ _ _ (n1, n2, Some (Some (k, v, gb', gbr)))
                    (n1, n2, Some (Some (k, v, gb', gbr)))
                   with "[$g_del $Ha]") as "[_ >[Hmyga Hpubga]]".
      { intros. destruct H13. split. split; auto; simpl.
        hnf in H13; hnf.
        symmetry; rewrite puretree.merge_comm; eapply merge_again.
        symmetry; rewrite puretree.merge_comm; eauto.
        simpl in *.
        inversion H14.
        apply sepalg.join_unit2. apply psepalg.None_unit. reflexivity.
        subst. inversion H18.
        intros; auto.
      }
      iPoseProof (public_update _ _ _ (n1, Finite_Integer k, Some (Some (x, vx, ga, gbl)))
                     with "[$gb $Hpubb]") as ">(Hmygb & Hpubgb)".
      inv J2.
      assert (key_in_range x (n1, n2) = true).
      { eapply key_in_range_incl; eauto. }
      assert (x < k).
      { eapply key_in_range_incl in Hincl; [|eauto].
        apply andb_prop in Hincl as []; simpl in *; lia.
      }
      iDestruct ("Hb" with "[$Hpubgb $Hmya $Hpubga]") as ">(($ & Hgdel) & Hgb)".
      { iPureIntro; repeat (split; auto). simpl; lia. }
      iExists n1, n2; iFrame.
      iPureIntro; repeat (split; auto).
      eapply range_incl_trans; try eassumption.
      apply (key_in_range_r _ (_, _)); auto.
   }
   match goal with |-context[|={⊤}=> ?P] => viewshift_SEP 0 P by entailer! end.
   Intros rangedell rangedelh.
   gather_SEP (lock_inv _ lockb' (node_lock_inv gsh1 g tb' gb' lockb')) (self_part _ lockb').
   unfold node_lock_inv at 1.
   sep_apply self_part_eq.
   apply readable_not_bot.
   apply readable_gsh2.
   unfold ltree at 1.
   unfold ltree at 2.
   Intros.
   forward_call release_self (gsh2, lockp', node_lock_inv_pred gsh g p' g_del (ptr_of lockp')).
   {
     unfold node_lock_inv_pred at 4.
     unfold sync_inv.
     Exists ((rangedell, rangedelh), Some (Some (k, v, gb', gbr))).
     rewrite node_rep_def; simpl. Exists tbv; cancel.
     unfold tree_rep_R.
     rewrite -> if_false; auto.
     Exists gb' gbr k v tb' tbr lockb' ltbr; cancel.
     unfold node_lock_inv. cancel.
     unfold ltree at 1.
     do 2 rewrite sepcon_andp_prop'.
     apply andp_right.
     {
       apply prop_right.
       repeat (split; auto).
       eapply key_in_range_incl; eauto.
     }
     {
       cancel. eapply derives_trans.
       2: { apply sepcon_derives; [apply now_later| apply derives_refl]. }
       entailer !.
     }
   }
   Exists tb' lockb' tbl ltbl gbl gb' (rangedell, Finite_Integer k) gsh1; entailer!.
   { eapply key_in_range_incl in H1; [|eauto].
     unfold key_in_range in *; apply andb_prop in H1 as [-> _]; simpl; lia.
   }
   unfold ltree.
   entailer !.
   apply derives_refl.
Qed.


From hahn Require Import Hahn.
Require Import Exec.
Require Import Events.

Section Scdrf.

Lemma drf_tot__hb_sc e X Y :
  well_formed e ->
  consistent e ->
  data_race_free e ->
  tot e X Y ->
  overlap X Y ->
  writes e X \/ writes e Y ->
  hb e X Y \/ (same_loc X Y /\ sc e X /\ sc e Y).
Proof.
  intros wf cst drf totXY overlapXY wXY.
  unfold data_race_free in drf.
  destruct drf with X Y as [hbXY | [hbYX | [[nWX nWY] | [novrlpXY | [slXY [scX scY]]]]]];
  auto.
  - exfalso.
    destruct wf_tot with e as [[irrefl trans] tot]; try assumption.
    apply irrefl with X.
    apply trans with Y; try assumption.
    apply cst_hb_tot; try assumption.
    apply cst_ufxd.
    assumption.
  - exfalso.
    destruct wXY; contradiction.
  - exfalso.
    destruct overlapXY.
      apply novrlpXY with x.
      destruct H.
      split; assumption.
Qed.

Theorem sc_drf e :
  well_formed e ->
  consistent e ->
  data_race_free e ->
  seqcst e.
Proof.

  intros wf cst drf.
  unfold seqcst.
  unfolder.
  intros n.
  split.
  { intros Y [X [rfbYX totXY]].
    assert (hb e X Y \/ (same_loc X Y /\ sc e X /\ sc e Y)) as [hbXY | [slXY [scX scY]]]. {
      apply drf_tot__hb_sc; auto.
      exists n. split; destruct (rfb__dom e X Y n wf rfbYX); try assumption.
      right. eapply rfb__w; eassumption.
    }
    - apply (cst_rf_hb e (cst_ufxd e cst) X).
      exists Y.
      split; try assumption.
      econstructor. eauto.
    - destruct (wf_tot e wf) as [[irrefl trans] _].
      apply irrefl with X.
      apply trans with Y; try assumption.
      apply cst_hb_tot; try apply cst_ufxd; try assumption.
      constructor. left. right.
      apply sw_intro; auto.
      eexists; eauto.
      apply same_loc_sym. auto.
  }
  intros Z' [Z [[eqZZ' [wZ domZn]] [X [totZX [Y [rfbYX totYZ]]]]]].
  subst.
  assert (in_dom n Y /\ in_dom n X) as [domYn domXn]. {
    apply rfb__dom with e; assumption.
  }
  assert (hb e Y Z \/ (same_loc Y Z /\ sc e Y /\ sc e Z)) as drfYZ. {
    apply drf_tot__hb_sc; auto.
    exists n; auto.
  }
  assert (hb e Z X \/ (same_loc Z X /\ sc e Z /\ sc e X)) as drfZX. {
    apply drf_tot__hb_sc; auto.
    exists n; auto.
  }
  assert (hb e Y X \/ (same_loc Y X /\ sc e Y /\ sc e X)) as drfYX. {
    apply drf_tot__hb_sc; auto.
    - destruct (wf_tot e wf) as [[_ trans] _].
      apply trans with Z; assumption.
    - exists n; auto.
    - left.
      apply rfb__w with X n; assumption.
  }
  destruct drfYZ as [hbYZ | [slYZ [ScY scZ]]];
  destruct drfZX as [hbZX | [slZX [ScZ' ScX]]];
  [ apply (cst_rf_hb_hb e (cst_ufxd e cst) n Z) |
    destruct drfYX as [hbYX | [slYX [ScY _]]];
      [apply (cst_ddagger e cst Z) | apply (cst_sw_tot e (cst_ufxd e cst) Z)] |
    destruct drfYX as [hbYX | [slYX [_ ScX]]];
      [apply (cst_dagger e cst Z) | apply (cst_sw_tot e (cst_ufxd e cst) Z)] |
    apply (cst_sw_tot e (cst_ufxd e cst) Z)
  ];
  unfolder;
  split; auto;
  repeat (eexists; split; eauto).
  - split; try assumption.
    apply rfb__rf with n.
    assumption.
  - apply sw_intro; auto.
    apply rfb__rf with n.
    assumption.
  - split; try assumption.
    apply rfb__rf with n.
    assumption.
  - split.
    + apply (cst_hb_tot e (cst_ufxd e cst)).
      eassumption.
    + eapply same_loc_trans;
      try eassumption.
      apply same_loc_sym.
      assumption.
  - apply sw_intro; auto.
    apply rfb__rf with n.
    assumption.
  - apply sw_intro; auto.
    apply rfb__rf with n.
    assumption.
    eapply same_loc_trans;
    eassumption.
Qed.

End Scdrf.