barrier.v 27.5 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.
44
    - apply (non_empty_inhabited(State Low {[ i ]})). rewrite !mkSet_elem_of /=.
Ralf Jung's avatar
Ralf Jung committed
45
46
47
48
49
      apply lookup_singleton.
    - move=>[p I]. rewrite /= /tok !mkSet_elem_of /= =>HI.
      move=>s' /elem_of_intersection. rewrite !mkSet_elem_of /=.
      move=>[[Htok|Htok] ? ]; subst s'; first done.
      destruct p; done.
50
51
52
53
54
    - (* 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
55
56
      (* We probably want some helper lemmas for this... *)
      inversion_clear Hstep as [T1 T2 Hdisj Hstep'].
57
58
      inversion_clear Hstep' as [? ? ? ? Htrans _ _ Htok].
      destruct Htrans; last done; move:Hs1 Hdisj Htok.
Ralf Jung's avatar
Ralf Jung committed
59
60
61
      rewrite /= /tok /=.
      intros. apply dec_stable. 
      assert (Change i  change_tokens I1) as HI1
62
        by (rewrite mkSet_not_elem_of; set_solver +Hs1).
Ralf Jung's avatar
Ralf Jung committed
63
64
      assert (Change i  change_tokens I2) as HI2.
      { destruct p.
65
66
        - set_solver +Htok Hdisj HI1.
        - set_solver +Htok Hdisj HI1 / discriminate. }
Ralf Jung's avatar
Ralf Jung committed
67
68
      done.
  Qed.
69
70
71
72

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

  Lemma low_states_closed : sts.closed low_states {[ Send ]}.
75
76
77
78
  Proof.
    split.
    - apply (non_empty_inhabited(State Low )). by rewrite !mkSet_elem_of /=.
    - move=>[p I]. rewrite /= /tok !mkSet_elem_of /= =>HI.
79
      destruct p; last done. set_solver.
80
81
82
83
84
    - 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.
85
      rewrite /= /tok /=. intros. set_solver +Hdisj Htok.
86
87
  Qed.

88
End barrier_proto.
89
90
91
92
93
94
(* 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.
95

96
97
98
(** Now we come to the Iris part of the proof. *)
Section proof.
  Context {Σ : iFunctorG} (N : namespace).
Ralf Jung's avatar
Ralf Jung committed
99
  Context `{heapG Σ} (heapN : namespace).
100
101
  Context `{stsG heap_lang Σ sts}.
  Context `{savedPropG heap_lang Σ}.
Ralf Jung's avatar
Ralf Jung committed
102

Ralf Jung's avatar
Ralf Jung committed
103
104
  Local Hint Immediate i_states_closed low_states_closed.

105
  Local Notation iProp := (iPropG heap_lang Σ).
106
107

  Definition waiting (P : iProp) (I : gset gname) : iProp :=
108
109
    ( Ψ : gname  iProp, (P - Π★{set I} (λ i, Ψ i)) 
                             Π★{set I} (λ i, saved_prop_own i (Ψ i)))%I.
110
111

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

114
115
  Local Notation state_to_val s :=
    (match s with State Low _ => 0 | State High _ => 1 end).
116
  Definition barrier_inv (l : loc) (P : iProp) (s : stateT) : iProp :=
117
    (l  '(state_to_val s) 
118
119
     match s with State Low I' => waiting P I' | State High I' => ress I' end
    )%I.
120
121

  Definition barrier_ctx (γ : gname) (l : loc) (P : iProp) : iProp :=
Ralf Jung's avatar
Ralf Jung committed
122
    (heap_ctx heapN  sts_ctx γ N (barrier_inv l P))%I.
123

124
125
126
127
128
129
130
  Global Instance barrier_ctx_ne n γ l : Proper (dist n ==> dist n) (barrier_ctx γ l).
  Proof.
    move=>? ? EQ. rewrite /barrier_ctx. apply sep_ne; first done. apply sts_ctx_ne.
    move=>[p I]. rewrite /barrier_inv. destruct p; last done.
    rewrite /waiting. by setoid_rewrite EQ.
  Qed.

131
  Definition send (l : loc) (P : iProp) : iProp :=
132
    ( γ, barrier_ctx γ l P  sts_ownS γ low_states {[ Send ]})%I.
133

134
135
136
137
138
  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.

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

143
144
145
146
147
  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
148
149
150
151
152
153
154
155
156
157
  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
158
    rewrite !assoc [(_  _ i _)%I]comm !assoc [(_  _ i _)%I]comm -!assoc.
Ralf Jung's avatar
Ralf Jung committed
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
    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) //.
      rewrite big_sepS_insert; last set_solver.
      rewrite big_sepS_insert; last set_solver.
      rewrite [(_  Π★{set _} _)%I]comm !assoc [(_  Π★{set _} _)%I]comm -!assoc.
      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.
      + rewrite !fn_lookup_insert fn_lookup_insert_ne // !fn_lookup_insert !assoc.
        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.
    - rewrite big_sepS_insert; last set_solver.
      rewrite big_sepS_insert; last set_solver.
      rewrite !assoc. apply sep_mono.
      + rewrite !fn_lookup_insert fn_lookup_insert_ne // !fn_lookup_insert comm.
        done.
      + 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
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
  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
209

210
211
  Lemma newchan_spec (P : iProp) (Φ : val  iProp) :
    (heap_ctx heapN   l, recv l P  send l P - Φ (LocV l))
212
     || newchan '() {{ Φ }}.
Ralf Jung's avatar
Ralf Jung committed
213
  Proof.
214
    rewrite /newchan. wp_seq.
215
    rewrite -wp_pvs. wp eapply wp_alloc; eauto with I ndisj.
Ralf Jung's avatar
Ralf Jung committed
216
217
218
219
220
221
222
    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.
223
    trans (pvs   (heap_ctx heapN   (barrier_inv l P (State Low {[ i ]}))   saved_prop_own i P)).
Ralf Jung's avatar
Ralf Jung committed
224
225
226
227
228
229
    - 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
230
231
        by rewrite big_sepS_singleton.
      + by rewrite big_sepS_singleton.
Ralf Jung's avatar
Ralf Jung committed
232
233
234
235
    - 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
236
237
238
239
      (* 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
240
      rewrite [barrier_ctx _ _ _]lock !assoc [(_ locked _)%I]comm !assoc -lock.
Ralf Jung's avatar
Ralf Jung committed
241
      rewrite -always_sep_dup.
Ralf Jung's avatar
Ralf Jung committed
242
243
      rewrite [barrier_ctx _ _ _]lock always_and_sep_l -!assoc assoc -lock.
      rewrite -pvs_frame_l. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
244
245
      rewrite [(saved_prop_own _ _  _)%I]comm !assoc. rewrite -pvs_frame_r.
      apply sep_mono_l.
Ralf Jung's avatar
Ralf Jung committed
246
247
248
      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
249
250
      rewrite (sts_own_weaken  _ _ (i_states i  low_states) _ 
                              ({[ Change i ]}  {[ Send ]})).
Ralf Jung's avatar
Ralf Jung committed
251
      + apply pvs_mono. rewrite sts_ownS_op; eauto; []. set_solver.
Ralf Jung's avatar
Ralf Jung committed
252
      (* TODO the rest of this proof is rather annoying. *)
Ralf Jung's avatar
Ralf Jung committed
253
254
      + rewrite /= /tok /=. apply elem_of_equiv=>t.
        rewrite elem_of_difference elem_of_union.
Ralf Jung's avatar
Ralf Jung committed
255
        rewrite !mkSet_elem_of /change_tokens.
256
        (* TODO: destruct t; set_solver does not work. What is the best way to do on? *)
Ralf Jung's avatar
Ralf Jung committed
257
258
        destruct t as [i'|]; last by naive_solver. split.
        * move=>[_ Hn]. left. destruct (decide (i = i')); first by subst i.
259
260
261
          exfalso. apply Hn. left. set_solver.
        * move=>[[EQ]|?]; last discriminate. set_solver. 
      + apply elem_of_intersection. rewrite !mkSet_elem_of /=. set_solver.
Ralf Jung's avatar
Ralf Jung committed
262
      + apply sts.closed_op; eauto; first set_solver; [].
Ralf Jung's avatar
Ralf Jung committed
263
264
        apply (non_empty_inhabited (State Low {[ i ]})).
        apply elem_of_intersection.
Ralf Jung's avatar
Ralf Jung committed
265
        rewrite !mkSet_elem_of /=. set_solver.
Ralf Jung's avatar
Ralf Jung committed
266
  Qed.
Ralf Jung's avatar
Ralf Jung committed
267

268
  Lemma signal_spec l P (Φ : val  iProp) :
269
    heapN  N  (send l P  P  Φ '())  || signal (LocV l) {{ Φ }}.
Ralf Jung's avatar
Ralf Jung committed
270
  Proof.
271
    intros Hdisj. rewrite /signal /send /barrier_ctx. rewrite sep_exist_r.
272
    apply exist_elim=>γ. wp_let.
Ralf Jung's avatar
Ralf Jung committed
273
    (* I think some evars here are better than repeating *everything* *)
274
275
    eapply (sts_fsaS _ (wp_fsa _)) with (N0:=N) (γ0:=γ); simpl;
      eauto with I ndisj.
276
    rewrite [(_  sts_ownS _ _ _)%I]comm -!assoc. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
277
278
279
    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.
280
281
    eapply wp_store; eauto with I ndisj. 
    rewrite -!assoc. apply sep_mono_r. u_strip_later.
Ralf Jung's avatar
Ralf Jung committed
282
283
    apply wand_intro_l. rewrite -(exist_intro (State High I)).
    rewrite -(exist_intro ). rewrite const_equiv /=; last first.
Ralf Jung's avatar
Ralf Jung committed
284
285
    { apply rtc_once. constructor; first constructor;
                        rewrite /= /tok /=; set_solver. }
Ralf Jung's avatar
Ralf Jung committed
286
287
288
289
    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
290
    (* Now we come to the core of the proof: Updating from waiting to ress. *)
291
    rewrite /waiting /ress sep_exist_l. apply exist_elim=>{Φ} Φ.
Ralf Jung's avatar
Ralf Jung committed
292
    rewrite later_wand {1}(later_intro P) !assoc wand_elim_r.
Robbert Krebbers's avatar
Robbert Krebbers committed
293
    rewrite big_sepS_later -big_sepS_sepS. apply big_sepS_mono'=>i.
294
    rewrite -(exist_intro (Φ i)) comm. done.
Ralf Jung's avatar
Ralf Jung committed
295
  Qed.
Ralf Jung's avatar
Ralf Jung committed
296

297
  Lemma wait_spec l P (Φ : val  iProp) :
298
    heapN  N  (recv l P  (P - Φ '()))  || wait (LocV l) {{ Φ }}.
Ralf Jung's avatar
Ralf Jung committed
299
  Proof.
Ralf Jung's avatar
Ralf Jung committed
300
    rename P into R. intros Hdisj. wp_rec.
Ralf Jung's avatar
Ralf Jung committed
301
302
303
    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.
Ralf Jung's avatar
Ralf Jung committed
304
    apply exist_elim=>i. wp_focus (! _)%L.
Ralf Jung's avatar
Ralf Jung committed
305
306
307
    (* I think some evars here are better than repeating *everything* *)
    eapply (sts_fsaS _ (wp_fsa _)) with (N0:=N) (γ0:=γ); simpl;
      eauto with I ndisj.
308
    rewrite !assoc [(_  sts_ownS _ _ _)%I]comm -!assoc. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
309
    apply forall_intro=>-[p I]. apply wand_intro_l. rewrite -!assoc.
Ralf Jung's avatar
Ralf Jung committed
310
311
312
    apply const_elim_sep_l=>Hs.
    rewrite {1}/barrier_inv =>/=. rewrite later_sep.
    eapply wp_load; eauto with I ndisj.
313
    rewrite -!assoc. apply sep_mono_r. u_strip_later.
Ralf Jung's avatar
Ralf Jung committed
314
315
316
317
318
319
    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 ]}).
      rewrite const_equiv /=; last by apply rtc_refl.
      rewrite left_id -[( barrier_inv _ _ _)%I]later_intro {3}/barrier_inv.
      rewrite -!assoc. apply sep_mono_r, sep_mono_r, wand_intro_l.
320
      wp_op; first done. intros _. wp_if. rewrite !assoc.
321
      rewrite -always_wand_impl always_elim.
Ralf Jung's avatar
Ralf Jung committed
322
      rewrite -{2}pvs_wp. apply pvs_wand_r.
Ralf Jung's avatar
Ralf Jung committed
323
      rewrite -(exist_intro γ) -(exist_intro P) -(exist_intro Q) -(exist_intro i).
324
325
      rewrite !assoc.
      do 3 (rewrite -pvs_frame_r; apply sep_mono; last (try apply later_intro; reflexivity)).
Ralf Jung's avatar
Ralf Jung committed
326
327
328
329
330
      rewrite [(_  heap_ctx _)%I]comm -!assoc -pvs_frame_l. apply sep_mono_r.
      rewrite comm -pvs_frame_l. apply sep_mono_r.
      apply sts_ownS_weaken; eauto using sts.up_subseteq. }
    (* a High state: the comparison succeeds, and we perform a transition and
       return to the client *)
331
    rewrite [(_   (_  _ ))%I]sep_elim_l.
Ralf Jung's avatar
Ralf Jung committed
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
    rewrite -(exist_intro (State High (I  {[ i ]}))) -(exist_intro ).
    change (i  I) in Hs.
    rewrite const_equiv /=; last first.
    { 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 /=.
      destruct t as [j|]; last naive_solver.
      rewrite elem_of_difference elem_of_singleton.
      destruct (decide (i = j)); naive_solver. }
    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.
349
    wp_op>; last done. intros _. u_strip_later.
350
    wp_if. 
Ralf Jung's avatar
Ralf Jung committed
351
352
353
354
    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
355

Ralf Jung's avatar
Ralf Jung committed
356
  Lemma recv_split l P1 P2 Φ :
357
    (recv l (P1  P2)  (recv l P1  recv l P2 - Φ '()))  || Skip {{ Φ }}.
Ralf Jung's avatar
Ralf Jung committed
358
  Proof.
Ralf Jung's avatar
Ralf Jung committed
359
360
361
362
    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.
Ralf Jung's avatar
Ralf Jung committed
363
    apply exist_elim=>i. rewrite -wp_pvs.
Ralf Jung's avatar
Ralf Jung committed
364
365
366
    (* 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
367
    rewrite !assoc [(_  sts_ownS _ _ _)%I]comm -!assoc. apply sep_mono_r.
Ralf Jung's avatar
Ralf Jung committed
368
    apply forall_intro=>-[p I]. apply wand_intro_l. rewrite -!assoc.
Ralf Jung's avatar
Ralf Jung committed
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
    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 ]})).
      rewrite const_equiv; last first.
      { apply rtc_once. constructor; first constructor; rewrite /= /tok /=; first 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.
          rewrite !mkSet_elem_of /change_tokens /=.
          rewrite !elem_of_union !elem_of_difference !elem_of_singleton.
          naive_solver.
        - apply elem_of_equiv=>t. destruct t as [j|]; last set_solver.
          rewrite !mkSet_elem_of /change_tokens /=.
          rewrite !elem_of_union !elem_of_difference !elem_of_singleton.
          destruct (decide (i1 = j)); first naive_solver. 
          destruct (decide (i2 = j)); first naive_solver.
          destruct (decide (i = j)); naive_solver. }
      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
403
404
      rewrite !assoc [(_  _ i1 _)%I]comm.
      rewrite !assoc [(_  _ i _)%I]comm.
Ralf Jung's avatar
Ralf Jung committed
405
406
407
408
409
410
      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
411
412
413
        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
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
        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.
        * rewrite -sts_ownS_op; [|set_solver|by eauto..].
          apply sts_own_weaken; first done.
          { rewrite !mkSet_elem_of /=. set_solver+. }
          apply sts.closed_op; [by eauto..|set_solver|].
          apply (non_empty_inhabited (State Low ({[i1]}  ({[i2]}  (I  {[i]}))))).
          rewrite !mkSet_elem_of /=. set_solver+.
        * rewrite {1}[heap_ctx _]always_sep_dup !assoc [(_  heap_ctx _)%I]comm -!assoc. apply sep_mono_r.
          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
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
(* Case II: High state. TODO: Lots of this script is just copy-n-paste of the previous one.
   Some of that ist because stuff should be more trivial than it is (like sts_ownS_op
   having a too strong precondition, see the TODO over there); some of that
   is because the goals a fairly simioar in structure, and the proof scripts
   are mostlx concerned with manually managaing the structure (assoc, comm, dup) of
   the context. *)
    - rewrite -(exist_intro (State High ({[i1]}  ({[i2]}  (I  {[i]}))))).
      rewrite -(exist_intro ({[Change i1 ]}  {[ Change i2 ]})).
      rewrite const_equiv; last first.
      (* This is exactly the same proof as above. Really, this should all be automated to be simple...
         but if we can't get that, at least factor it out as a lemma? *)
      { apply rtc_once. constructor; first constructor; rewrite /= /tok /=; first 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.
          rewrite !mkSet_elem_of /change_tokens /=.
          rewrite !elem_of_union !elem_of_difference !elem_of_singleton.
          naive_solver.
        - apply elem_of_equiv=>t. destruct t as [j|]; last set_solver.
          rewrite !mkSet_elem_of /change_tokens /=.
          rewrite !elem_of_union !elem_of_difference !elem_of_singleton.
          destruct (decide (i1 = j)); first naive_solver. 
          destruct (decide (i2 = j)); first naive_solver.
          destruct (decide (i = j)); naive_solver. }
      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.
        * rewrite -sts_ownS_op; [|set_solver|by eauto..].
          apply sts_own_weaken; first done.
          { rewrite !mkSet_elem_of /=. set_solver+. }
          apply sts.closed_op; [by eauto..|set_solver|].
          apply (non_empty_inhabited (State High ({[i1]}  ({[i2]}  (I  {[i]}))))).
          rewrite !mkSet_elem_of /=. set_solver+.
        * rewrite {1}[heap_ctx _]always_sep_dup !assoc [(_  heap_ctx _)%I]comm -!assoc. apply sep_mono_r.
          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
496
497
498
499

  Lemma recv_strengthen l P1 P2 :
    (P1 - P2)  (recv l P1 - recv l P2).
  Proof.
Ralf Jung's avatar
Ralf Jung committed
500
501
502
503
504
505
506
    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.
    rewrite -!assoc. apply sep_mono_r, sep_mono_r, sep_mono_r, sep_mono_r.
    rewrite (later_intro (P1 - _)%I) -later_sep. apply later_mono.
    apply wand_intro_l. rewrite !assoc wand_elim_r wand_elim_r. done.
  Qed.
507
508

End proof.
509
510
511
512
513
514
515
516
517
518
519
520
521

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),
522
523
524
525
      ( 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 }}) 
526
527
528
      ( 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)).
529
    split_and?; cbn.
530
531
532
533
    - intros. apply: always_intro. apply impl_intro_l. rewrite -newchan_spec.
      rewrite comm always_and_sep_r. apply sep_mono_r. apply forall_intro=>l.
      apply wand_intro_l. rewrite right_id -(exist_intro l) const_equiv // left_id.
      done.
Ralf Jung's avatar
Ralf Jung committed
534
535
536
537
    - intros. apply ht_alt. rewrite -signal_spec; last done.
        by rewrite right_id.
    - intros. apply ht_alt. rewrite -wait_spec; last done.
      apply sep_intro_True_r; first done. apply wand_intro_l. eauto with I.
Ralf Jung's avatar
Ralf Jung committed
538
539
    - intros. apply ht_alt. rewrite -recv_split.
      apply sep_intro_True_r; first done. apply wand_intro_l. eauto with I.
540
    - intros. apply recv_strengthen.
Ralf Jung's avatar
Ralf Jung committed
541
  Qed.
542
543

End spec.