lifting.v 4.58 KB
Newer Older
1 2
From program_logic Require Export weakestpre.
From program_logic Require Import wsat ownership.
Robbert Krebbers's avatar
Robbert Krebbers committed
3
Local Hint Extern 10 (_  _) => omega.
4
Local Hint Extern 100 (@eq coPset _ _) => set_solver.
Robbert Krebbers's avatar
Robbert Krebbers committed
5
Local Hint Extern 10 ({_} _) =>
6 7 8
  repeat match goal with
  | H : wsat _ _ _ _ |- _ => apply wsat_valid in H; last omega
  end; solve_validN.
Robbert Krebbers's avatar
Robbert Krebbers committed
9 10

Section lifting.
11 12 13 14
Context {Λ : language} {Σ : iFunctor}.
Implicit Types v : val Λ.
Implicit Types e : expr Λ.
Implicit Types σ : state Λ.
15 16
Implicit Types P Q : iProp Λ Σ.
Implicit Types Φ : val Λ  iProp Λ Σ.
17
Transparent uPred_holds.
Robbert Krebbers's avatar
Robbert Krebbers committed
18

19
Notation wp_fork ef := (default True ef (flip (wp ) (λ _,  True)))%I.
20

Robbert Krebbers's avatar
Robbert Krebbers committed
21
Lemma wp_lift_step E1 E2
22
    (φ : expr Λ  state Λ  option (expr Λ)  Prop) Φ e1 σ1 :
Robbert Krebbers's avatar
Robbert Krebbers committed
23
  E1  E2  to_val e1 = None 
24
  reducible e1 σ1 
Robbert Krebbers's avatar
Robbert Krebbers committed
25
  ( e2 σ2 ef, prim_step e1 σ1 e2 σ2 ef  φ e2 σ2 ef) 
26
  (|={E2,E1}=>  ownP σ1    e2 σ2 ef,
27 28
    ( φ e2 σ2 ef  ownP σ2) - |={E1,E2}=> || e2 @ E2 {{ Φ }}  wp_fork ef)
   || e1 @ E2 {{ Φ }}.
Robbert Krebbers's avatar
Robbert Krebbers committed
29
Proof.
30
  intros ? He Hsafe Hstep. uPred.unseal; split=> n r ? Hvs; constructor; auto.
