Skip to content

GitLab

Commit ba2fcff2 authored by Robbert Krebbers's avatar Robbert Krebbers
Browse files
Options

Same the same for the binary logrel on F_mu_ref_par.

parent f69f3e5b
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 570 additions and 940 deletions
F_mu_ref_par/context_refinement.v
View file @ ba2fcff2
From iris_logrel.F_mu_ref_par Require Export fundamental_binary.
Inductive context_item :=
Inductive ctx_item :=
| CTX_Lam
| CTX_AppL (e2 : expr)
| CTX_AppR (e1 : expr)
......@@ -40,7 +40,7 @@ Inductive context_item :=
| CTX_CAS_M (e0 : expr) (e2 : expr)
| CTX_CAS_R (e0 : expr) (e1 : expr).
Fixpoint fill_ctx_item (ctx : context_item) (e : expr) : expr :=
Fixpoint fill_ctx_item (ctx : ctx_item) (e : expr) : expr :=
match ctx with
| CTX_Lam => Lam e
| CTX_AppL e2 => App e e2
......@@ -73,142 +73,135 @@ Fixpoint fill_ctx_item (ctx : context_item) (e : expr) : expr :=
| CTX_CAS_R e0 e1 => CAS e0 e1 e
end.
Definition context := list context_item.
Definition ctx := list ctx_item.
Definition fill_ctx (K : context) (e : expr) : expr := foldr fill_ctx_item e K.
Definition fill_ctx (K : ctx) (e : expr) : expr := foldr fill_ctx_item e K.
Local Open Scope bin_logrel_scope.
(** typed ctx *)
Inductive typed_ctx_item :
ctx_item → list type → type → list type → type → Prop :=
| TP_CTX_Lam Γ τ τ' :
typed_ctx_item CTX_Lam (TArrow τ τ' :: τ :: Γ) τ' Γ (TArrow τ τ')
| TP_CTX_AppL Γ e2 τ τ' :
typed Γ e2 τ →
typed_ctx_item (CTX_AppL e2) Γ (TArrow τ τ') Γ τ'
| TP_CTX_AppR Γ e1 τ τ' :
typed Γ e1 (TArrow τ τ') →
typed_ctx_item (CTX_AppR e1) Γ τ Γ τ'
| TP_CTX_PairL Γ e2 τ τ' :
typed Γ e2 τ' →
typed_ctx_item (CTX_PairL e2) Γ τ Γ (TProd τ τ')
| TP_CTX_PairR Γ e1 τ τ' :
typed Γ e1 τ →
typed_ctx_item (CTX_PairR e1) Γ τ' Γ (TProd τ τ')
| TP_CTX_Fst Γ τ τ' :
typed_ctx_item CTX_Fst Γ (TProd τ τ') Γ τ
| TP_CTX_Snd Γ τ τ' :
typed_ctx_item CTX_Snd Γ (TProd τ τ') Γ τ'
| TP_CTX_InjL Γ τ τ' :
typed_ctx_item CTX_InjL Γ τ Γ (TSum τ τ')
| TP_CTX_InjR Γ τ τ' :
typed_ctx_item CTX_InjR Γ τ' Γ (TSum τ τ')
| TP_CTX_CaseL Γ e1 e2 τ1 τ2 τ' :
typed (τ1 :: Γ) e1 τ' → typed (τ2 :: Γ) e2 τ' →
typed_ctx_item (CTX_CaseL e1 e2) Γ (TSum τ1 τ2) Γ τ'
| TP_CTX_CaseM Γ e0 e2 τ1 τ2 τ' :
typed Γ e0 (TSum τ1 τ2) → typed (τ2 :: Γ) e2 τ' →
typed_ctx_item (CTX_CaseM e0 e2) (τ1 :: Γ) τ' Γ τ'
| TP_CTX_CaseR Γ e0 e1 τ1 τ2 τ' :
typed Γ e0 (TSum τ1 τ2) → typed (τ1 :: Γ) e1 τ' →
typed_ctx_item (CTX_CaseR e0 e1) (τ2 :: Γ) τ' Γ τ'
| TP_CTX_IfL Γ e1 e2 τ :
typed Γ e1 τ → typed Γ e2 τ →
typed_ctx_item (CTX_IfL e1 e2) Γ (TBool) Γ τ
| TP_CTX_IfM Γ e0 e2 τ :
typed Γ e0 (TBool) → typed Γ e2 τ →
typed_ctx_item (CTX_IfM e0 e2) Γ τ Γ τ
| TP_CTX_IfR Γ e0 e1 τ :
typed Γ e0 (TBool) → typed Γ e1 τ →
typed_ctx_item (CTX_IfR e0 e1) Γ τ Γ τ
| TP_CTX_BinOpL op Γ e2 :
typed Γ e2 TNat →
typed_ctx_item (CTX_BinOpL op e2) Γ TNat Γ (binop_res_type op)
| TP_CTX_BinOpR op e1 Γ :
typed Γ e1 TNat →
typed_ctx_item (CTX_BinOpR op e1) Γ TNat Γ (binop_res_type op)
| TP_CTX_Fold Γ τ :
typed_ctx_item CTX_Fold Γ τ.[(TRec τ)/] Γ (TRec τ)
| TP_CTX_Unfold Γ τ :
typed_ctx_item CTX_Unfold Γ (TRec τ) Γ τ.[(TRec τ)/]
| TP_CTX_TLam Γ τ :
typed_ctx_item CTX_TLam (subst (ren (+1)) <$> Γ) τ Γ (TForall τ)
| TP_CTX_TApp Γ τ τ' :
typed_ctx_item CTX_TApp Γ (TForall τ) Γ τ.[τ'/]
| TP_CTX_Fork Γ :
typed_ctx_item CTX_Fork Γ TUnit Γ TUnit
| TPCTX_Alloc Γ τ :
typed_ctx_item CTX_Alloc Γ τ Γ (Tref τ)
| TP_CTX_Load Γ τ :
typed_ctx_item CTX_Load Γ (Tref τ) Γ τ
| TP_CTX_StoreL Γ e2 τ :
typed Γ e2 τ → typed_ctx_item (CTX_StoreL e2) Γ (Tref τ) Γ TUnit
| TP_CTX_StoreR Γ e1 τ :
typed Γ e1 (Tref τ) →
typed_ctx_item (CTX_StoreR e1) Γ τ Γ TUnit
| TP_CTX_CasL Γ e1 e2 τ :
EqType τ → typed Γ e1 τ → typed Γ e2 τ →
typed_ctx_item (CTX_CAS_L e1 e2) Γ (Tref τ) Γ TBool
| TP_CTX_CasM Γ e0 e2 τ :
EqType τ → typed Γ e0 (Tref τ) → typed Γ e2 τ →
typed_ctx_item (CTX_CAS_M e0 e2) Γ τ Γ TBool
| TP_CTX_CasR Γ e0 e1 τ :
EqType τ → typed Γ e0 (Tref τ) → typed Γ e1 τ →
typed_ctx_item (CTX_CAS_R e0 e1) Γ τ Γ TBool.
(** typed context *)
Inductive typed_context_item :
context_item → list type → type → list type → type → Prop :=
| TP_CTX_Lam : ∀ Γ τ τ',
typed_context_item CTX_Lam (TArrow τ τ' :: τ :: Γ) τ' Γ (TArrow τ τ')
| TP_CTX_AppL (e2 : expr) : ∀ Γ τ τ',
typed Γ e2 τ →
typed_context_item (CTX_AppL e2) Γ (TArrow τ τ') Γ τ'
| TP_CTX_AppR (e1 : expr) : ∀ Γ τ τ',
typed Γ e1 (TArrow τ τ') →
typed_context_item (CTX_AppR e1) Γ τ Γ τ'
| TP_CTX_PairL (e2 : expr) : ∀ Γ τ τ',
typed Γ e2 τ' →
typed_context_item (CTX_PairL e2) Γ τ Γ (TProd τ τ')
| TP_CTX_PairR (e1 : expr) : ∀ Γ τ τ',
typed Γ e1 τ →
typed_context_item (CTX_PairR e1) Γ τ' Γ (TProd τ τ')
| TP_CTX_Fst : ∀ Γ τ τ',
typed_context_item CTX_Fst Γ (TProd τ τ') Γ τ
| TP_CTX_Snd : ∀ Γ τ τ',
typed_context_item CTX_Snd Γ (TProd τ τ') Γ τ'
| TP_CTX_InjL : ∀ Γ τ τ',
typed_context_item CTX_InjL Γ τ Γ (TSum τ τ')
| TP_CTX_InjR : ∀ Γ τ τ',
typed_context_item CTX_InjR Γ τ' Γ (TSum τ τ')
| TP_CTX_CaseL (e1 : expr) (e2 : expr) : ∀ Γ τ1 τ2 τ',
typed (τ1 :: Γ) e1 τ' → typed (τ2 :: Γ) e2 τ' →
typed_context_item (CTX_CaseL e1 e2) Γ (TSum τ1 τ2) Γ τ'
| TP_CTX_CaseM (e0 : expr) (e2 : expr) : ∀ Γ τ1 τ2 τ',
typed Γ e0 (TSum τ1 τ2) → typed (τ2 :: Γ) e2 τ' →
typed_context_item (CTX_CaseM e0 e2) (τ1 :: Γ) τ' Γ τ'
| TP_CTX_CaseR (e0 : expr) (e1 : expr) : ∀ Γ τ1 τ2 τ',
typed Γ e0 (TSum τ1 τ2) → typed (τ1 :: Γ) e1 τ' →
typed_context_item (CTX_CaseR e0 e1) (τ2 :: Γ) τ' Γ τ'
| TP_CTX_IfL (e1 : expr) (e2 : expr) : ∀ Γ τ,
typed Γ e1 τ → typed Γ e2 τ →
typed_context_item (CTX_IfL e1 e2) Γ (TBool) Γ τ
| TP_CTX_IfM (e0 : expr) (e2 : expr) : ∀ Γ τ,
typed Γ e0 (TBool) → typed Γ e2 τ →
typed_context_item (CTX_IfM e0 e2) Γ τ Γ τ
| TP_CTX_IfR (e0 : expr) (e1 : expr) : ∀ Γ τ,
typed Γ e0 (TBool) → typed Γ e1 τ →
typed_context_item (CTX_IfR e0 e1) Γ τ Γ τ
| TP_CTX_BinOpL op (e2 : expr) : ∀ Γ,
typed Γ e2 TNat →
typed_context_item (CTX_BinOpL op e2) Γ TNat Γ (binop_res_type op)
| TP_CTX_BinOpR op (e1 : expr) : ∀ Γ,
typed Γ e1 TNat →
typed_context_item (CTX_BinOpR op e1) Γ TNat Γ (binop_res_type op)
| TP_CTX_Fold : ∀ Γ τ,
typed_context_item CTX_Fold Γ τ.[(TRec τ)/] Γ (TRec τ)
| TP_CTX_Unfold : ∀ Γ τ,
typed_context_item CTX_Unfold Γ (TRec τ) Γ τ.[(TRec τ)/]
| TP_CTX_TLam : ∀ Γ τ,
typed_context_item
CTX_TLam (map (λ t : type, t.[ren (+1)]) Γ) τ Γ (TForall τ)
| TP_CTX_TApp : ∀ Γ τ τ',
typed_context_item CTX_TApp Γ (TForall τ) Γ τ.[τ'/]
| TP_CTX_Fork : ∀ Γ,
typed_context_item CTX_Fork Γ TUnit Γ TUnit
| TPCTX_Alloc : ∀ Γ τ,
typed_context_item CTX_Alloc Γ τ Γ (Tref τ)
| TP_CTX_Load : ∀ Γ τ,
typed_context_item CTX_Load Γ (Tref τ) Γ τ
| TP_CTX_StoreL (e2 : expr) : ∀ Γ τ,
typed Γ e2 τ →
typed_context_item (CTX_StoreL e2) Γ (Tref τ) Γ TUnit
| TP_CTX_StoreR (e1 : expr) : ∀ Γ τ,
typed Γ e1 (Tref τ) →
typed_context_item (CTX_StoreR e1) Γ τ Γ TUnit
| TP_CTX_CasL (e1 : expr) (e2 : expr) : ∀ Γ τ,
EqType τ → typed Γ e1 τ → typed Γ e2 τ →
typed_context_item (CTX_CAS_L e1 e2) Γ (Tref τ) Γ TBool
| TP_CTX_CasM (e0 : expr) (e2 : expr) : ∀ Γ τ,
EqType τ → typed Γ e0 (Tref τ) → typed Γ e2 τ →
typed_context_item (CTX_CAS_M e0 e2) Γ τ Γ TBool
| TP_CTX_CasR (e0 : expr) (e1 : expr) : ∀ Γ τ,
EqType τ → typed Γ e0 (Tref τ) → typed Γ e1 τ →
typed_context_item (CTX_CAS_R e0 e1) Γ τ Γ TBool.
Lemma typed_context_item_typed k Γ τ Γ' τ' e :
typed Γ e τ → typed_context_item k Γ τ Γ' τ' →
Lemma typed_ctx_item_typed k Γ τ Γ' τ' e :
typed Γ e τ → typed_ctx_item k Γ τ Γ' τ' →
typed Γ' (fill_ctx_item k e) τ'.
Proof. intros H1 H2; induction H2; simpl; eauto using typed. Qed.
Proof. induction 2; simpl; eauto using typed. Qed.
Inductive typed_context: context → list type → type → list type → type → Prop :=
Inductive typed_ctx: ctx → list type → type → list type → type → Prop :=
| TPCTX_nil Γ τ :
typed_context nil Γ τ Γ τ
typed_ctx nil Γ τ Γ τ
| TPCTX_cons Γ1 τ1 Γ2 τ2 Γ3 τ3 k K :
typed_context_item k Γ2 τ2 Γ3 τ3 →
typed_context K Γ1 τ1 Γ2 τ2 →
typed_context (k :: K) Γ1 τ1 Γ3 τ3.
typed_ctx_item k Γ2 τ2 Γ3 τ3 →
typed_ctx K Γ1 τ1 Γ2 τ2 →
typed_ctx (k :: K) Γ1 τ1 Γ3 τ3.
Lemma typed_context_typed K Γ τ Γ' τ' e :
typed Γ e τ → typed_context K Γ τ Γ' τ' → typed Γ' (fill_ctx K e) τ'.
Proof.
intros H1 H2; induction H2; simpl; eauto using typed_context_item_typed.
Qed.
Lemma typed_ctx_typed K Γ τ Γ' τ' e :
typed Γ e τ → typed_ctx K Γ τ Γ' τ' → typed Γ' (fill_ctx K e) τ'.
Proof. induction 2; simpl; eauto using typed_ctx_item_typed. Qed.
Lemma typed_context_n_closed K Γ τ Γ' τ' e :
(∀ f, e.[base.iter (length Γ) up f] = e) → typed_context K Γ τ Γ' τ' →
Lemma typed_ctx_n_closed K Γ τ Γ' τ' e :
(∀ f, e.[base.iter (length Γ) up f] = e) → typed_ctx K Γ τ Γ' τ' →
∀ f, (fill_ctx K e).[base.iter (length Γ') up f] = (fill_ctx K e).
Proof.
intros H1 H2; induction H2; simpl; auto.
(induction H => f); asimpl; simpl in *;
repeat match goal with H : _ |- _ => rewrite map_length in H end;
induction H => f; asimpl; simpl in *;
repeat match goal with H : _ |- _ => rewrite fmap_length in H end;
try f_equal;
eauto using typed_n_closed;
try match goal with H : _ |- _ => eapply (typed_n_closed _ _ _ H) end.
Qed.
Definition context_refines Γ e e' τ :=
∀ K,
typed_context K Γ τ [] TUnit →
∀ thp h v, rtc step ([fill_ctx K e], ∅) ((# v) :: thp, h) →
∃ thp' h' v',
rtc step ([fill_ctx K e'], ∅) ((# v') :: thp', h').
Definition ctx_refines (Γ : list type)
(e e' : expr) (τ : type) := ∀ K thp σ v,
typed_ctx K Γ τ [] TUnit →
rtc step ([fill_ctx K e], ∅) (# v :: thp, σ) →
∃ thp' σ' v', rtc step ([fill_ctx K e'], ∅) (# v' :: thp', σ').
Section bin_log_related_under_typed_context.
Context {Σ : gFunctors} {iI : heapIG Σ} {iS : cfgSG Σ} {N : namespace}.
Implicit Types Δ : varC -n> bivalC -n> iPropG lang Σ.
Section bin_log_related_under_typed_ctx.
Context `{heapIG Σ, cfgSG Σ} {N : namespace}.
Notation D := (prodC valC valC -n> iPropG lang Σ).
Implicit Types Δ : listC D.
Lemma bin_log_related_under_typed_context Γ e e' τ Γ' τ' K :
Lemma bin_log_related_under_typed_ctx Γ e e' τ Γ' τ' K :
(∀ f, e.[base.iter (length Γ) up f] = e) →
(∀ f, e'.[base.iter (length Γ) up f] = e') →
typed_context K Γ τ Γ' τ' →
(∀ Δ {HΔ : ∀ x vw, PersistentP (Δ x vw)},
@bin_log_related _ _ _ N Δ Γ e e' τ HΔ) →
∀ Δ {HΔ : ∀ x vw, PersistentP (Δ x vw)},
@bin_log_related _ _ _ N Δ Γ' (fill_ctx K e) (fill_ctx K e') τ' HΔ.
typed_ctx K Γ τ Γ' τ' →
(∀ Δ (HΔ : ctx_PersistentP Δ), @bin_log_related _ _ _ N Δ Γ e e' τ) →
∀ Δ (HΔ : ctx_PersistentP Δ),
@bin_log_related _ _ _ N Δ Γ' (fill_ctx K e) (fill_ctx K e') τ'.
Proof.
revert Γ τ Γ' τ' e e'.
induction K as [|k K]=> Γ τ Γ' τ' e e' H1 H2; simpl.
......@@ -218,7 +211,7 @@ Section bin_log_related_under_typed_context.
inversion Hx1; subst; simpl.
+ eapply typed_binary_interp_Lam; eauto;
match goal with
H : _ |- _ => eapply (typed_context_n_closed _ _ _ _ _ _ _ H)
H : _ |- _ => eapply (typed_ctx_n_closed _ _ _ _ _ _ _ H)
end.
+ eapply typed_binary_interp_App; eauto using typed_binary_interp.
+ eapply typed_binary_interp_App; eauto using typed_binary_interp.
......@@ -229,7 +222,7 @@ Section bin_log_related_under_typed_context.
+ eapply typed_binary_interp_InjL; eauto.
+ eapply typed_binary_interp_InjR; eauto.
+ match goal with
H : typed_context_item _ _ _ _ _ |- _ => inversion H; subst
H : typed_ctx_item _ _ _ _ _ |- _ => inversion H; subst
end.
eapply typed_binary_interp_Case;
eauto using typed_binary_interp;
......@@ -237,7 +230,7 @@ Section bin_log_related_under_typed_context.
H : _ |- _ => eapply (typed_n_closed _ _ _ H)
end.
+ match goal with
H : typed_context_item _ _ _ _ _ |- _ => inversion H; subst
H : typed_ctx_item _ _ _ _ _ |- _ => inversion H; subst
end.
eapply typed_binary_interp_Case;
eauto using typed_binary_interp;
......@@ -245,10 +238,10 @@ Section bin_log_related_under_typed_context.
H : _ |- _ => eapply (typed_n_closed _ _ _ H)
end;
match goal with
H : _ |- _ => eapply (typed_context_n_closed _ _ _ _ _ _ _ H)
H : _ |- _ => eapply (typed_ctx_n_closed _ _ _ _ _ _ _ H)
end.
+ match goal with
H : typed_context_item _ _ _ _ _ |- _ => inversion H; subst
H : typed_ctx_item _ _ _ _ _ |- _ => inversion H; subst
end.
eapply typed_binary_interp_Case;
eauto using typed_binary_interp;
......@@ -256,25 +249,25 @@ Section bin_log_related_under_typed_context.
H : _ |- _ => eapply (typed_n_closed _ _ _ H)
end;
match goal with
H : _ |- _ => eapply (typed_context_n_closed _ _ _ _ _ _ _ H)
H : _ |- _ => eapply (typed_ctx_n_closed _ _ _ _ _ _ _ H)
end.
+ eapply typed_binary_interp_If;
eauto using typed_context_typed, typed_binary_interp.
eauto using typed_ctx_typed, typed_binary_interp.
+ eapply typed_binary_interp_If;
eauto using typed_context_typed, typed_binary_interp.
eauto using typed_ctx_typed, typed_binary_interp.
+ eapply typed_binary_interp_If;
eauto using typed_context_typed, typed_binary_interp.
eauto using typed_ctx_typed, typed_binary_interp.
+ eapply typed_binary_interp_nat_bin_op;
eauto using typed_context_typed, typed_binary_interp.
eauto using typed_ctx_typed, typed_binary_interp.
+ eapply typed_binary_interp_nat_bin_op;
eauto using typed_context_typed, typed_binary_interp.
eauto using typed_ctx_typed, typed_binary_interp.
+ eapply typed_binary_interp_Fold; eauto.
+ eapply typed_binary_interp_Unfold; eauto.
+ eapply typed_binary_interp_TLam; eauto.
+ eapply typed_binary_interp_TApp; trivial.
+ eapply typed_binary_interp_Fork; trivial.
+ eapply typed_binary_interp_Alloc; trivial.
+ eapply typed_binary_interp_Load; trivial.
+ eapply typed_binary_interp_TLam; eauto with typeclass_instances.
+ eapply typed_binary_interp_TApp; eauto.
+ eapply typed_binary_interp_Fork; eauto.
+ eapply typed_binary_interp_Alloc; eauto.
+ eapply typed_binary_interp_Load; eauto.
+ eapply typed_binary_interp_Store; eauto using typed_binary_interp.
+ eapply typed_binary_interp_Store; eauto using typed_binary_interp.
+ eapply typed_binary_interp_CAS; eauto using typed_binary_interp.
......@@ -282,4 +275,4 @@ Section bin_log_related_under_typed_context.
+ eapply typed_binary_interp_CAS; eauto using typed_binary_interp.
Unshelve. all: trivial.
Qed.
End bin_log_related_under_typed_context.
End bin_log_related_under_typed_ctx.
F_mu_ref_par/examples/counter.v
View file @ ba2fcff2
......@@ -35,8 +35,9 @@ Definition FG_counter : expr :=
App (Lam (FG_counter_body (Var 1))) (Alloc (♯ 0)).
Section CG_Counter.
Context {Σ : gFunctors} {iS : cfgSG Σ} {iI : heapIG Σ}.
Implicit Types Δ : varC -n> bivalC -n> iPropG lang Σ.
Context `{iS : cfgSG Σ, heapIG Σ}.
Notation D := (prodC valC valC -n> iPropG lang Σ).
Implicit Types Δ : listC D.
(* Coarse-grained increment *)
Lemma CG_increment_type x Γ :
......@@ -50,7 +51,7 @@ Section CG_Counter.
Lemma CG_increment_closed (x : expr) :
(∀ f, x.[f] = x) → ∀ f, (CG_increment x).[f] = CG_increment x.
Proof. intros H f. unfold CG_increment. asimpl. rewrite ?H; trivial. Qed.
Proof. intros Hx f. unfold CG_increment. asimpl. rewrite ?Hx; trivial. Qed.
Lemma CG_increment_subst (x : expr) f :
(CG_increment x).[f] = CG_increment x.[f].
......@@ -221,7 +222,7 @@ Section CG_Counter.
Lemma FG_increment_closed (x : expr) :
(∀ f, x.[f] = x) → ∀ f, (FG_increment x).[f] = FG_increment x.
Proof. intros H f. asimpl. unfold FG_increment. rewrite ?H; trivial. Qed.
Proof. intros Hx f. asimpl. unfold FG_increment. rewrite ?Hx; trivial. Qed.
Lemma FG_counter_body_type x Γ :
typed Γ x (Tref TNat) →
......@@ -251,14 +252,14 @@ Section CG_Counter.
Lemma FG_counter_closed f : FG_counter.[f] = FG_counter.
Proof. asimpl; rewrite counter_read_subst; by asimpl. Qed.
Lemma FG_CG_counter_refinement N Δ {HΔ : ∀ x v, PersistentP (Δ x v)} :
Lemma FG_CG_counter_refinement N Δ {HΔ : ctx_PersistentP Δ} :
@bin_log_related _ _ _ N Δ [] FG_counter CG_counter
(TProd (TArrow TUnit TUnit) (TArrow TUnit TNat)) HΔ.
(TProd (TArrow TUnit TUnit) (TArrow TUnit TNat)).
Proof.
(* executing the preambles *)
intros [|v vs] Hlen; simplify_eq.
intros [|v vs] ρ j K [=].
cbn -[FG_counter CG_counter].
iIntros {ρ j K} "(#Hheap & #Hspec & _ & Hj)".
iIntros "(#Hheap & #Hspec & _ & Hj)".
rewrite ?empty_env_subst /CG_counter /FG_counter.
iPvs (steps_newlock _ _ _ j (K ++ [AppRCtx (LamV _)]) _ with "[Hj]")
as {l} "[Hj Hl]"; eauto.
......@@ -358,11 +359,11 @@ End CG_Counter.
Definition Σ := #[auth.authGF heapUR; auth.authGF cfgUR].
Theorem counter_context_refinement :
context_refines [] FG_counter CG_counter
Theorem counter_ctx_refinement :
ctx_refines [] FG_counter CG_counter
(TProd (TArrow TUnit TUnit) (TArrow TUnit TNat)).
Proof.
eapply (@Binary_Soundness Σ);
eapply (@binary_soundness Σ);
auto using FG_counter_closed, CG_counter_closed, FG_CG_counter_refinement.
all: typeclasses eauto.
Qed.
F_mu_ref_par/examples/stack/refinement.v
View file @ ba2fcff2
......@@ -6,11 +6,11 @@ From iris_logrel.F_mu_ref_par.examples.stack Require Import
From iris.proofmode Require Import invariants ghost_ownership tactics.
Section Stack_refinement.
Context {Σ : gFunctors} {iS : cfgSG Σ} {iI : heapIG Σ}
{iSTK : authG lang Σ stackUR}.
Implicit Types Δ : varC -n> bivalC -n> iPropG lang Σ.
Context `{cfgSG Σ, heapIG Σ, authG lang Σ stackUR}.
Notation D := (prodC valC valC -n> iPropG lang Σ).
Implicit Types Δ : listC D.
Lemma FG_CG_counter_refinement N Δ {HΔ : ∀ x vw, PersistentP (Δ x vw)} :
Lemma FG_CG_counter_refinement N Δ {HΔ : ctx_PersistentP Δ} :
@bin_log_related _ _ _ N Δ [] FG_stack CG_stack
(TForall
(TProd
......@@ -19,10 +19,10 @@ Section Stack_refinement.
(TArrow TUnit (TSum TUnit (TVar 0)))
)
(TArrow (TArrow (TVar 0) TUnit) TUnit)
)) HΔ.
)).
Proof.
(* executing the preambles *)
iIntros { [|??] [=] ρ j K } "[#Hheap [#Hspec [_ Hj]]]".
iIntros { [|??] ρ j K [=] } "[#Hheap [#Hspec [_ Hj]]]".
cbn -[FG_stack CG_stack].
rewrite ?empty_env_subst /CG_stack /FG_stack.
iApply wp_value; eauto.
......@@ -64,7 +64,7 @@ Section Stack_refinement.
{ constructor; eauto. eapply ucmra_unit_valid. }
set (istkG := StackG _ _ γ).
change γ with (@stack_name _ istkG).
change iSTK with (@stack_inG _ istkG).
change H1 with (@stack_inG _ istkG).
clearbody istkG. clear γ.
iAssert (@stack_owns _ istkG _ ∅) with "[Hemp]" as "Hoe".
{ unfold stack_owns; rewrite big_sepM_empty; iFrame "Hemp"; trivial. }
......@@ -374,8 +374,8 @@ End Stack_refinement.
Definition Σ := #[authGF heapUR; authGF cfgUR; authGF stackUR].
Theorem stack_context_refinement :
context_refines [] FG_stack CG_stack
Theorem stack_ctx_refinement :
ctx_refines [] FG_stack CG_stack
(TForall
(TProd
(TProd
......@@ -386,8 +386,8 @@ Theorem stack_context_refinement :
)
).
Proof.
eapply (@Binary_Soundness Σ);
eapply (@binary_soundness Σ);
eauto using FG_stack_closed, CG_stack_closed.
all: try typeclasses eauto.
intros. apply FG_CG_counter_refinement.
intros. apply FG_CG_counter_refinement, _.
Qed.
F_mu_ref_par/examples/stack/stack_rules.v
View file @ ba2fcff2
......@@ -20,19 +20,17 @@ Class stackG Σ :=
StackG { stack_inG :> authG lang Σ stackUR; stack_name : gname }.
Section Rules.
Context {Σ : gFunctors} {istk : stackG Σ}.
Context `{stackG Σ}.
Notation D := (prodC valC valC -n> iPropG lang Σ).
Definition stack_mapsto (l : loc) (v: val) : iPropG lang Σ :=
auth_own stack_name ({[ l := DecAgree v ]}).
auth_own stack_name {[ l := DecAgree v ]}.
Notation "l ↦ˢᵗᵏ v" := (stack_mapsto l v) (at level 20) : uPred_scope.
Lemma stack_mapsto_dup l v : True%I ⊢ l ↦ˢᵗᵏ v -★ (l ↦ˢᵗᵏ v ★ l ↦ˢᵗᵏ v).
Lemma stack_mapsto_dup l v : l ↦ˢᵗᵏ v ⊢ l ↦ˢᵗᵏ v ★ l ↦ˢᵗᵏ v.
Proof.
iIntros "H".
unfold stack_mapsto, auth_own.
rewrite -own_op -auth_frag_op.
rewrite -stackR_self_op; trivial.
by rewrite /stack_mapsto /auth_own -own_op -auth_frag_op -stackR_self_op.
Qed.
Lemma stack_mapstos_agree l v w:
......@@ -47,53 +45,37 @@ Section Rules.
cbv -[decide] in Hvalid; destruct decide; trivial.
Qed.
Program Definition StackLink_pre (Q : bivalC -n> iPropG lang Σ)
{HQ : ∀ vw, PersistentP (Q vw)} :
(bivalC -n> iPropG lang Σ) -n> bivalC -n> iPropG lang Σ := λne P v,
Program Definition StackLink_pre (Q : D) : D -n> D := λne P v,
(∃ l w, v.1 = LocV l ★ l ↦ˢᵗᵏ w ★
((w = InjLV UnitV ∧ v.2 = FoldV (InjLV UnitV)) ∨
(∃ y1 z1 y2 z2, w = InjRV (PairV y1 (FoldV z1)) ★
v.2 = FoldV (InjRV (PairV y2 z2)) ★ Q (y1, y2) ★ ▷ P(z1, z2))))%I.
Next Obligation.
intros Q HQ P n [v1 v2] [w1 w2] [Hv1 Hv2]; simpl in *;
by rewrite Hv1 Hv2.
Qed.
Next Obligation. solve_proper. Qed.
Solve Obligations with solve_proper.
Global Instance StackLink_pre_contractive Q {HQ} :
Contractive (@StackLink_pre Q HQ).
Global Instance StackLink_pre_contractive Q : Contractive (StackLink_pre Q).
Proof.
intros n P1 P2 HP v; simpl. repeat (apply exist_ne => ?).
repeat apply sep_ne; trivial. rewrite or_ne; trivial.
repeat (apply exist_ne => ?).
repeat apply sep_ne; trivial.
apply later_contractive => i H. by apply HP.
apply later_contractive => i ?. by apply HP.
Qed.
Definition StackLink Q {HQ} := fixpoint (@StackLink_pre Q HQ).
Definition StackLink Q := fixpoint (StackLink_pre Q).
Lemma StackLink_unfold Q {HQ} v :
@StackLink Q HQ v ≡
(∃ l w, v.1 = LocV l ★ l ↦ˢᵗᵏ w ★
((w = InjLV UnitV ∧
v.2 = FoldV (InjLV UnitV)) ∨
(∃ y1 z1 y2 z2,
(w = InjRV (PairV y1 (FoldV z1)))
★ (v.2 = FoldV (InjRV (PairV y2 z2)))
★ Q (y1, y2)
★ ▷ @StackLink Q HQ (z1, z2)
)
)
)%I.
Proof.
unfold StackLink at 1.
rewrite fixpoint_unfold; trivial.
Qed.
Lemma StackLink_unfold Q v :
StackLink Q v ≡ (∃ l w,
v.1 = LocV l ★ l ↦ˢᵗᵏ w ★
((w = InjLV UnitV ∧ v.2 = FoldV (InjLV UnitV)) ∨
(∃ y1 z1 y2 z2, w = InjRV (PairV y1 (FoldV z1))
★ v.2 = FoldV (InjRV (PairV y2 z2))
★ Q (y1, y2) ★ ▷ @StackLink Q (z1, z2))))%I.
Proof. by rewrite {1}/StackLink fixpoint_unfold. Qed.
Global Opaque StackLink. (* So that we can only use the unfold above. *)
Lemma StackLink_dup Q {HQ} v :
@StackLink Q HQ v ⊢ @StackLink Q HQ v ★ @StackLink Q HQ v.
Lemma StackLink_dup (Q : D) v `{∀ vw, PersistentP (Q vw)} :
StackLink Q v ⊢ StackLink Q v ★ StackLink Q v.
Proof.
iIntros "H". iLöb {v} as "Hlat". rewrite StackLink_unfold.
iDestruct "H" as {l w} "[% [Hl Hr]]"; subst.
......@@ -113,8 +95,8 @@ Section Rules.
Lemma stackR_valid (h : stackUR) (i : loc) :