barrier.v 25.8 KB
Newer Older
Ralf Jung's avatar
Ralf Jung committed
1
From prelude Require Export functions.
2
From algebra Require Export upred_big_op.
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
17
  Inductive phase := Low | High.
  Record stateT := State { state_phase : phase; state_I : gset gname }.
18
19
  Inductive token := Change (i : gname) | Send.

20
21
22
  Global Instance stateT_inhabited: Inhabited stateT.
  Proof. split. exact (State Low ). Qed.

23
  Definition change_tokens (I : gset gname) : set token :=
Ralf Jung's avatar
Ralf Jung committed
24
    mkSet (λ t, match t with Change i => i  I | Send => False end).
25

26
27
28
  Inductive trans : relation stateT :=
  | ChangeI p I2 I1 : trans (State p I1) (State p I2)
  | ChangePhase I : trans (State Low I) (State High I).
29

30
31
32
  Definition tok (s : stateT) : set token :=
      change_tokens (state_I s)
     match state_phase s with Low =>  | High => {[ Send ]} end.
33

Robbert Krebbers's avatar
Robbert Krebbers committed
34
  Canonical Structure sts := sts.STS trans tok.
35

36
  (* The set of states containing some particular i *)
37
38
39
40
  Definition i_states (i : gname) : set stateT :=
    mkSet (λ s, i  state_I s).

  Lemma i_states_closed i :
Robbert Krebbers's avatar
Robbert Krebbers committed
41
    sts.closed (i_states i) {[ Change i ]}.
42
43
  Proof.
    split.
Ralf Jung's avatar
Ralf Jung committed
44
    - move=>[p I]. rewrite /= /tok !mkSet_elem_of /= =>HI.
45
      destruct p; set_solver.