Robbert Krebbers's avatar
Robbert Krebbers committed
31 32 33
  intros rf k Ef σ1' ???; destruct (Hvs rf (S k) Ef σ1')
    as (r'&(r1&r2&?&?&Hwp)&Hws); auto; clear Hvs; cofe_subst r'.
  destruct (wsat_update_pst k (E1  Ef) σ1 σ1' r1 (r2  rf)) as [-> Hws'].
34
  { apply equiv_dist. rewrite -(ownP_spec k); auto. }
35
  { by rewrite assoc. }
Robbert Krebbers's avatar
Robbert Krebbers committed
36
  constructor; [done|intros e2 σ2 ef ?; specialize (Hws' σ2)].
Robbert Krebbers's avatar
Robbert Krebbers committed
37
  destruct (λ H1 H2 H3, Hwp e2 σ2 ef k (update_pst σ2 r1) H1 H2 H3 rf k Ef σ2)
Robbert Krebbers's avatar
Robbert Krebbers committed
38
    as (r'&(r1'&r2'&?&?&?)&?); auto; cofe_subst r'.
39
  { split. by eapply Hstep. apply ownP_spec; auto. }
40
  { rewrite (comm _ r2) -assoc; eauto using wsat_le. }
41
  exists r1', r2'; split_and?; try done. by uPred.unseal; intros ? ->.
Robbert Krebbers's avatar
Robbert Krebbers committed
42
Qed.
43

44
Lemma wp_lift_pure_step E (φ : expr Λ  option (expr Λ)  Prop) Φ e1 :
Robbert Krebbers's avatar
Robbert Krebbers committed
45
  to_val e1 = None 
46
  ( σ1, reducible e1 σ1) 
Robbert Krebbers's avatar
Robbert Krebbers committed
47
  ( σ1 e2 σ2 ef, prim_step e1 σ1 e2 σ2 ef  σ1 = σ2  φ e2 ef) 
48
  (  e2 ef,  φ e2 ef  || e2 @ E {{ Φ }}  wp_fork ef)  || e1 @ E {{ Φ }}.
Robbert Krebbers's avatar
Robbert Krebbers committed
49
Proof.
50
  intros He Hsafe Hstep; uPred.unseal; split=> n r ? Hwp; constructor; auto.
51
  intros rf k Ef σ1 ???; split; [done|]. destruct n as [|n]; first lia.
Robbert Krebbers's avatar
Robbert Krebbers committed
52
  intros e2 σ2 ef ?; destruct (Hstep σ1 e2 σ2 ef); auto; subst.
Robbert Krebbers's avatar
Robbert Krebbers committed
53
  destruct (Hwp e2 ef k r) as (r1&r2&Hr&?&?); auto.
54 55 56
  exists r1,r2; split_and?; try done.
  - rewrite -Hr; eauto using wsat_le.
  - uPred.unseal; by intros ? ->.
Robbert Krebbers's avatar
Robbert Krebbers committed
57
Qed.
58 59

(** Derived lifting lemmas. *)
60 61
Opaque uPred_holds.
Import uPred.
62

63
Lemma wp_lift_atomic_step {E Φ} e1
64
    (φ : val Λ  state Λ  option (expr Λ)  Prop) σ1 :
65 66
  to_val e1 = None 
  reducible e1 σ1 
67 68
  ( e2 σ2 ef,
    prim_step e1 σ1 e2 σ2 ef   v2, to_val e2 = Some v2  φ v2 σ2 ef) 
69
  ( ownP σ1    v2 σ2 ef,  φ v2 σ2 ef  ownP σ2 - Φ v2  wp_fork ef)
70
   || e1 @ E {{ Φ }}.
71
Proof.
72 73
  intros. rewrite -(wp_lift_step E E (λ e2 σ2 ef,  v2,
    to_val e2 = Some v2  φ v2 σ2 ef) _ e1 σ1) //; [].
74 75 76
  rewrite -pvs_intro. apply sep_mono, later_mono; first done.
  apply forall_intro=>e2'; apply forall_intro=>σ2'.
  apply forall_intro=>ef; apply wand_intro_l.
77
  rewrite always_and_sep_l -assoc -always_and_sep_l.
78 79 80
  apply const_elim_l=>-[v2' [Hv ?]] /=.
  rewrite -pvs_intro.
  rewrite (forall_elim v2') (forall_elim σ2') (forall_elim ef) const_equiv //.
81
  by rewrite left_id wand_elim_r -(wp_value _ _ e2' v2').
82 83
Qed.

84
Lemma wp_lift_atomic_det_step {E Φ e1} σ1 v2 σ2 ef :
85 86
  to_val e1 = None 
  reducible e1 σ1 
87 88
  ( e2' σ2' ef', prim_step e1 σ1 e2' σ2' ef' 
    σ2 = σ2'  to_val e2' = Some v2  ef = ef') 
89
  ( ownP σ1   (ownP σ2 - Φ v2  wp_fork ef))  || e1 @ E {{ Φ }}.
90
Proof.
91 92
  intros. rewrite -(wp_lift_atomic_step _ (λ v2' σ2' ef',
    σ2 = σ2'  v2 = v2'  ef = ef') σ1) //; last naive_solver.
93
  apply sep_mono, later_mono; first done.
94
  apply forall_intro=>e2'; apply forall_intro=>σ2'; apply forall_intro=>ef'.
95
  apply wand_intro_l.
96
  rewrite always_and_sep_l -assoc -always_and_sep_l.
97
  apply const_elim_l=>-[-> [-> ->]] /=. by rewrite wand_elim_r.
98 99
Qed.

100
Lemma wp_lift_pure_det_step {E Φ} e1 e2 ef :
101 102
  to_val e1 = None 
  ( σ1, reducible e1 σ1) 
103
  ( σ1 e2' σ2 ef', prim_step e1 σ1 e2' σ2 ef'  σ1 = σ2  e2 = e2'  ef = ef')
104
   (|| e2 @ E {{ Φ }}  wp_fork ef)  || e1 @ E {{ Φ }}.
105
Proof.
106 107
  intros.
  rewrite -(wp_lift_pure_step E (λ e2' ef', e2 = e2'  ef = ef') _ e1) //=.
108
  apply later_mono, forall_intro=>e'; apply forall_intro=>ef'.
109
  by apply impl_intro_l, const_elim_l=>-[-> ->].
110 111
Qed.

Robbert Krebbers's avatar
Robbert Krebbers committed
112
End lifting.