Commit 7f8d960d authored by Ralf Jung's avatar Ralf Jung
Browse files

start work on the auth construction

parent ab91a93a
...@@ -64,6 +64,7 @@ program_logic/resources.v ...@@ -64,6 +64,7 @@ program_logic/resources.v
program_logic/hoare.v program_logic/hoare.v
program_logic/language.v program_logic/language.v
program_logic/tests.v program_logic/tests.v
program_logic/auth.v
program_logic/ghost_ownership.v program_logic/ghost_ownership.v
heap_lang/heap_lang.v heap_lang/heap_lang.v
heap_lang/heap_lang_tactics.v heap_lang/heap_lang_tactics.v
......
...@@ -146,6 +146,8 @@ Proof. ...@@ -146,6 +146,8 @@ Proof.
Qed. Qed.
Lemma auth_frag_op a b : (a b) a b. Lemma auth_frag_op a b : (a b) a b.
Proof. done. Qed. Proof. done. Qed.
Lemma auth_both_op a b : Auth (Excl a) b a b.
Proof. by rewrite /op /auth_op /= left_id. Qed.
Lemma auth_update a a' b b' : Lemma auth_update a a' b b' :
( n af, {S n} a a {S n} a' af b {S n} b' af {S n} b) ( n af, {S n} a a {S n} a' af b {S n} b' af {S n} b)
......
Require Export algebra.auth algebra.functor. Require Export algebra.auth algebra.functor.
Require Import program_logic.language program_logic.weakestpre. Require Export program_logic.invariants program_logic.ghost_ownership.
Import uPred. Import uPred ghost_ownership.
(* RJ: This is a work-in-progress playground.
FIXME: Finish or remove. *)
Section auth. Section auth.
(* TODO what should be implicit, what explicit? *) Context {A : cmraT} `{Empty A, !CMRAIdentity A}.
Context {Λ : language}. Context {Λ : language} {Σ : gid iFunctor} (AuthI : gid) `{!InG Λ Σ AuthI (authRA A)}.
Context {C : nat cmraT}. (* TODO: Come up with notation for "iProp Λ (globalC Σ)". *)
Context (i : nat). Context (N : namespace) (φ : A iProp Λ (globalC Σ)).
Context {A : cmraT}. Implicit Types P Q R : iProp Λ (globalC Σ).
Implicit Types a b : A.
Hypothesis Ci : C i = authRA A. Implicit Types γ : gname.
Let Σ : iFunctor := iprodF (mapF positive constF C).
(* TODO: Need this to be proven somewhere. *)
Definition tr (a : authRA A) : C i. (* FIXME ✓ binds too strong, I need parenthesis here. *)
rewrite Ci. exact a. Defined. Hypothesis auth_valid :
Definition tr' (c : C i) : authRA A. forall a b, ((Auth (Excl a) b) : iProp Λ (globalC Σ)) ( b', a b b').
rewrite -Ci. exact c. Defined.
(* FIXME how much would break if we had a global instance from ∅ to Inhabited? *)
Lemma tr'_tr a : Local Instance auth_inhabited : Inhabited A.
tr' $ tr a = a. Proof. split. exact . Qed.
Proof.
rewrite /tr' /tr. by destruct Ci. Definition auth_inv (γ : gname) : iProp Λ (globalC Σ) :=
Qed. ( a, own AuthI γ (a) φ a)%I.
Definition auth_own (γ : gname) (a : A) := own AuthI γ (a).
Lemma tr_tr' c : Definition auth_ctx (γ : gname) := inv N (auth_inv γ).
tr $ tr' c = c.
Proof. Lemma auth_alloc a :
rewrite /tr' /tr. by destruct Ci. a φ a pvs N N ( γ, auth_ctx γ auth_own γ a).
Qed.
Lemma tr_proper : Proper (() ==> ()) tr.
Proof.
move=>a1 a2 Heq. rewrite /tr. by destruct Ci.
Qed.
Lemma Ci_op (c1 c2: C i) :
c1 c2 = tr (tr' c1 tr' c2).
Proof.
rewrite /tr' /tr. by destruct Ci.
Qed.
Lemma A_val a :
a = (tr a).
Proof.
rewrite /tr. by destruct Ci.
Qed.
(* FIXME RJ: I'd rather not have to specify Σ by hand here. *)
Definition A2m (p : positive) (a : authRA A) : iGst Λ Σ :=
iprod_singleton i (<[p:=tr a]>).
Definition ownA (p : positive) (a : authRA A) : iProp Λ Σ :=
ownG (Σ:=Σ) (A2m p a).
Lemma ownA_op p a1 a2 :
(ownA p a1 ownA p a2)%I ownA p (a1 a2).
Proof. Proof.
rewrite /ownA /A2m /iprod_singleton /iprod_insert -ownG_op. apply ownG_proper=>j /=. intros Ha. rewrite -(right_id True%I ()%I (φ _)).
rewrite iprod_lookup_op. destruct (decide (i = j)). rewrite (own_alloc AuthI (Auth (Excl a) a) N) //; [].
- move=>q. destruct e. rewrite lookup_op /=. rewrite pvs_frame_l. apply pvs_strip_pvs.
destruct (decide (p = q)); first subst q. rewrite sep_exist_l. apply exist_elim=>γ. rewrite -(exist_intro γ).
+ rewrite !lookup_insert. transitivity (auth_inv γ auth_own γ a)%I.
rewrite /op /cmra_op /=. f_equiv. { rewrite /auth_inv -later_intro -(exist_intro a).
rewrite Ci_op. apply tr_proper. rewrite (commutative _ _ (φ _)) -associative. apply sep_mono; first done.
rewrite !tr'_tr. reflexivity. rewrite /auth_own -own_op auth_both_op. done. }
+ by rewrite !lookup_insert_ne //. rewrite (inv_alloc N) /auth_ctx pvs_frame_r. apply pvs_mono.
- by rewrite left_id. by rewrite always_and_sep_l'.
Qed. Qed.
(* TODO: This also holds if we just have ✓a at the current step-idx, as Iris Lemma auth_opened a γ :
assertion. However, the map_updateP_alloc does not suffice to show this. *) (auth_inv γ auth_own γ a) ( a', φ (a a') own AuthI γ ( (a a') a)).
Lemma ownA_alloc E a :
a True pvs E E ( p, ownA p a).
Proof. Proof.
intros Ha. set (P m := p, m = A2m p a). rewrite /auth_inv. rewrite [auth_own _ _]later_intro -later_sep.
set (a' := tr a). apply later_mono. rewrite sep_exist_r. apply exist_elim=>b.
rewrite -(pvs_mono _ _ ( m, P m ownG m)%I). rewrite /auth_own [(_ φ _)%I]commutative -associative -own_op.
- rewrite -pvs_updateP_empty //; []. rewrite own_valid_r auth_valid !sep_exist_l /=. apply exist_elim=>a'.
subst P. eapply (iprod_singleton_updateP_empty i). rewrite [ _]left_id -(exist_intro a').
+ eapply map_updateP_alloc' with (x:=a'). subst a'. Abort.
by rewrite -A_val.
+ simpl. move=>? [p [-> ?]]. exists p. done.
- apply exist_elim=>m. apply const_elim_l.
move=>[p ->] {P}. by rewrite -(exist_intro p).
Qed.
End auth. End auth.
...@@ -8,6 +8,7 @@ Local Hint Extern 100 (@subseteq coPset _ _) => solve_elem_of. ...@@ -8,6 +8,7 @@ Local Hint Extern 100 (@subseteq coPset _ _) => solve_elem_of.
Local Hint Extern 100 (_ _) => solve_elem_of. Local Hint Extern 100 (_ _) => solve_elem_of.
Local Hint Extern 99 ({[ _ ]} _) => apply elem_of_subseteq_singleton. Local Hint Extern 99 ({[ _ ]} _) => apply elem_of_subseteq_singleton.
Definition namespace := list positive. Definition namespace := list positive.
Definition nnil : namespace := nil. Definition nnil : namespace := nil.
Definition ndot `{Countable A} (N : namespace) (x : A) : namespace := Definition ndot `{Countable A} (N : namespace) (x : A) : namespace :=
...@@ -91,7 +92,7 @@ Qed. ...@@ -91,7 +92,7 @@ Qed.
Lemma wp_open_close E e N P (Q : val Λ iProp Λ Σ) : Lemma wp_open_close E e N P (Q : val Λ iProp Λ Σ) :
atomic e nclose N E atomic e nclose N E
(inv N P (P - wp (E nclose N) e (λ v, P Q v)))%I wp E e Q. (inv N P (P - wp (E nclose N) e (λ v, P Q v))) wp E e Q.
Proof. Proof.
move=>He HN. move=>He HN.
rewrite /inv and_exist_r. apply exist_elim=>i. rewrite /inv and_exist_r. apply exist_elim=>i.
...@@ -108,7 +109,7 @@ Proof. ...@@ -108,7 +109,7 @@ Proof.
apply pvs_mask_frame'; solve_elem_of. apply pvs_mask_frame'; solve_elem_of.
Qed. Qed.
Lemma pvs_alloc N P : P pvs N N (inv N P). Lemma inv_alloc N P : P pvs N N (inv N P).
Proof. by rewrite /inv (pvs_allocI N); last apply coPset_suffixes_infinite. Qed. Proof. by rewrite /inv (pvs_allocI N); last apply coPset_suffixes_infinite. Qed.
End inv. End inv.
...@@ -132,6 +132,8 @@ Global Instance pvs_mono' E1 E2 : Proper ((⊑) ==> (⊑)) (@pvs Λ Σ E1 E2). ...@@ -132,6 +132,8 @@ Global Instance pvs_mono' E1 E2 : Proper ((⊑) ==> (⊑)) (@pvs Λ Σ E1 E2).
Proof. intros P Q; apply pvs_mono. Qed. Proof. intros P Q; apply pvs_mono. Qed.
Lemma pvs_trans' E P : pvs E E (pvs E E P) pvs E E P. Lemma pvs_trans' E P : pvs E E (pvs E E P) pvs E E P.
Proof. apply pvs_trans; solve_elem_of. Qed. Proof. apply pvs_trans; solve_elem_of. Qed.
Lemma pvs_strip_pvs E P Q : P pvs E E Q pvs E E P pvs E E Q.
Proof. move=>->. by rewrite pvs_trans'. Qed.
Lemma pvs_frame_l E1 E2 P Q : (P pvs E1 E2 Q) pvs E1 E2 (P Q). Lemma pvs_frame_l E1 E2 P Q : (P pvs E1 E2 Q) pvs E1 E2 (P Q).
Proof. rewrite !(commutative _ P); apply pvs_frame_r. Qed. Proof. rewrite !(commutative _ P); apply pvs_frame_r. Qed.
Lemma pvs_always_l E1 E2 P Q `{!AlwaysStable P} : Lemma pvs_always_l E1 E2 P Q `{!AlwaysStable P} :
......
...@@ -100,7 +100,7 @@ Proof. ...@@ -100,7 +100,7 @@ Proof.
Qed. Qed.
Lemma vs_alloc (N : namespace) P : P ={N}=> inv N P. Lemma vs_alloc (N : namespace) P : P ={N}=> inv N P.
Proof. by intros; apply vs_alt, pvs_alloc. Qed. Proof. by intros; apply vs_alt, inv_alloc. Qed.
End vs. End vs.
......
...@@ -206,6 +206,8 @@ Proof. by apply wp_mask_frame_mono. Qed. ...@@ -206,6 +206,8 @@ Proof. by apply wp_mask_frame_mono. Qed.
Global Instance wp_mono' E e : Global Instance wp_mono' E e :
Proper (pointwise_relation _ () ==> ()) (@wp Λ Σ E e). Proper (pointwise_relation _ () ==> ()) (@wp Λ Σ E e).
Proof. by intros Q Q' ?; apply wp_mono. Qed. Proof. by intros Q Q' ?; apply wp_mono. Qed.
Lemma wp_strip_pvs E e P Q : P wp E e Q pvs E E P wp E e Q.
Proof. move=>->. by rewrite pvs_wp. Qed.
Lemma wp_value' E Q e v : to_val e = Some v Q v wp E e Q. Lemma wp_value' E Q e v : to_val e = Some v Q v wp E e Q.
Proof. intros; rewrite -(of_to_val e v) //; by apply wp_value. Qed. Proof. intros; rewrite -(of_to_val e v) //; by apply wp_value. Qed.
Lemma wp_frame_l E e Q R : (R wp E e Q) wp E e (λ v, R Q v). Lemma wp_frame_l E e Q R : (R wp E e Q) wp E e (λ v, R Q v).
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment