Commit 479a6a8c authored by Dan Frumin's avatar Dan Frumin

Lock invariants and a "well-bracketed" control flow refinement

parent 1b9dfa34
From iris.proofmode Require Import tactics.
From iris.algebra Require Import excl.
From iris_logrel Require Export logrel.
Definition newlock : val := λ: <>, ref #false.
......@@ -38,8 +39,106 @@ Proof. solve_typed. Qed.
Hint Resolve with_lock_type : typeable.
Section proof.
Class lockG Σ := LockG { lock_tokG :> inG Σ (exclR unitC) }.
Definition lockΣ : gFunctors := #[GFunctor (exclR unitC)].
Instance subG_lockΣ {Σ} : subG lockΣ Σ lockG Σ.
Proof. solve_inG. Qed.
Section lockG_rules.
Context `{!lockG Σ, !logrelG Σ} (N: namespace).
Definition lock_inv (γ : gname) (l : loc) (R : iProp Σ) : iProp Σ :=
( b : bool, l ↦ᵢ #b if b then True else own γ (Excl ()) R)%I.
Definition is_lock (γ : gname) (lk : val) (R : iProp Σ) : iProp Σ :=
( l: loc, lk = #l inv N (lock_inv γ l R))%I.
Definition locked (γ : gname) : iProp Σ := own γ (Excl ()).
Lemma locked_exclusive (γ : gname) : locked γ - locked γ - False.
Proof. iIntros "H1 H2". by iDestruct (own_valid_2 with "H1 H2") as %?. Qed.
Global Instance lock_inv_ne γ l : NonExpansive (lock_inv γ l).
Proof. solve_proper. Qed.
Global Instance is_lock_ne l : NonExpansive (is_lock γ l).
Proof. solve_proper. Qed.
Global Instance is_lock_persistent γ l R : PersistentP (is_lock γ l R).
Proof. apply _. Qed.
Global Instance locked_timeless γ : TimelessP (locked γ).
Proof. apply _. Qed.
Lemma bin_log_related_newlock_l (R : iProp Σ) Δ Γ E K t τ :
R -
( (lk : loc) γ, is_lock γ #lk R
- ({E,E;Δ;Γ} fill K #lk log t: τ)) -
{E,E;Δ;Γ} fill K (newlock #()) log t: τ.
Proof.
iIntros "HR Hlog".
iApply bin_log_related_wp_l.
rewrite -wp_fupd /newlock /=. unlock.
wp_seq. wp_alloc l as "Hl".
iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
iMod (inv_alloc N _ (lock_inv γ l R) with "[-Hlog]") as "#?".
{ iIntros "!>". iExists false. by iFrame. }
iModIntro. iApply "Hlog". iExists l. eauto.
Qed.
Lemma bin_log_related_release_l (R : iProp Σ) (lk : loc) γ Δ Γ E K t τ :
N E
is_lock γ #lk R -
locked γ -
R -
({E,E;Δ;Γ} fill K #() log t: τ) -
{E,E;Δ;Γ} fill K (release #lk) log t: τ.
Proof.
iIntros (?) "Hlock Hlocked HR Hlog".
iDestruct "Hlock" as (l) "[% #?]"; simplify_eq.
unlock release. simpl.
rel_let_l.
rel_store_l_atomic.
iInv N as (b) "[Hl _]" "Hclose".
iModIntro. iExists _. iFrame.
iNext. iIntros "Hl".
iMod ("Hclose" with "[-Hlog]").
{ iNext. iExists false. by iFrame. }
iApply "Hlog".
Qed.
Lemma bin_log_related_acquire_l (R : iProp Σ) (lk : loc) γ Δ Γ E K t τ :
N E
is_lock γ #lk R -
(locked γ - R - {E,E;Δ;Γ} fill K #() log t: τ) -
{E,E;Δ;Γ} fill K (acquire #lk) log t: τ.
Proof.
iIntros (?) "#Hlock Hlog".
iLöb as "IH".
unlock acquire. simpl.
rel_rec_l.
iDestruct "Hlock" as (l) "[% #?]". simplify_eq.
rel_cas_l_atomic.
iInv N as (b) "[Hl HR]" "Hclose".
iModIntro. iExists _. iFrame.
iSplit.
- iIntros (?). iNext. iIntros "Hl".
assert (b = true) as ->. { destruct b; congruence. }
rel_if_l.
iMod ("Hclose" with "[Hl]"); first (iNext; iExists true; eauto).
by iApply "IH".
- iIntros (?). simplify_eq.
iNext. iIntros "Hl".
rel_if_l.
iMod ("Hclose" with "[Hl]"); first (iNext; iExists true; eauto).
iDestruct "HR" as "[Hlocked HR]".
iApply ("Hlog" with "Hlocked HR").
Qed.
End lockG_rules.
Section lock_rules_r.
Context `{logrelG Σ}.
Variable (E1 E2 : coPset).
Variable (Δ : list (prodC valC valC -n> iProp Σ)).
......@@ -67,7 +166,7 @@ Section proof.
iApply ("Hlog" with "Hl").
Qed.
Lemma bin_log_related_newlock_l Γ K t τ :
Lemma bin_log_related_newlock_l_simp Γ K t τ :
( l : loc, l ↦ᵢ #false - {E1,E1;Δ;Γ} fill K #l log t : τ) -
{E1,E1;Δ;Γ} fill K (newlock #()) log t : τ.
Proof.
......@@ -232,4 +331,4 @@ Section proof.
iApply ("Hlog" with "HQ Hl").
Qed.
End proof.
End lock_rules_r.
......@@ -4,7 +4,7 @@
*)
From iris.proofmode Require Import tactics.
From iris.algebra Require Import csum agree excl.
From iris_logrel Require Import logrel.
From iris_logrel Require Import logrel examples.lock.
Section refinement.
Context `{logrelG Σ}.
......@@ -207,5 +207,58 @@ Section refinement.
unlock bot; simpl_subst/=.
iApply ("IH" with "Hlog").
Qed.
(* /Sort of/ a well-bracketedness example.
Without locking in the first expression, the callback can reenter
the body in a forked thread to change the value of x
*)
Lemma refinement4 Γ `{!lockG Σ}:
Γ
(let: "x" := ref #1 in
let: "l" := newlock #() in
λ: "f", acquire "l";;
"x" <- #0;; "f" #();;
"x" <- #1;; "f" #();;
let: "v" := !"x" in
release "l";; "v")
log
(let: "x" := ref #0 in
λ: "f", "f" #();; "x" <- #1;; "f" #();; !"x")
: TArrow (TArrow TUnit TUnit) TNat.
Proof.
iIntros (Δ).
rel_alloc_l as x "Hx".
rel_alloc_r as y "Hy".
rel_let_l; rel_let_r.
pose (N:=logrelN.@"lock").
rel_apply_l (bin_log_related_newlock_l N ( (n m : nat), x ↦ᵢ #n y ↦ₛ #m)%I with "[Hx Hy]").
{ iExists _, _. iFrame. }
iIntros (l γ) "#Hl".
rel_let_l.
iApply bin_log_related_arrow_val; auto.
iIntros "!#" (f1 f2) "#Hf".
rel_let_l. rel_let_r.
rel_apply_l (bin_log_related_acquire_l N _ l with "Hl"); auto.
iIntros "Hlocked". iDestruct 1 as (n m) "[Hx Hy]".
rel_seq_l.
rel_store_l. rel_seq_l.
iApply (bin_log_related_seq _ _ _ _ _ _ _ TUnit with "[Hf]"); auto.
{ iApply (bin_log_related_app _ _ _ _ _ _ _ TUnit TUnit with "[Hf]").
iApply (related_ret ). iApply interp_ret; eauto using to_of_val.
iApply bin_log_related_unit. }
rel_store_l. rel_seq_l.
rel_store_r. rel_seq_r.
iApply (bin_log_related_seq _ _ _ _ _ _ _ TUnit with "[Hf]"); auto.
{ iApply (bin_log_related_app _ _ _ _ _ _ _ TUnit TUnit with "[Hf]").
iApply (related_ret ). iApply interp_ret; eauto using to_of_val.
iApply bin_log_related_unit. }
rel_load_l.
rel_let_l.
rel_load_r.
rel_apply_l (bin_log_related_release_l N _ l γ with "Hl Hlocked [Hx Hy]"); eauto.
{ iExists _,_. iFrame. }
rel_seq_l.
rel_vals; eauto.
Qed.
End refinement.
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