46
47
48
49
50
    - (* 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". *)
      move=>s1 s2. rewrite !mkSet_elem_of /==> Hs1 Hstep.
Ralf Jung's avatar
Ralf Jung committed
51
      inversion_clear Hstep as [T1 T2 Hdisj Hstep'].
52
53
      inversion_clear Hstep' as [? ? ? ? Htrans _ _ Htok].
      destruct Htrans; last done; move:Hs1 Hdisj Htok.
54
55
      rewrite /= /tok /=. 
      (* TODO: Can this be done better? *)
Ralf Jung's avatar
Ralf Jung committed
56
57
      intros. apply dec_stable. 
      assert (Change i  change_tokens I1) as HI1
58
        by (rewrite mkSet_not_elem_of; set_solver +Hs1).
Ralf Jung's avatar
Ralf Jung committed
59
60
      assert (Change i  change_tokens I2) as HI2.
      { destruct p.
61
62
        - set_solver +Htok Hdisj HI1.
        - set_solver +Htok Hdisj HI1 / discriminate. }
Ralf Jung's avatar
Ralf Jung committed
63
64
      done.
  Qed.
65
66
67
68

  (* The set of low states *)
  Definition low_states : set stateT :=
    mkSet (λ s, if state_phase s is Low then True else False).
69
70

  Lemma low_states_closed : sts.closed low_states {[ Send ]}.
71
72
73
  Proof.
    split.
    - move=>[p I]. rewrite /= /tok !mkSet_elem_of /= =>HI.
74
      destruct p; set_solver.
75
76
77
78
79
    - move=>s1 s2. rewrite !mkSet_elem_of /==> Hs1 Hstep.
      inversion_clear Hstep as [T1 T2 Hdisj Hstep'].
      inversion_clear Hstep' as [? ? ? ? Htrans _ _ Htok].
      destruct Htrans; move:Hs1 Hdisj Htok =>/=;
                                first by destruct p.
80
      rewrite /= /tok /=. intros. set_solver +Hdisj Htok.
81
82
  Qed.

83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
  (* Proof that we can take the steps we need. *)
  Lemma signal_step I:
    sts.steps (State Low I, {[Send]}) (State High I, ).
  Proof.
    apply rtc_once. constructor; first constructor;
                        rewrite /= /tok /=; set_solver.
  Qed.

  Lemma wait_step i I :
    i  I  sts.steps (State High I, {[ Change i ]}) (State High (I  {[ i ]}), ).
  Proof.
    intros. apply rtc_once.
    constructor; first constructor; rewrite /= /tok /=; [set_solver..|].
    (* TODO this proof is rather annoying. *)
    apply elem_of_equiv=>t. rewrite !elem_of_union.
    rewrite !mkSet_elem_of /change_tokens /=.
99
    destruct t as [j|]; last set_solver.
100
    rewrite elem_of_difference elem_of_singleton.
101
    destruct (decide (i = j)); set_solver.
102
103
104
105
106
107
108
109
110
111
112
  Qed.
    
  Lemma split_step p i i1 i2 I :
    i  I  i1  I  i2  I  i1  i2 
    sts.steps (State p I, {[ Change i ]})
        (State p ({[i1]}  ({[i2]}  (I  {[i]}))), {[ Change i1; Change i2 ]}).
  Proof.
    intros. apply rtc_once.
    constructor; first constructor; rewrite /= /tok /=; first (destruct p; set_solver).
    (* 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.
113
      rewrite !mkSet_elem_of. destruct p; set_solver.
114
    - apply elem_of_equiv=>t. destruct t as [j|]; last set_solver.
115
116
117
118
      rewrite !mkSet_elem_of.
      destruct (decide (i1 = j)); first set_solver. 
      destruct (decide (i2 = j)); first set_solver.
      destruct (decide (i = j)); set_solver.
119
120
  Qed.

121
End barrier_proto.
122
123
124
125
126
127
(* 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.
128

129
130
131
(* The functors we need. *)
Definition barrierFs := stsF sts `::` agreeF `::` pnil.

132
133
134
(** Now we come to the Iris part of the proof. *)
Section proof.
  Context {Σ : iFunctorG} (N : namespace).
Ralf Jung's avatar
Ralf Jung committed
135
  Context `{heapG Σ} (heapN : namespace).
136
137
  Context `{stsG heap_lang Σ sts}.
  Context `{savedPropG heap_lang Σ}.
Ralf Jung's avatar
Ralf Jung committed
138

139
140
141
142
  Local Hint Immediate i_states_closed low_states_closed : sts.
  Local Hint Resolve signal_step wait_step split_step : sts.
  Local Hint Resolve sts.closed_op : sts.

143
144
145
  Hint Extern 50 (_  _) => try rewrite !mkSet_elem_of; set_solver : sts.
  Hint Extern 50 (_  _) => try rewrite !mkSet_elem_of; set_solver : sts.
  Hint Extern 50 (_  _) => try rewrite !mkSet_elem_of; set_solver : sts.
Ralf Jung's avatar
Ralf Jung committed
146

147
  Local Notation iProp := (iPropG heap_lang Σ).
148
149

  Definition waiting (P : iProp) (I : gset gname) : iProp :=
150
151
    ( Ψ : gname  iProp, (P - Π★{set I} (λ i, Ψ i)) 
                             Π★{set I} (λ i, saved_prop_own i (Ψ i)))%I.
152
153

  Definition ress (I : gset gname) : iProp :=
154
    (Π★{set I} (λ i,  R, saved_prop_own i R  R))%I.
155

156
157
  Local Notation state_to_val s :=
    (match s with State Low _ => 0 | State High _ => 1 end).
158
  Definition barrier_inv (l : loc) (P : iProp) (s : stateT) : iProp :=
159
    (l  '(state_to_val s) 
160
161
     match s with State Low I' => waiting P I' | State High I' => ress I' end
    )%I.
162
163

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

166
167
  Global Instance barrier_ctx_ne n γ l : Proper (dist n ==> dist n) (barrier_ctx γ l).
  Proof.
168
169
    move=>? ? EQ. rewrite /barrier_ctx. apply sep_ne; first done.
    apply sep_ne; first done. apply sts_ctx_ne.
170
171
172
173
    move=>[p I]. rewrite /barrier_inv. destruct p; last done.
    rewrite /waiting. by setoid_rewrite EQ.
  Qed.

174
  Definition send (l : loc) (P : iProp) : iProp :=
175
    ( γ, barrier_ctx γ l P  sts_ownS γ low_states {[ Send ]})%I.
176

177
178
179
180
181
  Global Instance send_ne n l : Proper (dist n ==> dist n) (send l).
  Proof. (* TODO: This really ought to be doable by an automatic tactic. it is just application of already regostered congruence lemmas. *)
    move=>? ? EQ. rewrite /send. apply exist_ne=>γ. by rewrite EQ.
  Qed.

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

186
187
188
189
190
  Global Instance recv_ne n l : Proper (dist n ==> dist n) (recv l).
  Proof.
    move=>? ? EQ. rewrite /send. do 4 apply exist_ne=>?. by rewrite EQ.
  Qed.

Ralf Jung's avatar
Ralf Jung committed
191
192
193
194
195
196
197
198
199
200
  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
201
    rewrite !assoc [(_  _ i _)%I]comm !assoc [(_  _ i _)%I]comm -!assoc.
202
203
    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
204
205
206
207
    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) //.
208
      rewrite [(_  Π★{set _} _)%I]comm [(_  Π★{set _} _)%I]comm -!assoc.
Ralf Jung's avatar
Ralf Jung committed
209
210
211
212
213
214
      apply sep_mono.
      + apply big_sepS_mono; first done. intros j.
        rewrite elem_of_difference not_elem_of_singleton. intros.
        rewrite fn_lookup_insert_ne; last naive_solver.
        rewrite fn_lookup_insert_ne; last naive_solver.
        done.
215
      + rewrite !assoc.
Ralf Jung's avatar
Ralf Jung committed
216
217
218
        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.
219
220
    - rewrite !assoc. apply sep_mono.
      + by rewrite comm.
Ralf Jung's avatar
Ralf Jung committed
221
222
223
224
225
      + apply big_sepS_mono; first done. intros j.
        rewrite elem_of_difference not_elem_of_singleton. intros.
        rewrite fn_lookup_insert_ne; last naive_solver.
        rewrite fn_lookup_insert_ne; last naive_solver.
        done.
Ralf Jung's avatar
Ralf Jung committed
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
  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.
    rewrite big_sepS_insert; last set_solver.
    rewrite big_sepS_insert; last set_solver.
    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.
    { rewrite <-later_wand, <-later_intro. done. }
    { 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
249

250
  Lemma newchan_spec (P : iProp) (Φ : val  iProp) :
251
    heapN  N 
252
    (heap_ctx heapN   l, recv l P  send l P - Φ (LocV l))
253
     || newchan '() {{ Φ }}.
Ralf Jung's avatar
Ralf Jung committed
254
  Proof.
255
    intros HN. rewrite /newchan. wp_seq.
256
    rewrite -wp_pvs. wp eapply wp_alloc; eauto with I ndisj.
Ralf Jung's avatar
Ralf Jung committed
257
258
259
260
261
262
263
    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. *)
    eapply sep_elim_True_r.
    { by eapply (saved_prop_alloc _ P). }
    rewrite pvs_frame_l. apply pvs_strip_pvs. rewrite sep_exist_l.
    apply exist_elim=>i.
264
    trans (pvs   (heap_ctx heapN   (barrier_inv l P (State Low {[ i ]}))   saved_prop_own i P)).
Ralf Jung's avatar
Ralf Jung committed
265
266
267
268
269
270
    - rewrite -pvs_intro. rewrite [(_  heap_ctx _)%I]comm -!assoc. apply sep_mono_r.
      rewrite {1}[saved_prop_own _ _]always_sep_dup !assoc. apply sep_mono_l.
      rewrite /barrier_inv /waiting -later_intro. apply sep_mono_r.
      rewrite -(exist_intro (const P)) /=. rewrite -[saved_prop_own _ _](left_id True%I ()%I).
      apply sep_mono.
      + rewrite -later_intro. apply wand_intro_l. rewrite right_id.
Ralf Jung's avatar
Ralf Jung committed
271
272
        by rewrite big_sepS_singleton.
      + by rewrite big_sepS_singleton.
Ralf Jung's avatar
Ralf Jung committed
273
274
275
276
    - 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
277
278
279
280
      (* TODO: The record notation is rather annoying here *)
      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... *)
Ralf Jung's avatar
Ralf Jung committed
281
      rewrite [barrier_ctx _ _ _]lock !assoc [(_ locked _)%I]comm !assoc -lock.
Ralf Jung's avatar
Ralf Jung committed
282
      rewrite -always_sep_dup.
Ralf Jung's avatar
Ralf Jung committed
283
      rewrite [barrier_ctx _ _ _]lock always_and_sep_l -!assoc assoc -lock.
284
      rewrite -pvs_frame_l. rewrite /barrier_ctx const_equiv // left_id. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
285
286
      rewrite [(saved_prop_own _ _  _)%I]comm !assoc. rewrite -pvs_frame_r.
      apply sep_mono_l.
Ralf Jung's avatar
Ralf Jung committed
287
288
289
      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
290
291
      rewrite (sts_own_weaken  _ _ (i_states i  low_states) _ 
                              ({[ Change i ]}  {[ Send ]})).
292
      + apply pvs_mono. rewrite sts_ownS_op; eauto with sts.
293
294
295
296
      + rewrite /= /tok /=  =>t. rewrite !mkSet_elem_of.
        move=>[[?]|?]; set_solver. 
      + eauto with sts.
      + eauto with sts.
Ralf Jung's avatar
Ralf Jung committed
297
  Qed.
Ralf Jung's avatar
Ralf Jung committed
298

299
  Lemma signal_spec l P (Φ : val  iProp) :
300
    (send l P  P  Φ '())  || signal (LocV l) {{ Φ }}.
Ralf Jung's avatar
Ralf Jung committed
301
  Proof.
302
303
    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
304
    (* I think some evars here are better than repeating *everything* *)
305
306
    eapply (sts_fsaS _ (wp_fsa _)) with (N0:=N) (γ0:=γ); simpl;
      eauto with I ndisj.
307
    rewrite !assoc [(_  sts_ownS _ _ _)%I]comm -!assoc. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
308
309
310
    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.
311
312
    eapply wp_store; eauto with I ndisj. 
    rewrite -!assoc. apply sep_mono_r. u_strip_later.
Ralf Jung's avatar
Ralf Jung committed
313
    apply wand_intro_l. rewrite -(exist_intro (State High I)).
314
    rewrite -(exist_intro ). rewrite const_equiv /=; last by eauto with sts.
Ralf Jung's avatar
Ralf Jung committed
315
316
317
318
    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
319
    (* Now we come to the core of the proof: Updating from waiting to ress. *)
320
    rewrite /waiting /ress sep_exist_l. apply exist_elim=>{Φ} Φ.
Ralf Jung's avatar
Ralf Jung committed
321
    rewrite later_wand {1}(later_intro P) !assoc wand_elim_r.
Robbert Krebbers's avatar
Robbert Krebbers committed
322
    rewrite big_sepS_later -big_sepS_sepS. apply big_sepS_mono'=>i.
323
    rewrite -(exist_intro (Φ i)) comm. done.
Ralf Jung's avatar
Ralf Jung committed
324
  Qed.
Ralf Jung's avatar
Ralf Jung committed
325

326
  Lemma wait_spec l P (Φ : val  iProp) :
327
    (recv l P  (P - Φ '()))  || wait (LocV l) {{ Φ }}.
Ralf Jung's avatar
Ralf Jung committed
328
  Proof.
329
    rename P into R. wp_rec.
Ralf Jung's avatar
Ralf Jung committed
330
331
332
    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.
333
334
    apply exist_elim=>i. rewrite -!assoc. apply const_elim_sep_l=>?.
    wp_focus (! _)%L.
Ralf Jung's avatar
Ralf Jung committed
335
336
337
    (* I think some evars here are better than repeating *everything* *)
    eapply (sts_fsaS _ (wp_fsa _)) with (N0:=N) (γ0:=γ); simpl;
      eauto with I ndisj.
338
    rewrite !assoc [(_  sts_ownS _ _ _)%I]comm -!assoc. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
339
    apply forall_intro=>-[p I]. apply wand_intro_l. rewrite -!assoc.
Ralf Jung's avatar
Ralf Jung committed
340
341
342
    apply const_elim_sep_l=>Hs.
    rewrite {1}/barrier_inv =>/=. rewrite later_sep.
    eapply wp_load; eauto with I ndisj.
343
    rewrite -!assoc. apply sep_mono_r. u_strip_later.
Ralf Jung's avatar
Ralf Jung committed
344
345
346
    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 ]}).
347
      rewrite [( sts.steps _ _ )%I]const_equiv /=; last by apply rtc_refl.
Ralf Jung's avatar
Ralf Jung committed
348
349
      rewrite left_id -[( barrier_inv _ _ _)%I]later_intro {3}/barrier_inv.
      rewrite -!assoc. apply sep_mono_r, sep_mono_r, wand_intro_l.
350
      wp_op; first done. intros _. wp_if. rewrite !assoc.
351
      rewrite -always_wand_impl always_elim.
Ralf Jung's avatar
Ralf Jung committed
352
      rewrite -{2}pvs_wp. apply pvs_wand_r.
Ralf Jung's avatar
Ralf Jung committed
353
      rewrite -(exist_intro γ) -(exist_intro P) -(exist_intro Q) -(exist_intro i).
354
355
      rewrite !assoc.
      do 3 (rewrite -pvs_frame_r; apply sep_mono; last (try apply later_intro; reflexivity)).
356
357
      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
358
      rewrite comm -pvs_frame_l. apply sep_mono_r.
359
      apply sts_ownS_weaken; eauto using sts.up_subseteq with sts. }
Ralf Jung's avatar
Ralf Jung committed
360
361
    (* a High state: the comparison succeeds, and we perform a transition and
       return to the client *)
362
    rewrite [(_   (_  _ ))%I]sep_elim_l.
Ralf Jung's avatar
Ralf Jung committed
363
364
    rewrite -(exist_intro (State High (I  {[ i ]}))) -(exist_intro ).
    change (i  I) in Hs.
365
    rewrite const_equiv /=; last by eauto with sts.
Ralf Jung's avatar
Ralf Jung committed
366
367
368
369
370
371
372
    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.
373
    wp_op>; last done. intros _. u_strip_later.
374
    wp_if. 
Ralf Jung's avatar
Ralf Jung committed
375
376
377
378
    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
379

Ralf Jung's avatar
Ralf Jung committed
380
  Lemma recv_split l P1 P2 Φ :
381
    (recv l (P1  P2)  (recv l P1  recv l P2 - Φ '()))  || Skip {{ Φ }}.
Ralf Jung's avatar
Ralf Jung committed
382
  Proof.
Ralf Jung's avatar
Ralf Jung committed
383
384
385
386
    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.
387
    apply exist_elim=>i. rewrite -!assoc. apply const_elim_sep_l=>?. rewrite -wp_pvs.
Ralf Jung's avatar
Ralf Jung committed
388
389
390
    (* 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
391
    rewrite !assoc [(_  sts_ownS _ _ _)%I]comm -!assoc. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
392
    apply forall_intro=>-[p I]. apply wand_intro_l. rewrite -!assoc.
Ralf Jung's avatar
Ralf Jung committed
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
    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 ]})).
408
      rewrite [( sts.steps _ _)%I]const_equiv; last by eauto with sts.
Ralf Jung's avatar
Ralf Jung committed
409
410
411
412
413
414
      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..].
      match goal with | |- _  ?G => rewrite [G]lock end.
      rewrite {1}[saved_prop_own i1 _]always_sep_dup.
      rewrite {1}[saved_prop_own i2 _]always_sep_dup.
Ralf Jung's avatar
Ralf Jung committed
415
416
      rewrite !assoc [(_  _ i1 _)%I]comm.
      rewrite !assoc [(_  _ i _)%I]comm.
Ralf Jung's avatar
Ralf Jung committed
417
418
419
420
421
422
      rewrite !assoc [(_  (l  _))%I]comm.
      rewrite !assoc [(_  (waiting _ _))%I]comm.
      rewrite !assoc [(_  (Q - _))%I]comm -!assoc 5!assoc.
      unlock. apply sep_mono.
      + (* This should really all be handled automatically. *)
        rewrite !assoc [(_  (l  _))%I]comm -!assoc. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
423
424
425
        rewrite !assoc [(_  _ i2 _)%I]comm -!assoc. apply sep_mono_r.
        rewrite !assoc [(_  _ i1 _)%I]comm -!assoc. apply sep_mono_r.
        rewrite !assoc [(_  _ i _)%I]comm -!assoc. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
426
427
428
429
430
431
432
        done.
      + 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.
433
        * rewrite -sts_ownS_op; by eauto using sts_own_weaken with sts.
434
435
        * rewrite const_equiv // !left_id.
          rewrite {1}[heap_ctx _]always_sep_dup !assoc [(_  heap_ctx _)%I]comm -!assoc. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
436
437
438
439
440
441
442
          rewrite !assoc ![(_  heap_ctx _)%I]comm -!assoc. apply sep_mono_r.
          rewrite {1}[sts_ctx _ _ _]always_sep_dup !assoc [(_  sts_ctx _ _ _)%I]comm -!assoc. apply sep_mono_r.
          rewrite !assoc ![(_  sts_ctx _ _ _)%I]comm -!assoc. apply sep_mono_r.
          rewrite comm. apply sep_mono_r. apply sep_intro_True_l.
          { rewrite -later_intro. apply wand_intro_l. by rewrite right_id. }
          apply sep_intro_True_r; first done.
          { rewrite -later_intro. apply wand_intro_l. by rewrite right_id. }
Ralf Jung's avatar
Ralf Jung committed
443
(* Case II: High state. TODO: Lots of this script is just copy-n-paste of the previous one.
444
445
   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
446
447
448
   the context. *)
    - rewrite -(exist_intro (State High ({[i1]}  ({[i2]}  (I  {[i]}))))).
      rewrite -(exist_intro ({[Change i1 ]}  {[ Change i2 ]})).
449
      rewrite const_equiv; last by eauto with sts.
Ralf Jung's avatar
Ralf Jung committed
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
      rewrite left_id -later_intro {1 3}/barrier_inv.
      rewrite -(ress_split _ _ _ Q R1 R2); [|done..].
      match goal with | |- _  ?G => rewrite [G]lock end.
      rewrite {1}[saved_prop_own i1 _]always_sep_dup.
      rewrite {1}[saved_prop_own i2 _]always_sep_dup.
      rewrite !assoc [(_  _ i1 _)%I]comm.
      rewrite !assoc [(_  _ i _)%I]comm.
      rewrite !assoc [(_  (l  _))%I]comm.
      rewrite !assoc [(_  (ress _))%I]comm.
      rewrite !assoc [(_  (Q - _))%I]comm -!assoc 5!assoc.
      unlock. apply sep_mono.
      + (* This should really all be handled automatically. *)
        rewrite !assoc [(_  (l  _))%I]comm -!assoc. apply sep_mono_r.
        rewrite !assoc [(_  _ i2 _)%I]comm -!assoc. apply sep_mono_r.
        rewrite !assoc [(_  _ i1 _)%I]comm -!assoc. apply sep_mono_r.
        rewrite !assoc [(_  _ i _)%I]comm -!assoc. apply sep_mono_r.
        done.
      + 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.
473
        * rewrite -sts_ownS_op; by eauto using sts_own_weaken with sts.
474
475
        * rewrite const_equiv // !left_id.
          rewrite {1}[heap_ctx _]always_sep_dup !assoc [(_  heap_ctx _)%I]comm -!assoc. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
476
477
478
479
480
481
482
483
          rewrite !assoc ![(_  heap_ctx _)%I]comm -!assoc. apply sep_mono_r.
          rewrite {1}[sts_ctx _ _ _]always_sep_dup !assoc [(_  sts_ctx _ _ _)%I]comm -!assoc. apply sep_mono_r.
          rewrite !assoc ![(_  sts_ctx _ _ _)%I]comm -!assoc. apply sep_mono_r.
          rewrite comm. apply sep_mono_r. apply sep_intro_True_l.
          { rewrite -later_intro. apply wand_intro_l. by rewrite right_id. }
          apply sep_intro_True_r; first done.
          { rewrite -later_intro. apply wand_intro_l. by rewrite right_id. }
  Qed.
Ralf Jung's avatar
Ralf Jung committed
484
485
486
487

  Lemma recv_strengthen l P1 P2 :
    (P1 - P2)  (recv l P1 - recv l P2).
  Proof.
Ralf Jung's avatar
Ralf Jung committed
488
489
490
    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.
491
    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
492
493
494
    rewrite (later_intro (P1 - _)%I) -later_sep. apply later_mono.
    apply wand_intro_l. rewrite !assoc wand_elim_r wand_elim_r. done.
  Qed.
495
496

End proof.
497
498
499
500
501
502
503
504
505
506
507
508
509

Section spec.
  Context {Σ : iFunctorG}.
  Context `{heapG Σ}.
  Context `{stsG heap_lang Σ barrier_proto.sts}.
  Context `{savedPropG heap_lang Σ}.

  Local Notation iProp := (iPropG heap_lang Σ).

  (* TODO: Maybe notation for LocV (and Loc)? *)
  Lemma barrier_spec (heapN N : namespace) :
    heapN  N 
     (recv send : loc -> iProp -n> iProp),
510
511
512
513
      ( P, heap_ctx heapN  ({{ True }} newchan '() {{ λ v,  l, v = LocV l  recv l P  send l P }})) 
      ( 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 }}) 
514
515
516
      ( l P Q, (P - Q)  (recv l P - recv l Q)).
  Proof.
    intros HN. exists (λ l, CofeMor (recv N heapN l)). exists (λ l, CofeMor (send N heapN l)).
517
    split_and?; cbn.
518
    - intros. apply: always_intro. apply impl_intro_l. rewrite -newchan_spec //.
519
      rewrite comm always_and_sep_r. apply sep_mono_r. apply forall_intro=>l.
520
      apply wand_intro_l. rewrite right_id -(exist_intro l) const_equiv // left_id;
521
      done.
522
523
    - intros. apply ht_alt. rewrite -signal_spec. by rewrite right_id.
    - intros. apply ht_alt. rewrite -wait_spec.
Ralf Jung's avatar
Ralf Jung committed
524
      apply sep_intro_True_r; first done. apply wand_intro_l. eauto with I.
Ralf Jung's avatar
Ralf Jung committed
525
526
    - intros. apply ht_alt. rewrite -recv_split.
      apply sep_intro_True_r; first done. apply wand_intro_l. eauto with I.
527
    - intros. apply recv_strengthen.
Ralf Jung's avatar
Ralf Jung committed
528
  Qed.
529
530

End spec.