barrier.v 23.7 KB
Newer Older
Ralf Jung's avatar
Ralf Jung committed
1
From prelude Require Export functions.
2
From algebra Require Export upred_big_op upred_tactics.
3
From program_logic Require Export sts saved_prop.
4
From program_logic Require Import hoare.
5
From heap_lang Require Export derived heap wp_tactics notation.
Ralf Jung's avatar
Ralf Jung committed
6
Import uPred.
7
8
9

Definition newchan := (λ: "", ref '0)%L.
Definition signal := (λ: "x", "x" <- '1)%L.
10
Definition wait := (rec: "wait" "x" :=if: !"x" = '1 then '() else "wait" "x")%L.
11

12
13
14
(** The STS describing the main barrier protocol. Every state has an index-set
    associated with it. These indices are actually [gname], because we use them
    with saved propositions. *)
15
Module barrier_proto.
16
  Inductive phase := Low | High.
Robbert Krebbers's avatar
Robbert Krebbers committed
17
  Record state := State { state_phase : phase; state_I : gset gname }.
Robbert Krebbers's avatar
Robbert Krebbers committed
18
  Add Printing Constructor state.
19
20
  Inductive token := Change (i : gname) | Send.

Robbert Krebbers's avatar
Robbert Krebbers committed
21
  Global Instance stateT_inhabited: Inhabited state := populate (State Low ).
Robbert Krebbers's avatar
Robbert Krebbers committed
22
23
  Global Instance Change_inj : Inj (=) (=) Change.
  Proof. by injection 1. Qed.
24

Robbert Krebbers's avatar
Robbert Krebbers committed
25
26
27
  Inductive prim_step : relation state :=
    | ChangeI p I2 I1 : prim_step (State p I1) (State p I2)
    | ChangePhase I : prim_step (State Low I) (State High I).
28

Robbert Krebbers's avatar
Robbert Krebbers committed
29
30
31
32
  Definition change_tok (I : gset gname) : set token :=
    mkSet (λ t, match t with Change i => i  I | Send => False end).
  Definition send_tok (p : phase) : set token :=
    match p with Low =>  | High => {[ Send ]} end.
Robbert Krebbers's avatar
Robbert Krebbers committed
33
  Definition tok (s : state) : set token :=
Robbert Krebbers's avatar
Robbert Krebbers committed
34
35
    change_tok (state_I s)  send_tok (state_phase s).
  Global Arguments tok !_ /.
36

Robbert Krebbers's avatar
Robbert Krebbers committed
37
  Canonical Structure sts := sts.STS prim_step tok.
38

39
  (* The set of states containing some particular i *)
Robbert Krebbers's avatar
Robbert Krebbers committed
40
  Definition i_states (i : gname) : set state :=
41
42
    mkSet (λ s, i  state_I s).

Robbert Krebbers's avatar
Robbert Krebbers committed
43
44
45
46
47
  (* The set of low states *)
  Definition low_states : set state :=
    mkSet (λ s, if state_phase s is Low then True else False).

  Lemma i_states_closed i : sts.closed (i_states i) {[ Change i ]}.
48
49
  Proof.
    split.
Robbert Krebbers's avatar
Robbert Krebbers committed
50
    - move=>[p I]. rewrite /= !mkSet_elem_of /= =>HI.
51
      destruct p; set_solver by eauto.
52
53
54
55
    - (* If we do the destruct of the states early, and then inversion
         on the proof of a transition, it doesn't work - we do not obtain
         the equalities we need. So we destruct the states late, because this
         means we can use "destruct" instead of "inversion". *)
Robbert Krebbers's avatar
Robbert Krebbers committed
56
57
      move=>s1 s2. rewrite !mkSet_elem_of.
      intros Hs1 [T1 T2 Hdisj Hstep'].
58
      inversion_clear Hstep' as [? ? ? ? Htrans _ _ Htok].
Robbert Krebbers's avatar
Robbert Krebbers committed
59
60
61
62
63
64
      destruct Htrans; simpl in *; last done.
      move: Hs1 Hdisj Htok. rewrite elem_of_equiv_empty elem_of_equiv.
      move=> ? /(_ (Change i)) Hdisj /(_ (Change i)); move: Hdisj.
      rewrite elem_of_intersection elem_of_union !mkSet_elem_of.
      intros; apply dec_stable.
      destruct p; set_solver.
Ralf Jung's avatar
Ralf Jung committed
65
  Qed.
66

67
  Lemma low_states_closed : sts.closed low_states {[ Send ]}.
68
69
70
  Proof.
    split.
    - move=>[p I]. rewrite /= /tok !mkSet_elem_of /= =>HI.
71
      destruct p; set_solver.
Robbert Krebbers's avatar
Robbert Krebbers committed
72
73
    - move=>s1 s2. rewrite !mkSet_elem_of.
      intros Hs1 [T1 T2 Hdisj Hstep'].
74
      inversion_clear Hstep' as [? ? ? ? Htrans _ _ Htok].
Robbert Krebbers's avatar
Robbert Krebbers committed
75
76
      destruct Htrans; simpl in *; first by destruct p.
      set_solver.
77
78
  Qed.

79
  (* Proof that we can take the steps we need. *)
Robbert Krebbers's avatar
Robbert Krebbers committed
80
81
  Lemma signal_step I : sts.steps (State Low I, {[Send]}) (State High I, ).
  Proof. apply rtc_once. constructor; first constructor; set_solver. Qed.
82
83

  Lemma wait_step i I :
Robbert Krebbers's avatar
Robbert Krebbers committed
84
85
    i  I 
    sts.steps (State High I, {[ Change i ]}) (State High (I  {[ i ]}), ).
86
87
  Proof.
    intros. apply rtc_once.
Robbert Krebbers's avatar
Robbert Krebbers committed
88
    constructor; first constructor; simpl; [set_solver by eauto..|].
89
90
    (* TODO this proof is rather annoying. *)
    apply elem_of_equiv=>t. rewrite !elem_of_union.
Robbert Krebbers's avatar
Robbert Krebbers committed
91
    rewrite !mkSet_elem_of /change_tok /=.
92
    destruct t as [j|]; last set_solver.
93
    rewrite elem_of_difference elem_of_singleton.
94
    destruct (decide (i = j)); set_solver.
95
  Qed.
96

97
98
  Lemma split_step p i i1 i2 I :
    i  I  i1  I  i2  I  i1  i2 
Robbert Krebbers's avatar
Robbert Krebbers committed
99
100
101
    sts.steps
      (State p I, {[ Change i ]})
      (State p ({[i1]}  ({[i2]}  (I  {[i]}))), {[ Change i1; Change i2 ]}).
102
103
  Proof.
    intros. apply rtc_once.
Robbert Krebbers's avatar
Robbert Krebbers committed
104
105
    constructor; first constructor; simpl.
    - destruct p; set_solver.
106
107
    (* This gets annoying... and I think I can see a pattern with all these proofs. Automatable? *)
    - apply elem_of_equiv=>t. destruct t; last set_solver.
Robbert Krebbers's avatar
Robbert Krebbers committed
108
109
110
      rewrite !mkSet_elem_of !not_elem_of_union !not_elem_of_singleton
        not_elem_of_difference elem_of_singleton !(inj_iff Change).
      destruct p; naive_solver.
111
    - apply elem_of_equiv=>t. destruct t as [j|]; last set_solver.
Robbert Krebbers's avatar
Robbert Krebbers committed
112
113
114
115
      rewrite !mkSet_elem_of !not_elem_of_union !not_elem_of_singleton
        not_elem_of_difference elem_of_singleton !(inj_iff Change).
      destruct (decide (i1 = j)) as [->|]; first tauto.
      destruct (decide (i2 = j)) as [->|]; intuition.
116
117
  Qed.

118
End barrier_proto.
119
120
121
122
123
124
(* I am too lazy to type the full module name all the time. But then
   why did we even put this into a module? Because some of the names 
   are so general.
   What we'd really like here is to import *some* of the names from
   the module into our namespaces. But Coq doesn't seem to support that...?? *)
Import barrier_proto.
125

126
127
(** The monoids we need. *)
(* Not bundling heapG, as it may be shared with other users. *)
128
Class barrierG Σ := BarrierG {
129
130
131
132
  barrier_stsG :> stsG heap_lang Σ sts;
  barrier_savedPropG :> savedPropG heap_lang Σ;
}.

133
Definition barrierGF : iFunctors := [stsGF sts; agreeF].
134

Robbert Krebbers's avatar
Robbert Krebbers committed
135
136
Instance inGF_barrierG
  `{inGF heap_lang Σ (stsGF sts), inGF heap_lang Σ agreeF} : barrierG Σ.
137
138
Proof. split; apply _. Qed.

139
140
(** Now we come to the Iris part of the proof. *)
Section proof.
Robbert Krebbers's avatar
Robbert Krebbers committed
141
142
  Context {Σ : iFunctorG} `{!heapG Σ, !barrierG Σ}.
  Context (heapN N : namespace).
143
  Local Notation iProp := (iPropG heap_lang Σ).
144
145

  Definition waiting (P : iProp) (I : gset gname) : iProp :=
Robbert Krebbers's avatar
Robbert Krebbers committed
146
147
    ( Ψ : gname  iProp,
       (P - Π★{set I} Ψ)  Π★{set I} (λ i, saved_prop_own i (Ψ i)))%I.
148
149

  Definition ress (I : gset gname) : iProp :=
Robbert Krebbers's avatar
Robbert Krebbers committed
150
151
152
153
154
    (Π★{set I} (λ i,  R, saved_prop_own i R   R))%I.

  Coercion state_to_val (s : state) : val :=
    match s with State Low _ => '0 | State High _ => '1 end.
  Arguments state_to_val !_ /.
155

Robbert Krebbers's avatar
Robbert Krebbers committed
156
  Definition barrier_inv (l : loc) (P : iProp) (s : state) : iProp :=
Robbert Krebbers's avatar
Robbert Krebbers committed
157
    (l  s 
158
159
     match s with State Low I' => waiting P I' | State High I' => ress I' end
    )%I.
160
161

  Definition barrier_ctx (γ : gname) (l : loc) (P : iProp) : iProp :=
162
    ( (heapN  N)  heap_ctx heapN  sts_ctx γ N (barrier_inv l P))%I.
163

Robbert Krebbers's avatar
Robbert Krebbers committed
164
165
166
167
168
169
170
171
172
  Definition send (l : loc) (P : iProp) : iProp :=
    ( γ, barrier_ctx γ l P  sts_ownS γ low_states {[ Send ]})%I.

  Definition recv (l : loc) (R : iProp) : iProp :=
    ( γ P Q i,
      barrier_ctx γ l P  sts_ownS γ (i_states i) {[ Change i ]} 
      saved_prop_own i Q   (Q - R))%I.

  (** Setoids *)
173
174
  (* These lemmas really ought to be doable by just calling a tactic.
     It is just application of already registered congruence lemmas. *)
Robbert Krebbers's avatar
Robbert Krebbers committed
175
176
177
178
  Global Instance waiting_ne n : Proper (dist n ==> (=) ==> dist n) waiting.
  Proof. intros P1 P2 HP I1 I2 ->. rewrite /waiting. by setoid_rewrite HP. Qed.
  Global Instance barrier_inv_ne n l :
    Proper (dist n ==> pointwise_relation _ (dist n)) (barrier_inv l).
179
  Proof.
Robbert Krebbers's avatar
Robbert Krebbers committed
180
    intros P1 P2 HP [[] ]; rewrite /barrier_inv //=. by setoid_rewrite HP.
181
  Qed.
Robbert Krebbers's avatar
Robbert Krebbers committed
182
183
  Global Instance barrier_ctx_ne n γ l : Proper (dist n ==> dist n) (barrier_ctx γ l).
  Proof. intros P1 P2 HP. rewrite /barrier_ctx. by setoid_rewrite HP. Qed.
184
  Global Instance send_ne n l : Proper (dist n ==> dist n) (send l).
Robbert Krebbers's avatar
Robbert Krebbers committed
185
  Proof. intros P1 P2 HP. rewrite /send. by setoid_rewrite HP. Qed.
186
  Global Instance recv_ne n l : Proper (dist n ==> dist n) (recv l).
Robbert Krebbers's avatar
Robbert Krebbers committed
187
  Proof. intros R1 R2 HR. rewrite /recv. by setoid_rewrite HR. Qed.
188

Robbert Krebbers's avatar
Robbert Krebbers committed
189
  (** Helper lemmas *)
Ralf Jung's avatar
Ralf Jung committed
190
191
192
193
194
195
196
197
198
199
  Lemma waiting_split i i1 i2 Q R1 R2 P I :
    i  I  i1  I  i2  I  i1  i2 
    (saved_prop_own i2 R2  saved_prop_own i1 R1  saved_prop_own i Q 
     (Q - R1  R2)  waiting P I)
     waiting P ({[i1]}  ({[i2]}  (I  {[i]}))).
  Proof.
    intros. rewrite /waiting !sep_exist_l. apply exist_elim=>Ψ.
    rewrite -(exist_intro (<[i1:=R1]> (<[i2:=R2]> Ψ))).
    rewrite [(Π★{set _} (λ _, saved_prop_own _ _))%I](big_sepS_delete _ I i) //.
    rewrite !assoc [(_  (_ - _))%I]comm !assoc [(_   _)%I]comm.
Ralf Jung's avatar
Ralf Jung committed
200
    rewrite !assoc [(_  _ i _)%I]comm !assoc [(_  _ i _)%I]comm -!assoc.
201
202
    do 4 (rewrite big_sepS_insert; last set_solver).
    rewrite !fn_lookup_insert fn_lookup_insert_ne // !fn_lookup_insert.
Ralf Jung's avatar
Ralf Jung committed
203
204
205
206
    rewrite 3!assoc. apply sep_mono.
    - rewrite saved_prop_agree. u_strip_later.
      apply wand_intro_l. rewrite [(_  (_ - Π★{set _} _))%I]comm !assoc wand_elim_r.
      rewrite (big_sepS_delete _ I i) //.
207
      rewrite [(_  Π★{set _} _)%I]comm [(_  Π★{set _} _)%I]comm -!assoc.
Ralf Jung's avatar
Ralf Jung committed
208
      apply sep_mono.
Robbert Krebbers's avatar
Robbert Krebbers committed
209
210
211
      + apply big_sepS_mono; [done|] => j.
        rewrite elem_of_difference not_elem_of_singleton=> -[??].
        by do 2 (rewrite fn_lookup_insert_ne; last naive_solver).
212
      + rewrite !assoc.
Ralf Jung's avatar
Ralf Jung committed
213
214
215
        eapply wand_apply_r'; first done.
        apply: (eq_rewrite (Ψ i) Q (λ x, x)%I); last by eauto with I.
        rewrite eq_sym. eauto with I.
Robbert Krebbers's avatar
Robbert Krebbers committed
216
217
218
219
    - rewrite !assoc [(saved_prop_own i2 _  _)%I]comm; apply sep_mono_r.
      apply big_sepS_mono; [done|]=> j.
      rewrite elem_of_difference not_elem_of_singleton=> -[??].
      by do 2 (rewrite fn_lookup_insert_ne; last naive_solver).
Ralf Jung's avatar
Ralf Jung committed
220
221
222
223
224
225
226
227
228
229
230
  Qed. 

  Lemma ress_split i i1 i2 Q R1 R2 I :
    i  I  i1  I  i2  I  i1  i2 
    (saved_prop_own i2 R2  saved_prop_own i1 R1  saved_prop_own i Q 
     (Q - R1  R2)  ress I)
     ress ({[i1]}  ({[i2]}  (I  {[i]}))).
  Proof.
    intros. rewrite /ress.
    rewrite [(Π★{set _} _)%I](big_sepS_delete _ I i) // !assoc !sep_exist_l !sep_exist_r.
    apply exist_elim=>R.
Robbert Krebbers's avatar
Robbert Krebbers committed
231
    do 2 (rewrite big_sepS_insert; last set_solver).
Ralf Jung's avatar
Ralf Jung committed
232
233
234
235
236
    rewrite -(exist_intro R1) -(exist_intro R2) [(_ i2 _  _)%I]comm -!assoc.
    apply sep_mono_r. rewrite !assoc. apply sep_mono_l.
    rewrite [( _  _ i2 _)%I]comm -!assoc. apply sep_mono_r.
    rewrite !assoc [(_  _ i R)%I]comm !assoc saved_prop_agree.
    rewrite [( _  _)%I]comm -!assoc. eapply wand_apply_l.
Robbert Krebbers's avatar
Robbert Krebbers committed
237
    { by rewrite <-later_wand, <-later_intro. }
Ralf Jung's avatar
Ralf Jung committed
238
239
240
241
    { by rewrite later_sep. }
    u_strip_later.
    apply: (eq_rewrite R Q (λ x, x)%I); eauto with I.
  Qed.
Ralf Jung's avatar
Ralf Jung committed
242

Robbert Krebbers's avatar
Robbert Krebbers committed
243
  (** Actual proofs *)
244
  Lemma newchan_spec (P : iProp) (Φ : val  iProp) :
245
    heapN  N 
246
    (heap_ctx heapN   l, recv l P  send l P - Φ (LocV l))
247
     || newchan '() {{ Φ }}.
Ralf Jung's avatar
Ralf Jung committed
248
  Proof.
249
    intros HN. rewrite /newchan. wp_seq.
250
    rewrite -wp_pvs. wp eapply wp_alloc; eauto with I ndisj.
Ralf Jung's avatar
Ralf Jung committed
251
252
253
    apply forall_intro=>l. rewrite (forall_elim l). apply wand_intro_l.
    rewrite !assoc. apply pvs_wand_r.
    (* The core of this proof: Allocating the STS and the saved prop. *)
Robbert Krebbers's avatar
Robbert Krebbers committed
254
    eapply sep_elim_True_r; first by eapply (saved_prop_alloc _ P).
Ralf Jung's avatar
Ralf Jung committed
255
256
    rewrite pvs_frame_l. apply pvs_strip_pvs. rewrite sep_exist_l.
    apply exist_elim=>i.
Robbert Krebbers's avatar
Robbert Krebbers committed
257
    trans (pvs   (heap_ctx heapN   (barrier_inv l P (State Low {[ i ]}))  saved_prop_own i P)).
258
259
260
    - rewrite -pvs_intro. cancel [heap_ctx heapN].
      rewrite {1}[saved_prop_own _ _]always_sep_dup. cancel [saved_prop_own i P].
      rewrite /barrier_inv /waiting -later_intro. cancel [l  '0]%I.
Ralf Jung's avatar
Ralf Jung committed
261
      rewrite -(exist_intro (const P)) /=. rewrite -[saved_prop_own _ _](left_id True%I ()%I).
Robbert Krebbers's avatar
Robbert Krebbers committed
262
      by rewrite !big_sepS_singleton /= wand_diag -later_intro.
Ralf Jung's avatar
Ralf Jung committed
263
264
265
266
    - rewrite (sts_alloc (barrier_inv l P)  N); last by eauto.
      rewrite !pvs_frame_r !pvs_frame_l. 
      rewrite pvs_trans'. apply pvs_strip_pvs. rewrite sep_exist_r sep_exist_l.
      apply exist_elim=>γ.
Ralf Jung's avatar
Ralf Jung committed
267
268
269
      rewrite /recv /send. rewrite -(exist_intro γ) -(exist_intro P).
      rewrite -(exist_intro P) -(exist_intro i) -(exist_intro γ).
      (* This is even more annoying than usually, since rewrite sometimes unfolds stuff... *)
270
271
      rewrite [barrier_ctx _ _ _]lock !assoc
              [(_  locked (barrier_ctx _ _ _))%I]comm !assoc -lock.
Ralf Jung's avatar
Ralf Jung committed
272
      rewrite -always_sep_dup.
Ralf Jung's avatar
Ralf Jung committed
273
      (* TODO: This is cancelling below a pvs. *)
Ralf Jung's avatar
Ralf Jung committed
274
      rewrite [barrier_ctx _ _ _]lock always_and_sep_l -!assoc assoc -lock.
275
      rewrite -pvs_frame_l. rewrite /barrier_ctx const_equiv // left_id. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
276
277
      rewrite [(saved_prop_own _ _  _)%I]comm !assoc. rewrite -pvs_frame_r.
      apply sep_mono_l.
Ralf Jung's avatar
Ralf Jung committed
278
279
280
      rewrite -assoc [( _  _)%I]comm assoc -pvs_frame_r.
      eapply sep_elim_True_r; last eapply sep_mono_l.
      { rewrite -later_intro. apply wand_intro_l. by rewrite right_id. }
Ralf Jung's avatar
Ralf Jung committed
281
282
      rewrite (sts_own_weaken  _ _ (i_states i  low_states) _ 
                              ({[ Change i ]}  {[ Send ]})).
Robbert Krebbers's avatar
Robbert Krebbers committed
283
284
285
286
287
288
      + apply pvs_mono.
        rewrite -sts_ownS_op; eauto using i_states_closed, low_states_closed.
        set_solver.
      + move=> /= t. rewrite !mkSet_elem_of; intros [<-|<-]; set_solver.
      + rewrite !mkSet_elem_of; set_solver.
      + auto using sts.closed_op, i_states_closed, low_states_closed.
Ralf Jung's avatar
Ralf Jung committed
289
  Qed.
Ralf Jung's avatar
Ralf Jung committed
290

291
  Lemma signal_spec l P (Φ : val  iProp) :
292
    (send l P  P  Φ '())  || signal (LocV l) {{ Φ }}.
Ralf Jung's avatar
Ralf Jung committed
293
  Proof.
294
295
    rewrite /signal /send /barrier_ctx. rewrite sep_exist_r.
    apply exist_elim=>γ. rewrite -!assoc. apply const_elim_sep_l=>?. wp_let.
Ralf Jung's avatar
Ralf Jung committed
296
    (* I think some evars here are better than repeating *everything* *)
297
298
    eapply (sts_fsaS _ (wp_fsa _)) with (N0:=N) (γ0:=γ); simpl;
      eauto with I ndisj.
299
    rewrite !assoc [(_  sts_ownS _ _ _)%I]comm -!assoc. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
300
301
302
    apply forall_intro=>-[p I]. apply wand_intro_l. rewrite -!assoc.
    apply const_elim_sep_l=>Hs. destruct p; last done.
    rewrite {1}/barrier_inv =>/={Hs}. rewrite later_sep.
Ralf Jung's avatar
Ralf Jung committed
303
    eapply wp_store with (v' := '0); eauto with I ndisj. 
304
    u_strip_later. cancel [l  '0]%I.
Ralf Jung's avatar
Ralf Jung committed
305
    apply wand_intro_l. rewrite -(exist_intro (State High I)).
Robbert Krebbers's avatar
Robbert Krebbers committed
306
    rewrite -(exist_intro ). rewrite const_equiv /=; last by eauto using signal_step.
Ralf Jung's avatar
Ralf Jung committed
307
308
309
310
    rewrite left_id -later_intro {2}/barrier_inv -!assoc. apply sep_mono_r.
    rewrite !assoc [(_  P)%I]comm !assoc -2!assoc.
    apply sep_mono; last first.
    { apply wand_intro_l. eauto with I. }
Ralf Jung's avatar
Ralf Jung committed
311
    (* Now we come to the core of the proof: Updating from waiting to ress. *)
312
    rewrite /waiting /ress sep_exist_l. apply exist_elim=>{Φ} Φ.
Ralf Jung's avatar
Ralf Jung committed
313
    rewrite later_wand {1}(later_intro P) !assoc wand_elim_r.
Robbert Krebbers's avatar
Robbert Krebbers committed
314
    rewrite big_sepS_later -big_sepS_sepS. apply big_sepS_mono'=>i.
Robbert Krebbers's avatar
Robbert Krebbers committed
315
    by rewrite -(exist_intro (Φ i)) comm.
Ralf Jung's avatar
Ralf Jung committed
316
  Qed.
Ralf Jung's avatar
Ralf Jung committed
317

318
  Lemma wait_spec l P (Φ : val  iProp) :
319
    (recv l P  (P - Φ '()))  || wait (LocV l) {{ Φ }}.
Ralf Jung's avatar
Ralf Jung committed
320
  Proof.
321
    rename P into R. wp_rec.
Ralf Jung's avatar
Ralf Jung committed
322
323
324
    rewrite {1}/recv /barrier_ctx. rewrite !sep_exist_r.
    apply exist_elim=>γ. rewrite !sep_exist_r. apply exist_elim=>P.
    rewrite !sep_exist_r. apply exist_elim=>Q. rewrite !sep_exist_r.
325
326
    apply exist_elim=>i. rewrite -!assoc. apply const_elim_sep_l=>?.
    wp_focus (! _)%L.
Ralf Jung's avatar
Ralf Jung committed
327
328
329
    (* I think some evars here are better than repeating *everything* *)
    eapply (sts_fsaS _ (wp_fsa _)) with (N0:=N) (γ0:=γ); simpl;
      eauto with I ndisj.
330
    rewrite !assoc [(_  sts_ownS _ _ _)%I]comm -!assoc. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
331
    apply forall_intro=>-[p I]. apply wand_intro_l. rewrite -!assoc.
Ralf Jung's avatar
Ralf Jung committed
332
333
334
    apply const_elim_sep_l=>Hs.
    rewrite {1}/barrier_inv =>/=. rewrite later_sep.
    eapply wp_load; eauto with I ndisj.
335
    rewrite -!assoc. apply sep_mono_r. u_strip_later.
Ralf Jung's avatar
Ralf Jung committed
336
337
338
    apply wand_intro_l. destruct p.
    { (* a Low state. The comparison fails, and we recurse. *)
      rewrite -(exist_intro (State Low I)) -(exist_intro {[ Change i ]}).
339
      rewrite [( sts.steps _ _ )%I]const_equiv /=; last by apply rtc_refl.
Ralf Jung's avatar
Ralf Jung committed
340
341
      rewrite left_id -[( barrier_inv _ _ _)%I]later_intro {3}/barrier_inv.
      rewrite -!assoc. apply sep_mono_r, sep_mono_r, wand_intro_l.
342
      wp_op; first done. intros _. wp_if. rewrite !assoc.
343
      rewrite -always_wand_impl always_elim.
Ralf Jung's avatar
Ralf Jung committed
344
      rewrite -{2}pvs_wp. apply pvs_wand_r.
Ralf Jung's avatar
Ralf Jung committed
345
      rewrite -(exist_intro γ) -(exist_intro P) -(exist_intro Q) -(exist_intro i).
346
347
      rewrite !assoc.
      do 3 (rewrite -pvs_frame_r; apply sep_mono; last (try apply later_intro; reflexivity)).
348
349
      rewrite [(_  heap_ctx _)%I]comm -!assoc.
      rewrite const_equiv // left_id -pvs_frame_l. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
350
      rewrite comm -pvs_frame_l. apply sep_mono_r.
Robbert Krebbers's avatar
Robbert Krebbers committed
351
      apply sts_own_weaken; eauto using i_states_closed. }
Ralf Jung's avatar
Ralf Jung committed
352
353
    (* a High state: the comparison succeeds, and we perform a transition and
       return to the client *)
354
    rewrite [(_   (_  _ ))%I]sep_elim_l.
Ralf Jung's avatar
Ralf Jung committed
355
356
    rewrite -(exist_intro (State High (I  {[ i ]}))) -(exist_intro ).
    change (i  I) in Hs.
Robbert Krebbers's avatar
Robbert Krebbers committed
357
    rewrite const_equiv /=; last by eauto using wait_step.
Ralf Jung's avatar
Ralf Jung committed
358
359
360
361
362
363
364
    rewrite left_id -[( barrier_inv _ _ _)%I]later_intro {2}/barrier_inv.
    rewrite -!assoc. apply sep_mono_r. rewrite /ress.
    rewrite (big_sepS_delete _ I i) // [(_  Π★{set _} _)%I]comm -!assoc.
    apply sep_mono_r. rewrite !sep_exist_r. apply exist_elim=>Q'.
    apply wand_intro_l. rewrite [(heap_ctx _  _)%I]sep_elim_r.
    rewrite [(sts_own _ _ _  _)%I]sep_elim_r [(sts_ctx _ _ _  _)%I]sep_elim_r.
    rewrite !assoc [(_  saved_prop_own i Q)%I]comm !assoc saved_prop_agree.
365
    wp_op>; last done. intros _. u_strip_later.
366
    wp_if. 
Ralf Jung's avatar
Ralf Jung committed
367
368
369
370
    eapply wand_apply_r; [done..|]. eapply wand_apply_r; [done..|].
    apply: (eq_rewrite Q' Q (λ x, x)%I); last by eauto with I.
    rewrite eq_sym. eauto with I.
  Qed.
Ralf Jung's avatar
Ralf Jung committed
371

Ralf Jung's avatar
Ralf Jung committed
372
  Lemma recv_split l P1 P2 Φ :
373
    (recv l (P1  P2)  (recv l P1  recv l P2 - Φ '()))  || Skip {{ Φ }}.
Ralf Jung's avatar
Ralf Jung committed
374
  Proof.
Ralf Jung's avatar
Ralf Jung committed
375
376
377
378
    rename P1 into R1. rename P2 into R2.
    rewrite {1}/recv /barrier_ctx. rewrite sep_exist_r.
    apply exist_elim=>γ. rewrite sep_exist_r.  apply exist_elim=>P. 
    rewrite sep_exist_r.  apply exist_elim=>Q. rewrite sep_exist_r.
379
    apply exist_elim=>i. rewrite -!assoc. apply const_elim_sep_l=>?. rewrite -wp_pvs.
Ralf Jung's avatar
Ralf Jung committed
380
381
382
    (* I think some evars here are better than repeating *everything* *)
    eapply (sts_fsaS _ (wp_fsa _)) with (N0:=N) (γ0:=γ); simpl;
      eauto with I ndisj.
Ralf Jung's avatar
Ralf Jung committed
383
    rewrite !assoc [(_  sts_ownS _ _ _)%I]comm -!assoc. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
384
    apply forall_intro=>-[p I]. apply wand_intro_l. rewrite -!assoc.
Ralf Jung's avatar
Ralf Jung committed
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
    apply const_elim_sep_l=>Hs. rewrite -wp_pvs. wp_seq.
    eapply sep_elim_True_l.
    { eapply saved_prop_alloc_strong with (P0 := R1) (G := I). }
    rewrite pvs_frame_r. apply pvs_strip_pvs. rewrite sep_exist_r.
    apply exist_elim=>i1. rewrite always_and_sep_l. rewrite -assoc.
    apply const_elim_sep_l=>Hi1. eapply sep_elim_True_l.
    { eapply saved_prop_alloc_strong with (P0 := R2) (G := I  {[ i1 ]}). }
    rewrite pvs_frame_r. apply pvs_mono. rewrite sep_exist_r.
    apply exist_elim=>i2. rewrite always_and_sep_l. rewrite -assoc.
    apply const_elim_sep_l=>Hi2.
    rewrite ->not_elem_of_union, elem_of_singleton in Hi2.
    destruct Hi2 as [Hi2 Hi12]. change (i  I) in Hs. destruct p.
    (* Case I: Low state. *)
    - rewrite -(exist_intro (State Low ({[i1]}  ({[i2]}  (I  {[i]}))))).
      rewrite -(exist_intro ({[Change i1 ]}  {[ Change i2 ]})).
Robbert Krebbers's avatar
Robbert Krebbers committed
400
      rewrite [( sts.steps _ _)%I]const_equiv; last by eauto using split_step.
Ralf Jung's avatar
Ralf Jung committed
401
402
403
404
405
      rewrite left_id -later_intro {1 3}/barrier_inv.
      (* FIXME ssreflect rewrite fails if there are evars around. Also, this is very slow because we don't have a proof mode. *)
      rewrite -(waiting_split _ _ _ Q R1 R2); [|done..].
      rewrite {1}[saved_prop_own i1 _]always_sep_dup.
      rewrite {1}[saved_prop_own i2 _]always_sep_dup.
406
407
      ecancel [l  _; saved_prop_own i1 _; saved_prop_own i2 _; waiting _ _;
               _ - _; saved_prop_own i _]%I. 
408
409
410
411
412
413
      apply wand_intro_l. rewrite !assoc. eapply pvs_wand_r. rewrite /recv.
      rewrite -(exist_intro γ) -(exist_intro P) -(exist_intro R1) -(exist_intro i1).
      rewrite -(exist_intro γ) -(exist_intro P) -(exist_intro R2) -(exist_intro i2).
      do 2 rewrite !(assoc ()%I) [(_  sts_ownS _ _ _)%I]comm.
      rewrite -!assoc. rewrite [(sts_ownS _ _ _  _  _)%I]assoc -pvs_frame_r.
      apply sep_mono.
Robbert Krebbers's avatar
Robbert Krebbers committed
414
415
416
417
      * rewrite -sts_ownS_op; eauto using i_states_closed.
        + apply sts_own_weaken; eauto using sts.closed_op, i_states_closed.
          rewrite !mkSet_elem_of; set_solver.
        + set_solver.
418
      * rewrite const_equiv // !left_id.
Ralf Jung's avatar
Ralf Jung committed
419
        rewrite {1}[heap_ctx _]always_sep_dup {1}[sts_ctx _ _ _]always_sep_dup.
Robbert Krebbers's avatar
Robbert Krebbers committed
420
        rewrite !wand_diag -!later_intro. solve_sep_entails.
Ralf Jung's avatar
Ralf Jung committed
421
(* Case II: High state. TODO: Lots of this script is just copy-n-paste of the previous one.
422
423
   Most of that is because the goals are fairly similar in structure, and the proof scripts
   are mostly concerned with manually managaing the structure (assoc, comm, dup) of
Ralf Jung's avatar
Ralf Jung committed
424
425
426
   the context. *)
    - rewrite -(exist_intro (State High ({[i1]}  ({[i2]}  (I  {[i]}))))).
      rewrite -(exist_intro ({[Change i1 ]}  {[ Change i2 ]})).
Robbert Krebbers's avatar
Robbert Krebbers committed
427
      rewrite const_equiv; last by eauto using split_step.
Ralf Jung's avatar
Ralf Jung committed
428
429
430
431
      rewrite left_id -later_intro {1 3}/barrier_inv.
      rewrite -(ress_split _ _ _ Q R1 R2); [|done..].
      rewrite {1}[saved_prop_own i1 _]always_sep_dup.
      rewrite {1}[saved_prop_own i2 _]always_sep_dup.
432
433
      ecancel [l  _; saved_prop_own i1 _; saved_prop_own i2 _; ress _;
               _ - _; saved_prop_own i _]%I. 
434
435
436
437
438
439
      apply wand_intro_l. rewrite !assoc. eapply pvs_wand_r. rewrite /recv.
      rewrite -(exist_intro γ) -(exist_intro P) -(exist_intro R1) -(exist_intro i1).
      rewrite -(exist_intro γ) -(exist_intro P) -(exist_intro R2) -(exist_intro i2).
      do 2 rewrite !(assoc ()%I) [(_  sts_ownS _ _ _)%I]comm.
      rewrite -!assoc. rewrite [(sts_ownS _ _ _  _  _)%I]assoc -pvs_frame_r.
      apply sep_mono.
Robbert Krebbers's avatar
Robbert Krebbers committed
440
441
442
443
      * rewrite -sts_ownS_op; eauto using i_states_closed.
        + apply sts_own_weaken; eauto using sts.closed_op, i_states_closed.
          rewrite !mkSet_elem_of; set_solver.
        + set_solver.
444
      * rewrite const_equiv // !left_id.
Ralf Jung's avatar
Ralf Jung committed
445
        rewrite {1}[heap_ctx _]always_sep_dup {1}[sts_ctx _ _ _]always_sep_dup.
Robbert Krebbers's avatar
Robbert Krebbers committed
446
        rewrite !wand_diag -!later_intro. solve_sep_entails.
Ralf Jung's avatar
Ralf Jung committed
447
  Qed.
Ralf Jung's avatar
Ralf Jung committed
448
449
450
451

  Lemma recv_strengthen l P1 P2 :
    (P1 - P2)  (recv l P1 - recv l P2).
  Proof.
Ralf Jung's avatar
Ralf Jung committed
452
453
454
    apply wand_intro_l. rewrite /recv. rewrite sep_exist_r. apply exist_mono=>γ.
    rewrite sep_exist_r. apply exist_mono=>P. rewrite sep_exist_r.
    apply exist_mono=>Q. rewrite sep_exist_r. apply exist_mono=>i.
455
    rewrite -!assoc. apply sep_mono_r, sep_mono_r, sep_mono_r, sep_mono_r, sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
456
    rewrite (later_intro (P1 - _)%I) -later_sep. apply later_mono.
Robbert Krebbers's avatar
Robbert Krebbers committed
457
    apply wand_intro_l. by rewrite !assoc wand_elim_r wand_elim_r.
Ralf Jung's avatar
Ralf Jung committed
458
  Qed.
459
End proof.
460
461

Section spec.
462
  Context {Σ : iFunctorG} `{!heapG Σ} `{!barrierG Σ}. 
463
464
465
466
467
468

  Local Notation iProp := (iPropG heap_lang Σ).

  (* TODO: Maybe notation for LocV (and Loc)? *)
  Lemma barrier_spec (heapN N : namespace) :
    heapN  N 
Robbert Krebbers's avatar
Robbert Krebbers committed
469
     recv send : loc -> iProp -n> iProp,
470
      ( P, heap_ctx heapN  {{ True }} newchan '() {{ λ v,  l, v = LocV l  recv l P  send l P }}) 
471
472
473
      ( l P, {{ send l P  P }} signal (LocV l) {{ λ _, True }}) 
      ( l P, {{ recv l P }} wait (LocV l) {{ λ _, P }}) 
      ( l P Q, {{ recv l (P  Q) }} Skip {{ λ _, recv l P  recv l Q }}) 
474
475
      ( l P Q, (P - Q)  (recv l P - recv l Q)).
  Proof.
Robbert Krebbers's avatar
Robbert Krebbers committed
476
477
478
479
480
481
482
483
484
485
486
    intros HN.
    exists (λ l, CofeMor (recv heapN N l)), (λ l, CofeMor (send heapN N l)).
    split_and?; simpl.
    - intros P. apply: always_intro. apply impl_intro_r.
      rewrite -(newchan_spec heapN N P) // always_and_sep_r.
      apply sep_mono_r, forall_intro=>l; apply wand_intro_l.
      by rewrite right_id -(exist_intro l) const_equiv // left_id.
    - intros l P. apply ht_alt. by rewrite -signal_spec right_id.
    - intros l P. apply ht_alt.
      by rewrite -(wait_spec heapN N l P) wand_diag right_id.
    - intros l P Q. apply ht_alt. rewrite -(recv_split heapN N l P Q).
Ralf Jung's avatar
Ralf Jung committed
487
      apply sep_intro_True_r; first done. apply wand_intro_l. eauto with I.
Robbert Krebbers's avatar
Robbert Krebbers committed
488
    - intros l P Q. apply recv_strengthen.
Ralf Jung's avatar
Ralf Jung committed
489
  Qed.
490
End spec.