diff --git a/.gitmodules b/.gitmodules index 5defec0..6f396f9 100644 --- a/.gitmodules +++ b/.gitmodules @@ -7,3 +7,6 @@ [submodule "external/paco"] path = external/paco url = https://github.com/snu-sf/paco.git +[submodule "external/coq-record-update"] + path = external/coq-record-update + url = https://github.com/tchajed/coq-record-update.git diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 0000000..4aa9673 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,15 @@ +{ + "files.exclude": { + "**/*.vo": true, + "**/*.vok": true, + "**/*.vos": true, + "**/*.aux": true, + "**/*.glob": true, + "**/.git": true, + "**/.svn": true, + "**/.hg": true, + "**/CVS": true, + "**/.DS_Store": true, + "**/Thumbs.db": true + } +} \ No newline at end of file diff --git a/Makefile b/Makefile index a0f3c39..6c23421 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ TRILLIUM_DIR := 'trillium' -FAIRIS_DIR := 'fairis' -LOCAL_SRC_DIRS := $(TRILLIUM_DIR) $(FAIRIS_DIR) +FAIRNERIS_DIR := 'fairneris' +LOCAL_SRC_DIRS := $(TRILLIUM_DIR) $(FAIRNERIS_DIR) SRC_DIRS := $(LOCAL_SRC_DIRS) 'external' ALL_VFILES := $(shell find $(SRC_DIRS) -name "*.v") @@ -43,15 +43,15 @@ clean: rm -f .coqdeps.d # project-specific targets -.PHONY: build clean-trillium clean-fairis trillium fairis +.PHONY: build clean-trillium clean-fairis clean-fairneris trillium fairis fairneris -VPATH= $(TRILLIUM_DIR) $(FAIRIS_DIR) +VPATH= $(TRILLIUM_DIR) $(FAIRNERIS_DIR) VPATH_FILES := $(shell find $(VPATH) -name "*.v") build: $(VPATH_FILES:.v=.vo) -fairis : - @$(MAKE) build VPATH=$(FAIRIS_DIR) +fairneris : + @$(MAKE) build VPATH=$(FAIRNERIS_DIR) trillium : @$(MAKE) build VPATH=$(TRILLIUM_DIR) @@ -64,5 +64,5 @@ clean-local: clean-trillium: @$(MAKE) clean-local LOCAL_SRC_DIRS=$(TRILLIUM_DIR) -clean-fairis: - @$(MAKE) clean-local LOCAL_SRC_DIRS=$(FAIRIS_DIR) +clean-fairneris: + @$(MAKE) clean-local LOCAL_SRC_DIRS=$(FAIRNERIS_DIR) diff --git a/_CoqProject b/_CoqProject index 03cc163..9a10a84 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,5 +1,5 @@ -Q trillium trillium --Q fairis trillium.fairness +-Q fairneris fairneris -Q external/stdpp/stdpp stdpp -Q external/stdpp/stdpp_unstable stdpp.unstable @@ -8,6 +8,7 @@ -Q external/iris/iris_unstable iris.unstable -Q external/iris/iris_heap_lang iris.heap_lang -Q external/paco/src Paco +-Q external/coq-record-update/src RecordUpdate -arg -w -arg -notation-overridden -arg -w -arg -redundant-canonical-projection @@ -19,3 +20,4 @@ -arg -w -arg -deprecated-instance-without-locality -arg -w -arg -deprecated-typeclasses-transparency-without-locality -arg -w -arg -future-coercion-class-field +-arg -w -arg -argument-scope-delimiter diff --git a/external/coq-record-update b/external/coq-record-update new file mode 160000 index 0000000..b49883f --- /dev/null +++ b/external/coq-record-update @@ -0,0 +1 @@ +Subproject commit b49883f4f73c3d98f832591fd67aabe88032fbcc diff --git a/external/iris b/external/iris index ab54fb2..93cb01f 160000 --- a/external/iris +++ b/external/iris @@ -1 +1 @@ -Subproject commit ab54fb217c0bbeca90c36c4ae0530b3397caed05 +Subproject commit 93cb01fc6f5f30d04eefd3b074e772ea8480ff45 diff --git a/external/paco b/external/paco index 7f10f14..5c5693f 160000 --- a/external/paco +++ b/external/paco @@ -1 +1 @@ -Subproject commit 7f10f146f84591236f1ddccb0c75b56cedbdf34e +Subproject commit 5c5693f46c8957f36a2349a0d906e911366136de diff --git a/external/stdpp b/external/stdpp index 800125d..cafd711 160000 --- a/external/stdpp +++ b/external/stdpp @@ -1 +1 @@ -Subproject commit 800125de4733a99e52b2256f0b63eb466811491c +Subproject commit cafd7113aa964724370c43379ab898bb997f3866 diff --git a/fairis/map_included_utils.v b/fairis/map_included_utils.v index 81ede31..e69eb39 100644 --- a/fairis/map_included_utils.v +++ b/fairis/map_included_utils.v @@ -145,13 +145,13 @@ Proof. rewrite !map_included_spec. intros HP Hle k v1 HSome1. pose proof HSome1 as HP'. - apply map_filter_lookup_Some_1_1 in HSome1. - apply map_filter_lookup_Some_1_2 in HP'. + apply map_lookup_filter_Some_1_1 in HSome1. + apply map_lookup_filter_Some_1_2 in HP'. pose proof HSome1 as HSome2. apply Hle in HSome2 as [v2 [HSome2 HR]]. specialize (HP k v1 v2 HSome1 HSome2 HP'). exists v2. split; [|done]. - by apply map_filter_lookup_Some_2. + by apply map_lookup_filter_Some_2. Qed. Lemma map_included_subseteq_r `{∀ A, Lookup K A (MAP A)} {A} diff --git a/fairneris/algebra/disj_gsets.v b/fairneris/algebra/disj_gsets.v new file mode 100644 index 0000000..5c950e3 --- /dev/null +++ b/fairneris/algebra/disj_gsets.v @@ -0,0 +1,209 @@ +From stdpp Require Export sets gmap mapset. +From iris.algebra Require Export cmra. +From iris.algebra Require Import updates local_updates big_op. + +Record disj_gsets K `{Countable K} := DGSets { dgsets_of : (gset (gset K)) }. +Global Arguments dgsets_of {_ _ _} _. +Global Arguments DGSets {_ _ _} _. + +Definition eq_or_disj `{Countable K} (X Y : gset K) : Prop := + X = Y ∨ X ## Y. + +Lemma eq_or_disj_comm `{Countable K} (x y : gset K) : + eq_or_disj x y → eq_or_disj y x. +Proof. rewrite /eq_or_disj. intros [Hdisj | Hidjs]; eauto. Qed. + +Lemma eq_or_disj_singleton `{Countable K} (x y : K) : + eq_or_disj {[x]} {[y]}. +Proof. rewrite /eq_or_disj. destruct (decide (x = y)); set_solver. Qed. + +Section disj_gsets. + Context `{Countable K}. + Local Arguments op _ _ !_ !_ /. + Local Arguments cmra_op _ !_ !_ /. + Local Arguments ucmra_op _ !_ !_ /. + + Canonical Structure disj_gsetsO := leibnizO (disj_gsets K). + + Definition have_disj_elems (X Y : gset (gset K)) : Prop := + ∀ x y, x ∈ X → y ∈ Y → eq_or_disj x y. + + Definition all_disjoint (X : gset (gset K)) : Prop := have_disj_elems X X. + + Local Instance disj_gsets_valid_instance : Valid (disj_gsets K) := + λ X, all_disjoint (dgsets_of X). + Local Instance disj_gsets_unit_instance : Unit (disj_gsets K) := DGSets ∅. + Local Instance disj_gsets_op_instance : Op (disj_gsets K) := + λ X Y, DGSets (dgsets_of X ∪ dgsets_of Y). + Local Instance disj_gsets_pcore_instance : PCore (disj_gsets K) := λ x, Some x. + + Lemma have_disj_elems_comm X Y : have_disj_elems X Y → have_disj_elems Y X. + Proof. intros HXY x y ??; destruct (HXY y x); rewrite /eq_or_disj; auto. Qed. + + Lemma all_disjoint_union X Y : + (all_disjoint X ∧ all_disjoint Y ∧ have_disj_elems X Y) ↔ all_disjoint (X ∪ Y). + Proof. + split. + - intros (HX & HY & HXY) x y [Hx|Hx]%elem_of_union [Hy|Hy]%elem_of_union. + + by apply HX. + + by apply HXY. + + apply have_disj_elems_comm in HXY. by apply HXY. + + by apply HY. + - intros HXY; split_and!. + + intros ????; apply HXY; set_solver. + + intros ????; apply HXY; set_solver. + + intros ????; apply HXY; set_solver. + Qed. + + Lemma have_disj_elems_subseteq X Y X' Y' : + X ⊆ X' → Y ⊆ Y' → have_disj_elems X' Y' → have_disj_elems X Y. + Proof. intros ?? HX'Y' ????; apply HX'Y'; set_solver. Qed. + + Lemma have_disj_elems_singleton z X : + (∀ x, x ∈ X → z = x ∨ z ## x) ↔ have_disj_elems {[z]} X. + Proof. + split. + - intros Hz ? y ->%elem_of_singleton ?; apply Hz; done. + - intros HX x Hx; apply HX; set_solver. + Qed. + + Lemma have_disj_elems_union X Y Z : + have_disj_elems X Y → + have_disj_elems X Z → + have_disj_elems X (Y ∪ Z). + Proof. + intros Hdisj1 Hdisj2. + intros y1 y2 Hin1 Hin2%elem_of_union. + destruct Hin2 as [Hin2|Hin2]. + - by apply Hdisj1. + - by apply Hdisj2. + Qed. + + Lemma have_disj_elems_union_2 X Y Z : + all_disjoint Z → + have_disj_elems X Z → + have_disj_elems Y Z → + have_disj_elems X Y → + have_disj_elems (X ∪ Z) (Y ∪ Z). + Proof. + intros Hdisj HdisjXZ HdisjYZ HdisjXY. + apply have_disj_elems_union. + - apply have_disj_elems_comm. + apply have_disj_elems_union; + [ apply have_disj_elems_comm, HdisjXY | apply HdisjYZ ]. + - apply have_disj_elems_comm. + apply have_disj_elems_union; + [ apply have_disj_elems_comm, HdisjXZ | apply Hdisj ]. + Qed. + + Lemma all_disjoint_subseteq X X' : X ⊆ X' → all_disjoint X' → all_disjoint X. + Proof. intros ? ?; eapply have_disj_elems_subseteq; eauto. Qed. + + Lemma all_disjoint_singleton z : all_disjoint {[z]}. + Proof. apply have_disj_elems_singleton; set_solver. Qed. + + Lemma elem_of_all_disjoint_eq x1 x2 x (X : gset (gset K)) : + all_disjoint X → x1 ∈ X → x2 ∈ X → x ∈ x1 → x ∈ x2 → x1 = x2. + Proof. + intros Hdisj Hin1 Hin2 Hxin1 Hxin2. + destruct (Hdisj x1 x2 Hin1 Hin2) as [->|Hdisj']; [done|]. + by specialize (Hdisj' x Hxin1 Hxin2). + Qed. + + Lemma elem_of_all_disjoint_neq x1 x2 x (X : gset (gset K)) : + all_disjoint X → x1 ∈ X → x2 ∈ X → x ∈ x1 → x ∉ x2 → x1 ## x2. + Proof. + intros Hdisj Hin1 Hin2 Hxin1 Hxin2. + destruct (Hdisj x1 x2 Hin1 Hin2) as [->|Hdisj']; [done|done]. + Qed. + + Lemma disjoint_empty_ne (X Y : gset K) : + X ## Y → X ≠ ∅ → Y ≠ ∅ → X ≠ Y. + Proof. intros Hdisj HX HY. set_solver. Qed. + + Lemma have_disj_elems_both_singletons x y : have_disj_elems {[x]} {[y]} ↔ x = y ∨ x ## y. + Proof. rewrite -have_disj_elems_singleton; set_solver. Qed. + + Lemma have_disj_elems_empty X : have_disj_elems ∅ X. + Proof. intros ? y ?%elem_of_empty; done. Qed. + + Lemma all_disjoint_empty : all_disjoint ∅. + Proof. apply have_disj_elems_empty. Qed. + + Lemma disj_gsets_included X Y : DGSets X ≼ DGSets Y ↔ X ⊆ Y. + Proof. + split. + - move=> [[Z]]; rewrite /= /disj_gsets_op_instance /=; set_solver. + - intros (Z&->&?)%subseteq_disjoint_union_L. + exists (DGSets Z); done. + Qed. + Lemma disj_gsets_valid (X : gset (gset K)) : + ✓ (DGSets X) ↔ all_disjoint X. + Proof. done. Qed. + Lemma disj_gsets_valid_op X Y : + ✓ (DGSets X ⋅ DGSets Y) ↔ all_disjoint X ∧ all_disjoint Y ∧ have_disj_elems X Y. + Proof. rewrite all_disjoint_union; done. Qed. + Lemma disj_gsets_valid_op_singletons_disjoint x y : + ✓ (DGSets {[x]} ⋅ DGSets {[y]}) ↔ x = y ∨ x ## y. + Proof. + rewrite disj_gsets_valid_op have_disj_elems_both_singletons. + split; [tauto|by auto using all_disjoint_singleton]. + Qed. + Lemma disj_gsets_op_union X Y : DGSets X ⋅ DGSets Y = DGSets (X ∪ Y). + Proof. done. Qed. + + Lemma disj_gsets_ra_mixin : RAMixin (disj_gsets K). + Proof. + apply ra_total_mixin. + - eauto. + - intros [X] [] [] ?%leibniz_equiv; simplify_eq; done. + - intros ?? ->%leibniz_equiv; done. + - intros ?? ->%leibniz_equiv; done. + - intros [] [] []; rewrite /= /disj_gsets_op_instance /= assoc_L; done. + - intros [] []; rewrite /= /disj_gsets_op_instance /= comm_L; done. + - intros []; rewrite /= /disj_gsets_op_instance /= union_idemp_L; done. + - done. + - done. + - intros [] []; rewrite disj_gsets_valid_op; intros (?&?&?); done. + Qed. + Canonical Structure disj_gsetsR := discreteR (disj_gsets K) disj_gsets_ra_mixin. + + Global Instance disj_gsets_cmra_discrete : CmraDiscrete disj_gsetsR. + Proof. apply discrete_cmra_discrete. Qed. + + Global Instance disj_gsets_core_id X : CoreId (DGSets X). + Proof. by constructor. Qed. + + Lemma disj_gsets_ucmra_mixin : UcmraMixin (disj_gsets K). + Proof. + split; [done| |done]. + intros [X]; rewrite /= /disj_gsets_op_instance /=; f_equiv; set_solver. + Qed. + Canonical Structure disj_gsetsUR := Ucmra (disj_gsets K) disj_gsets_ucmra_mixin. + + Local Arguments op _ _ _ _ : simpl never. + + Lemma disj_gsets_alloc_op_local_update X Y Z : + all_disjoint Z → + have_disj_elems Z X → + (DGSets X, DGSets Y) ~l~> (DGSets Z ⋅ DGSets X, DGSets Z ⋅ DGSets Y). + Proof. intros; apply op_local_update_discrete; rewrite disj_gsets_valid_op; done. Qed. + Lemma disj_gsets_alloc_union_local_update X Y Z : + all_disjoint Z → + have_disj_elems Z X → + (DGSets X, DGSets Y) ~l~> (DGSets (Z ∪ X), DGSets (Z ∪ Y)). + Proof. apply disj_gsets_alloc_op_local_update. Qed. + + Lemma disj_gset_alloc_empty_local_update X Z : + all_disjoint Z → + have_disj_elems Z X → + (DGSets X, DGSets ∅) ~l~> (DGSets (Z ∪ X), DGSets Z). + Proof. + intros. rewrite -{2}(right_id_L _ union Z). + apply disj_gsets_alloc_union_local_update; done. + Qed. +End disj_gsets. + +Global Arguments disj_gsetsO _ {_ _}. +Global Arguments disj_gsetsR _ {_ _}. +Global Arguments disj_gsetsUR _ {_ _}. diff --git a/fairneris/algebra/monotone.v b/fairneris/algebra/monotone.v new file mode 100644 index 0000000..9304bfc --- /dev/null +++ b/fairneris/algebra/monotone.v @@ -0,0 +1,315 @@ +From iris.algebra Require Export cmra auth. +From iris.base_logic Require Import base_logic. +Local Arguments validN _ _ _ !_ /. +Local Arguments valid _ _ !_ /. +Local Arguments op _ _ _ !_ /. +Local Arguments pcore _ _ !_ /. +Local Arguments ofe_dist !_ /. +Local Arguments ofe_equiv ! _ /. + +Definition monotone {A : Type} (R : relation A) : Type := list A. + +Definition principal {A : Type} (R : relation A) (a : A) : + monotone R := [a]. + +Section monotone. +Local Set Default Proof Using "Type". +Context {A : ofe} {R : relation A}. +Implicit Types a b : A. +Implicit Types x y : monotone R. + +Definition Below (a : A) (x : monotone R) := ∃ b, b ∈ x ∧ R a b. + +Lemma Below_app a x y : Below a (x ++ y) ↔ Below a x ∨ Below a y. +Proof. + split. + - intros (b & [|]%elem_of_app & ?); [left|right]; exists b; eauto. + - intros [(b & Hb1 & Hb2)|(b & Hb1 & Hb2)]; exists b; rewrite elem_of_app; eauto. +Qed. + +Lemma Below_principal a b : Below a (principal R b) ↔ R a b. +Proof. + split. + - intros (c & ->%elem_of_list_singleton & ?); done. + - intros Hab; exists b; split; first apply elem_of_list_singleton; done. +Qed. + +(* OFE *) +Instance monotone_dist : Dist (monotone R) := + λ n x y, ∀ a, Below a x ↔ Below a y. + +Instance monotone_equiv : Equiv (monotone R) := λ x y, ∀ n, x ≡{n}≡ y. + +Definition monotone_ofe_mixin : OfeMixin (monotone R). +Proof. + split. + - rewrite /equiv /monotone_equiv /dist /monotone_dist; intuition auto using O. + - intros n; split. + + rewrite /dist /monotone_dist /equiv /monotone_equiv; intuition. + + rewrite /dist /monotone_dist /equiv /monotone_equiv; intros ? ? Heq a. + split; apply Heq. + + rewrite /dist /monotone_dist /equiv /monotone_equiv; + intros ? ? ? Heq Heq' a. + split; intros Hxy. + * apply Heq'; apply Heq; auto. + * apply Heq; apply Heq'; auto. + - intros n x y; rewrite /dist /monotone_dist; auto. +Qed. +Canonical Structure monotoneC := Ofe (monotone R) monotone_ofe_mixin. + +(* CMRA *) +Instance monotone_validN : ValidN (monotone R) := λ n x, True. +Instance monotone_valid : Valid (monotone R) := λ x, True. + +Program Instance monotone_op : Op (monotone R) := λ x y, x ++ y. +Instance monotone_pcore : PCore (monotone R) := Some. + +Instance monotone_comm : Comm (≡) (@op (monotone R) _). +Proof. + intros x y n a; rewrite /Below. + setoid_rewrite elem_of_app; split=> Ha; firstorder. +Qed. +Instance monotone_assoc : Assoc (≡) (@op (monotone R) _). +Proof. + intros x y z n a; rewrite /Below /=. + repeat setoid_rewrite elem_of_app; split=> Ha; firstorder. +Qed. +Lemma monotone_idemp (x : monotone R) : x ⋅ x ≡ x. +Proof. + intros n a; rewrite /Below. + setoid_rewrite elem_of_app; split=> Ha; firstorder. +Qed. + +Instance monotone_validN_ne n : + Proper (dist n ==> impl) (@validN (monotone R) _ n). +Proof. intros x y ?; rewrite /impl; auto. Qed. +Instance monotone_validN_proper n : Proper (equiv ==> iff) (@validN (monotone R) _ n). +Proof. move=> x y /equiv_dist H; auto. Qed. + +Instance monotone_op_ne' x : NonExpansive (op x). +Proof. + intros n y1 y2; rewrite /dist /monotone_dist /equiv /monotone_equiv /Below. + rewrite /=; setoid_rewrite elem_of_app => Heq a. + specialize (Heq a); destruct Heq as [Heq1 Heq2]. + split; intros [b [[Hb|Hb] HRb]]; eauto. + - destruct Heq1 as [? [? ?]]; eauto. + - destruct Heq2 as [? [? ?]]; eauto. +Qed. +Instance monotone_op_ne : NonExpansive2 (@op (monotone R) _). +Proof. by intros n x1 x2 Hx y1 y2 Hy; rewrite Hy !(comm _ _ y2) Hx. Qed. +Instance monotone_op_proper : + Proper ((≡) ==> (≡) ==> (≡)) (@op (monotone R) _) := ne_proper_2 _. + +Lemma monotone_included (x y : monotone R) : x ≼ y ↔ y ≡ x ⋅ y. +Proof. + split; [|by intros ?; exists y]. + by intros [z Hz]; rewrite Hz assoc monotone_idemp. +Qed. + +Definition monotone_cmra_mixin : CmraMixin (monotone R). +Proof. + apply cmra_total_mixin; try apply _ || by eauto. + - intros ?; apply monotone_idemp. + - rewrite /equiv /monotone_equiv /dist /monotone_dist; eauto. +Qed. +Canonical Structure monotoneR : cmra := Cmra (monotone R) monotone_cmra_mixin. + +Global Instance monotone_cmra_total : CmraTotal monotoneR. +Proof. rewrite /CmraTotal; eauto. Qed. +Global Instance monotone_core_id (x : monotone R) : CoreId x. +Proof. by constructor. Qed. + +Global Instance monotone_cmra_discrete : CmraDiscrete monotoneR. +Proof. + split; auto. + intros ? ?. + rewrite /dist /equiv /= /cmra_dist /cmra_equiv /= + /monotone_dist /monotone_equiv /dist /monotone_dist; eauto. +Qed. + +Instance monotone_empty : Unit (monotone R) := @nil A. +Lemma auth_ucmra_mixin : UcmraMixin (monotone R). +Proof. split; done. Qed. + +Canonical Structure monotoneUR := Ucmra (monotone R) auth_ucmra_mixin. + +Global Instance principal_ne + `{HRne : !∀ n, Proper ((dist n) ==> (dist n) ==> iff) R} : + NonExpansive (principal R). +Proof. intros n a1 a2 Ha; split; rewrite /= !Below_principal !Ha; done. Qed. + +Global Instance principal_proper + {HRne : ∀ n, Proper ((dist n) ==> (dist n) ==> iff) R} : + Proper ((≡) ==> (≡)) (principal R) := ne_proper _. + +Global Instance principal_discrete a : Discrete (principal R a). +Proof. + intros y; rewrite /dist /ofe_dist /= /equiv /ofe_equiv /= /monotone_equiv; + eauto. +Qed. + +Lemma principal_injN_general n a b : + principal R a ≡{n}≡ principal R b → R a a → R a b. +Proof. + rewrite /principal /dist /monotone_dist => Hab Haa. + - destruct (Hab a) as [Ha _]; edestruct Ha as [? [?%elem_of_list_singleton ?]]; + subst; eauto. + eexists _; split; first apply elem_of_list_singleton; eauto. +Qed. + +Lemma principal_inj_general a b : + principal R a ≡ principal R b → R a a → R a b. +Proof. intros Hab; apply (principal_injN_general 0); eauto. Qed. + +Global Instance principal_injN_general' `{!Reflexive R} n : + Inj (λ a b, R a b ∧ R b a) (dist n) (principal R). +Proof. + intros x y Hxy; split; eapply (principal_injN_general n); eauto. +Qed. + +Global Instance principal_inj_general' `{!Reflexive R} : + Inj (λ a b, R a b ∧ R b a) (≡) (principal R). +Proof. + intros x y Hxy; specialize (Hxy 0); eapply principal_injN_general'; eauto. +Qed. + +Global Instance principal_injN `{!Reflexive R} {Has : AntiSymm (≡) R} n : + Inj (dist n) (dist n) (principal R). +Proof. + intros x y [Hxy Hyx]%principal_injN_general'. + erewrite (@anti_symm _ _ _ Has); eauto. +Qed. +Global Instance principal_inj `{!Reflexive R} `{!AntiSymm (≡) R} : + Inj (≡) (≡) (principal R). +Proof. intros ???. apply equiv_dist=>n. by apply principal_injN, equiv_dist. Qed. + +Lemma principal_R_opN_base `{!Transitive R} n x y : + (∀ b, b ∈ y → ∃ c, c ∈ x ∧ R b c) → y ⋅ x ≡{n}≡ x. +Proof. + intros HR; split; rewrite /op /monotone_op Below_app; [|by firstorder]. + intros [(c & (d & Hd1 & Hd2)%HR & Hc2)|]; [|done]. + exists d; split; [|transitivity c]; done. +Qed. + +Lemma principal_R_opN `{!Transitive R} n a b : + R a b → principal R a ⋅ principal R b ≡{n}≡ principal R b. +Proof. + intros; apply principal_R_opN_base; intros c; rewrite /principal. + setoid_rewrite elem_of_list_singleton => ->; eauto. +Qed. + +Lemma principal_R_op `{!Transitive R} a b : + R a b → principal R a ⋅ principal R b ≡ principal R b. +Proof. by intros ? ?; apply principal_R_opN. Qed. + +Lemma principal_op_RN n a b x : + R a a → principal R a ⋅ x ≡{n}≡ principal R b → R a b. +Proof. + intros Ha HR. + destruct (HR a) as [[z [HR1%elem_of_list_singleton HR2]] _]; + last by subst; eauto. + rewrite /op /monotone_op /principal Below_app Below_principal; auto. +Qed. + +Lemma principal_op_R a b x : + R a a → principal R a ⋅ x ≡ principal R b → R a b. +Proof. intros ? ?; eapply (principal_op_RN 0); eauto. Qed. + +Lemma principal_op_R' `{!Reflexive R} a b x : + principal R a ⋅ x ≡ principal R b → R a b. +Proof. intros; eapply principal_op_R; eauto. Qed. + +Lemma principal_includedN `{!PreOrder R} n a b : + principal R a ≼{n} principal R b ↔ R a b. +Proof. + split. + - intros [z Hz]; eapply principal_op_RN; last by rewrite Hz; eauto. + reflexivity. + - intros ?; exists (principal R b); rewrite principal_R_opN; eauto. +Qed. + +Lemma principal_included `{!PreOrder R} a b : + principal R a ≼ principal R b ↔ R a b. +Proof. + split. + - intros [z Hz]; eapply principal_op_R; last by rewrite Hz; eauto. + reflexivity. + - intros ?; exists (principal R b); rewrite principal_R_op; eauto. +Qed. + +(** Internalized properties *) +Lemma monotone_equivI `{!(∀ n : nat, Proper (dist n ==> dist n ==> iff) R)} + `{!Reflexive R} `{!AntiSymm (≡) R} {M} a b : + principal R a ≡ principal R b ⊣⊢ (a ≡ b : uPred M). +Proof. + uPred.unseal. do 2 split. + - intros Hx. exact: principal_injN. + - intros Hx. exact: principal_ne. +Qed. + +Lemma monotone_local_update_grow `{!Transitive R} a q na: + R a na → + (principal R a, q) ~l~> (principal R na, principal R na). +Proof. + intros Hana Hanb. + apply local_update_unital_discrete. + intros z _ Habz. + split; first done. + intros n; specialize (Habz n). + intros x; split. + - intros (y & ->%elem_of_list_singleton & Hy2). + by exists na; split; first constructor. + - intros (y & [->|Hy1]%elem_of_cons & Hy2). + + by exists na; split; first constructor. + + exists na; split; first constructor. + specialize (Habz x) as [_ [c [->%elem_of_list_singleton Hc2]]]. + { exists y; split; first (by apply elem_of_app; right); eauto. } + etrans; eauto. +Qed. + +Lemma monotone_local_update_get_frag `{!PreOrder R} a na: + R na a → + (principal R a, ε) ~l~> (principal R a, principal R na). +Proof. + intros Hana. + apply local_update_unital_discrete. + intros z _. + rewrite left_id. + intros <-. + split; first done. + apply monotone_included. + by apply principal_included. +Qed. + +Lemma monotone_update `{!PreOrder R} a b c: + R a b → + R c b → + ● principal R a ~~> ● principal R b ⋅ ◯ principal R c. +Proof. + intros Hab Hcb. + etrans. + { apply auth_update_alloc; apply (monotone_local_update_grow _ _ b); done. } + etrans; first apply cmra_update_op_l. + apply auth_update_alloc. + apply monotone_local_update_get_frag; done. +Qed. + + +End monotone. + +Arguments monotoneC {_} _. +Arguments monotoneR {_} _. +Arguments monotoneUR {_} _. + + +(** Having an instance of this class for a relation R allows almost +all lemmas provided in this module to be used. See type classes +required by some of preceding the lemmas and instances in the to see +how this works. + +The only lemma that requires extra conditions on R is the injectivity +of principal which requires antisymmetry. *) +Class ProperPreOrder {A : Type} `{Dist A} (R : relation A) := { + ProperPreOrder_preorder :> PreOrder R; + ProperPreOrder_ne :> ∀ n, Proper ((dist n) ==> (dist n) ==> iff) R +}. diff --git a/fairneris/aneris_lang/adequacy.v b/fairneris/aneris_lang/adequacy.v new file mode 100644 index 0000000..28d207e --- /dev/null +++ b/fairneris/aneris_lang/adequacy.v @@ -0,0 +1,918 @@ +From Paco Require Import pacotac. +From stdpp Require Import finite. +From iris.proofmode Require Import proofmode. +From iris.algebra Require Import excl. +From trillium Require Import adequacy. +From trillium.prelude Require Import relations. +From fairneris Require Import fairness retransmit_model fair_resources. +From fairneris.aneris_lang Require Import aneris_lang resources network_model. +From fairneris.aneris_lang.state_interp Require Import state_interp_def. +From fairneris.aneris_lang.state_interp Require Import state_interp_config_wp. +From fairneris.aneris_lang.state_interp Require Import state_interp. +From fairneris.aneris_lang.program_logic Require Import aneris_weakestpre. +From fairneris Require Import from_locale_utils trace_utils ltl_lite fuel_jm_scheduling_fairness. + +(* TODO: Move to stdpp *) +Lemma gset_union_difference_intersection_L `{Countable A} (X Y : gset A) : + X = (X ∖ Y) ∪ (X ∩ Y). +Proof. rewrite union_intersection_l_L difference_union_L. set_solver. Qed. + +(* TODO: Move *) +Definition tr_starts_in {S L} (tr : trace S L) (s : S) := trfirst tr = s. + +Definition extrace_property {Λ} (c : cfg Λ) (Φ : extrace Λ → Prop) := + ∀ extr, tr_starts_in extr c → extrace_valid extr → Φ extr. + +Lemma extrace_property_impl {Λ} c (Φ Ψ : extrace Λ → Prop) : + extrace_property c Φ → + (∀ extr, tr_starts_in extr c → extrace_valid extr → Φ extr → Ψ extr) → + extrace_property c Ψ. +Proof. intros HΦ Himpl extr Hstarts Hvalid. by apply Himpl, HΦ. Qed. + +Definition valid_state_evolution_fairness `(LM: LiveModel aneris_lang M) + (extr : execution_trace aneris_lang) + (auxtr : auxiliary_trace (live_model_to_model LM)) := + trace_steps LM.(lm_ls_trans) auxtr ∧ + trace_labels_match extr auxtr ∧ + live_tids (LM := LM) (trace_last extr) (trace_last auxtr). + +Definition trace_last_label {A L} (ft : finite_trace A L) : option L := + match ft with + | {tr[a]} => None + | _ :tr[ℓ]: _ => Some ℓ + end. + +Lemma rel_finitary_valid_state_evolution_fairness `(LM: LiveModel aneris_lang M): + rel_finitary (valid_state_evolution_fairness LM). +Proof. Admitted. + +(* Lemma derive_live_tid_inl c δ (ℓ : fmrole retransmit_fair_model) ζ : *) +(* role_enabled_locale_exists c δ → *) +(* locale_dead_role_disabled c δ → *) +(* live_tid c δ ℓ ζ. *) +(* Proof. *) +(* intros Himpl1 Himpl2 Hmatch Hrole. *) +(* specialize (Himpl1 _ _ Hmatch Hrole) as [e He]. *) +(* exists e. *) +(* split; [done|]. *) +(* destruct (language.to_val e) eqn:Heqn; [|done]. *) +(* specialize (Himpl2 _ _ Hmatch e He). *) +(* assert (is_Some $ language.to_val e) as Hsome by done. *) +(* by specialize (Himpl2 Hsome). *) +(* Qed. *) + +(* Lemma valid_state_live_tids ex atr : *) +(* simple_valid_state_evolution ex atr → *) +(* locale_dead_role_disabled (trace_last ex) (trace_last atr) → *) +(* live_tids (trace_last ex) (trace_last atr). *) +(* Proof. *) +(* intros (_&_&Hlive1&Hnm) Hlive2 ℓ ζ Hlabels. *) +(* by apply derive_live_tid_inl. *) +(* Qed. *) + +(* Lemma posts_of_empty_mapping `(M: UserModel aneris_lang) `{@anerisG M net_model LM Σ} *) +(* (e1 e: aneris_expr) v (tid : locale aneris_lang) (tp : list aneris_expr): *) +(* from_locale tp tid = Some e -> *) +(* to_val e = Some v -> *) +(* posts_of tp *) +(* ((λ (_ : aneris_val), (locale_of [] e) ↦M ∅) :: (map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from [e1] (drop (length [e1]) tp)))) -∗ *) +(* tid ↦M (∅ : gmap (usr_role M) nat). *) +(* Proof. *) +(* intros Hsome Hval. simpl. *) +(* rewrite (big_sepL_elem_of (λ x, x.2 x.1) _ (v, (λ _: val, tid ↦M ∅)%I) _) //. *) +(* apply elem_of_list_omap. *) +(* exists (e, (λ _: val, tid ↦M ∅)%I); split; last first. *) +(* - simpl. apply fmap_Some. exists v. split; done. *) +(* - destruct tp as [|e1' tp]; first set_solver. simpl. *) +(* apply elem_of_cons. *) +(* destruct tid as [|tid]; [left|right]; first by simpl in Hsome; simplify_eq. *) +(* apply elem_of_lookup_zip_with. eexists tid, e, _. do 2 split =>//. *) +(* rewrite /locale_of /=. *) +(* rewrite list_lookup_fmap fmap_Some. simpl in Hsome. *) +(* exists (e1 :: take tid tp, e). rewrite drop_0. split. *) +(* + erewrite prefixes_from_lookup =>//. *) +(* + rewrite /locale_of /= take_length_le //. *) +(* assert (tid < length tp)%nat; last lia. by eapply lookup_lt_Some. *) +(* Qed. *) + +Definition continued_simulation_init {Λ M} + (ξ : execution_trace Λ → auxiliary_trace M → Prop) + (c : cfg Λ) (s : mstate M) := + continued_simulation ξ {tr[c]} {tr[s]}. + +Definition addrs_to_ip_ports_map (A : gset socket_address) : gmap ip_address (gset port) := + fold_right union ∅ $ + (λ sa, {[ip_of_address sa := {[port_of_address sa]}]}) <$> (elements A). + +Definition ports_in_use (skts : gmap ip_address sockets) : gset socket_address := + map_fold (λ ip skts A, + map_fold + (λ sh skt A, match saddress skt.1 with + | Some a => {[a]} + | None => ∅ + end ∪ A) ∅ skts ∪ A) ∅ skts. + +Definition initial_fuel_map_from `(M: UserModel aneris_lang) `{LMeq: !LiveModelEq LM} `{@anerisPreG M net_model LM LMeq Σ} + (tp0 : list aneris_expr) + (es: list aneris_expr) (fss: list (gset M.(usr_role))) (st : M) : gmap aneris_locale (gmap _ _) := + let esfss := zip (prefixes_from tp0 es) fss in + foldr (λ '((tp, e), fs) fss, <[ locale_of tp e := gset_to_gmap (usr_fl st) fs]> fss) ∅ esfss. + +Definition initial_fuel_map `(M: UserModel aneris_lang) `{LMeq: !LiveModelEq LM} `{@anerisPreG M net_model LM LMeq Σ} := + initial_fuel_map_from M nil. + +Definition wp_proto_multiple_strong + `(M: UserModel aneris_lang) + `{LM: LiveModel aneris_lang (joint_model M net_model)} + `{LMeq: !LiveModelEq LM} `{@anerisPreG M net_model LM LMeq Σ} + (A: gset socket_address) (σ: aneris_lang.state) (s:stuckness) (es : list aneris_expr) (FR: gset (usr_role M)) + (st: M) (fss: list (gset M.(usr_role))):= + (∀ (aG : anerisG LM Σ), ⊢ |={⊤}=> + unallocated A -∗ + ([∗ set] sa ∈ A, sa ⤳ (∅, ∅)) -∗ + ([∗ set] ip ∈ dom (state_heaps σ), + ([∗ map] l ↦ v ∈ (state_heaps σ !!! ip), l ↦[ip] v) ∗ + ([∗ map] sh ↦ s ∈ (state_sockets σ !!! ip), sh ↪[ip] s.1)) -∗ + ([∗ map] ip ↦ ports ∈ (addrs_to_ip_ports_map + (A ∖ (ports_in_use $ state_sockets σ))), + free_ports ip ports)%I -∗ + frag_model_is st -∗ + frag_free_roles_are (FR ∖ usr_live_roles st) -∗ + ([∗ map] ζ ↦ fs ∈ (initial_fuel_map M es fss st), ζ ↦M fs) -∗ + ([∗ set] ip ∈ dom (state_heaps σ), is_node ip) -∗ + aneris_state_interp σ (∅, ∅) ={⊤}=∗ + ((aneris_state_interp σ (∅, ∅)) : iProp Σ) ∗ + wptp s es (fmap (λ '(tnew,e), λ v, fork_post (locale_of tnew e) v) + (prefixes es))). + +(* Definition wp_proto `{anerisPreG retransmit_fair_model Σ} IPs A *) +(* s es ip st := *) +(* (∀ (aG : anerisG retransmit_fair_model Σ), ⊢ |={⊤}=> *) +(* unallocated A -∗ *) +(* ([∗ set] a ∈ A, a ⤳ (∅, ∅)) -∗ *) +(* live_roles_frag_own (retransmit_live_roles st : gset $ fmrole retransmit_fair_model) -∗ *) +(* dead_roles_frag_own ((all_roles ∖ retransmit_live_roles st) : gset $ fmrole retransmit_fair_model) -∗ *) +(* ([∗ set] i ∈ IPs, free_ip i) -∗ *) +(* is_node ip ={⊤}=∗ *) +(* wptp s es (map (λ '(tnew,e), λ v, fork_post (locale_of tnew e) v) *) +(* (prefixes es)) *) +(* (* OBS: Can add [always_holds ξ] here *)). *) + +Definition good_fuel_alloc + `{M: UserModel aneris_lang} `{@anerisPreG M net_model LM LMeq Σ} {HLMEq: LiveModelEq LM} + (es : list aneris_expr) (st : lts_state M) (fss : list $ gset (usr_role M)) := + (length es = length fss) ∧ + (∀ (n1 n2 : nat) fs1 fs2, n1 ≠ n2 → fss !! n1 = Some fs1 → fss !! n2 = Some fs2 → fs1 ## fs2) ∧ + (∀ ρ, ρ ∈ usr_live_roles st → ∃ n fs, fss !! n = Some fs ∧ ρ ∈ fs). + +Lemma initial_fuel_map_inv' + `{M: UserModel aneris_lang} `{@anerisPreG M net_model LM LMeq Σ} {HLMEq: LiveModelEq LM} + (tp0 es : list aneris_expr) + (st : lts_state M) fss ζ (fs : gmap _ _): + initial_fuel_map_from M tp0 es fss st !! ζ = Some fs → + ∃ n e, fss !! n = Some (dom fs) ∧ + es !! n = Some e ∧ + ζ = locale_of (tp0 ++ take n es) e. +Proof. + revert tp0 fs fss. induction es as [|e es IH]; first naive_solver. + intros tp0 fs fss. rewrite /initial_fuel_map /initial_fuel_map_from /=. + destruct fss as [|fs' fss]; first naive_solver. simpl. + destruct (decide (ζ = locale_of tp0 e)) as [->|Hneq]. + { rewrite lookup_insert. intros; simplify_eq. exists 0, e. + rewrite dom_gset_to_gmap /=. list_simplifier. naive_solver. } + rewrite lookup_insert_ne //. + intros Hlk. + destruct (IH _ _ _ Hlk) as (n&fs''&?&?&?). + eexists (1+n), fs''. simpl. list_simplifier. naive_solver. +Qed. + +Lemma initial_fuel_map_inv + `{M: UserModel aneris_lang} `{@anerisPreG M net_model LM LMeq Σ} {HLMEq: LiveModelEq LM} + (es : list aneris_expr) + (st : lts_state M) fss ζ (fs : gmap _ _): + initial_fuel_map M es fss st !! ζ = Some fs → + ∃ n e, fss !! n = Some (dom fs) ∧ + es !! n = Some e ∧ + ζ = locale_of (take n es) e. +Proof. intros ?%initial_fuel_map_inv'. naive_solver. Qed. + + +Program Definition lm_init + `{M: UserModel aneris_lang} `{@anerisPreG M net_model LM LMeq Σ} {HLMEq: LiveModelEq LM} + (es : list aneris_expr) + (st : lts_state M) fss net_init + (Hfss: good_fuel_alloc es st fss) + : mstate LM := +{| + ls_data := {| + ls_under := (st, net_init); + ls_map := initial_fuel_map M es fss st; + |} +|}. +Next Obligation. + simpl. intros M LM LMeq Σ Haneris Hlmeq es st fss ? [Hlen [Hgood _]] ζ1 ζ2 fs1 fs2 Hneq. + intros (n1&?&?&?&?)%initial_fuel_map_inv. + intros (n2&?&?&?&?)%initial_fuel_map_inv. + apply map_disjoint_dom_2. eapply Hgood; try eassumption. + intros Heq. simplify_eq. +Qed. +Next Obligation. + simpl. intros M LM LMeq Σ Haneris Hlmeq es st fss ? [Hlen [_ Hgood]] ρ Hin. + rewrite /initial_fuel_map. destruct (Hgood _ Hin) as (n&fs&HSome&Hinfs). + destruct (es !! n) as [e|] eqn:Heq; last first. + { apply lookup_ge_None_1 in Heq. apply lookup_lt_Some in HSome. lia. } + exists (locale_of (take n es) e). exists (gset_to_gmap (usr_fl st) fs). + split; last by rewrite dom_gset_to_gmap //. + pose ctx := @nil aneris_expr. + + have // : foldr + (λ '(tp, e0, fs0) (fss0 : gmap aneris_locale (gmap (usr_role M) nat)), + <[locale_of tp e0:=gset_to_gmap (usr_fl st) fs0]> fss0) ∅ (zip (prefixes_from ctx es) fss) + !! locale_of (ctx ++ take n es) e = Some (gset_to_gmap (usr_fl st) fs). + + generalize ctx. clear ctx. + clear ρ Hinfs Hin Hgood. + revert n e fss Hlen fs Heq HSome. + + induction es as [|e' es IH]. + { move=> [] //. } + intros n e fss Hlen fs Heq HSome ctx. destruct fss as [|fs' fss] =>//. + simpl. + destruct n as [|n]. + { simpl in *. list_simplifier. rewrite lookup_insert //. } + rewrite /=. + + rewrite lookup_insert_ne; last first. + { eapply (locale_injective _ _ (take n es ++ [e])). + rewrite prefixes_from_app. apply elem_of_app; right. + simpl. list_simplifier. by apply elem_of_list_singleton. } + + replace (ctx ++ e' :: take n es) with ((ctx ++ [e'] ++ take n es)); last by list_simplifier. + + list_simplifier. + ospecialize (IH n e fss Hlen _ Heq HSome (ctx ++ [e'])). + list_simplifier. + rewrite IH //. +Qed. + + +Theorem simulation_adequacy_multiple_strong + `(M: UserModel aneris_lang) `{@anerisPreG M net_model LM LMeq Σ} + A s (es : list aneris_expr) σ st fss FR net_init + (Hfss: good_fuel_alloc es st fss) : + length es >= 1 → + (* aneris_model_rel_finitary Mdl → *) + dom (state_heaps σ) = dom (state_sockets σ) → + config_net_match (es, σ) net_init → + (* TODO1: something to relate the socket state and the model one. *) + (* TODO2: we need to get a proper LiveModel state that is related to the initial fuel map... + but that requires property on fss, i.e. disjointness. *) + (* Port coherence *) + ((∀ ip ps, (GSet <$> (addrs_to_ip_ports_map + (A ∖ (ports_in_use $ state_sockets σ)))) + !! ip = Some (GSet ps) → + ∀ Sn, (state_sockets σ) !! ip = Some Sn → + ∀ p, p ∈ ps → port_not_in_use p Sn)) → + (* Socket buffers are initially empty *) + map_Forall (λ ip s, map_Forall (λ sh sb, sb.2 = []) s) (state_sockets σ) → + map_Forall (λ ip s, socket_handlers_coh s) (state_sockets σ) → + map_Forall (λ ip s, socket_addresses_coh s ip) (state_sockets σ) → + (* Message soup is initially empty *) + state_ms σ = ∅ → + wp_proto_multiple_strong M A σ s es FR st fss → + continued_simulation_init (valid_state_evolution_fairness LM) (es, σ) (lm_init es st fss net_init Hfss). +Proof. + intros Hlen Hdom Hnetinit Hport_coh Hbuf_coh Hsh_coh Hsa_coh Hms Hwp. + apply (wp_strong_adequacy_multiple aneris_lang + (live_model_to_model LM) Σ s); + [done| |]. + { apply rel_finitary_valid_state_evolution_fairness. } + iIntros (?) "". + iMod node_gnames_auth_init as (γmp) "Hmp". + iMod saved_si_init as (γsi) "[Hsi Hsi']". + iMod (unallocated_init (to_singletons A)) as (γsif) + "[Hunallocated_auth Hunallocated]". + iMod (free_ips_init ∅) as (γips) "[HIPsCtx HIPs]". + iMod (free_ports_auth_init_multiple) as (γpiu) "[HPiu HPs]". + iMod (allocated_address_groups_init (to_singletons ∅)) as + (γobserved_send) "#Hobserved_send". + iMod (allocated_address_groups_init (to_singletons ∅)) as + (γobserved_receive) "#Hobserved_receive". + iMod (socket_address_group_ctx_init (to_singletons A)) as (γC) "Hauth"; + [apply to_singletons_all_disjoint|]. + iMod (socket_address_group_own_alloc_subseteq_pre _ (to_singletons A) + (to_singletons A) + with "Hauth") as + "[Hauth HownA]"; [done|]. + iDestruct (socket_address_group_own_big_sepS with "HownA") as "#HownAS". + iMod (messages_ctx_init (to_singletons A) _ _ _ _ with "HownAS Hobserved_send Hobserved_receive" ) as (γms) "[Hms HB]". + iMod (steps_init 1) as (γsteps) "[Hsteps _]". + iMod (alloc_evs_init ∅) as (γalevs) "[Halobctx Halobs]". + iMod (sendreceive_evs_init (to_singletons A)) as + (γsendevs) "[Hsendevsctx Hsendevs]". + iMod (sendreceive_evs_init (to_singletons A)) as + (γreceiveevs) "[Hreceiveevsctx Hreceiveevs]". + iMod (model_state_init st) as (γmod) "[Hmoda Hmodf]". + iMod (model_fuel_mapping_init_gen (initial_fuel_map M es fss st)) as (γmap) "[Hmapa Hmapf]". + iMod (model_free_roles_init st (FR ∖ usr_live_roles st)) as (γfr) "[HFR Hfr]". + set (dg := + {| + aneris_node_gnames_name := γmp; + aneris_si_name := γsi; + aneris_socket_address_group_name := γC; + aneris_unallocated_socket_address_groups_name := γsif; + aneris_freeips_name := γips; + aneris_freeports_name := γpiu; + aneris_messages_name := γms; + aneris_steps_name := γsteps; + aneris_allocEVS_name := γalevs; + aneris_sendonEVS_name := γsendevs; + aneris_receiveonEVS_name := γreceiveevs; + aneris_observed_send_name := γobserved_send; + aneris_observed_recv_name := γobserved_receive; + aneris_fairnessG := {| + fairness_model_name := γmod; + fairness_model_fuel_mapping_name := γmap; + fairness_model_free_roles_name := γfr; + |} + |}). + iMod (Hwp dg) as "Hwp". + iMod (is_node_alloc_multiple σ with "[Hmp]") + as (γs Hheaps_dom' Hsockets_dom') "[Hγs [#Hn [Hσctx Hσ]]]"; [set_solver|done|]. + iExists (@state_interp aneris_lang LM Σ (@anerisG_irisG M net_model LM LMeq Σ dg)). + iExists (fmap (λ '(tnew,e) v, fork_post (locale_of tnew e) v) (prefixes es))%I, + (fork_post)%I. + iSplitR; [iApply config_wp_correct|]. + iMod (socket_address_group_own_alloc_subseteq_pre _ + (to_singletons A) (to_singletons A) with "Hauth") + as "[Hauth Hown]"; [by set_solver|]. + iPoseProof (aneris_state_interp_init_strong ∅ (to_singletons A) + (addrs_to_ip_ports_map (A ∖ ports_in_use (state_sockets σ))) with + "Hγs Hσctx Hms [$Hauth $Hown] + Hunallocated_auth Hsi HIPsCtx HPiu") as "Hinterp"; + [set_solver|set_solver|set_solver|done|done|done|done|done|done|done| |..]. + { iPureIntro. apply to_singletons_is_ne. } + iSpecialize ("Hwp" with "Hunallocated [HB] Hσ HPs Hmodf Hfr [Hmapf] Hn Hinterp"). + { iApply (big_sepS_to_singletons with "[] HB"). + iIntros "!>" (sa). + iDestruct 1 as (As' Ar') "(?&?&[%HAs' %HAr']&$&$)". + simpl. iSplit; [|done]. + iExists _, _. iFrame. + iPureIntro. set_solver. } + { rewrite /has_fuels /frag_fuel_mapping_is. simpl. + rewrite -big_opM_own_1. + rewrite -big_opM_auth_frag. + iApply (fair_resources.own_proper with "Hmapf"). + f_equiv. + (* rewrite leibniz_equiv_iff. *) + transitivity (([^ op map] k↦x ∈ Excl <$> initial_fuel_map M es fss st, + {[k := x]} : gmap.gmapUR _ (exclR (gmap.gmapUR _ natO)))); last first. + { rewrite (big_opM_fmap). f_equiv. intros ??. rewrite map_fmap_singleton //. } + rewrite gmap.big_opM_singletons //. } + iDestruct ("Hwp") as ">[Hσ $]". + simpl. rewrite Hms=> /=. rewrite dom_empty_L. + iFrame. + iModIntro. + iSplitL "Hmapa"; first iSplit. + { iPureIntro. rewrite /fuel.valid_state_evolution_fairness /=. split; [constructor|split=>//]. + intros ζ Hin. rewrite /lm_init /= in Hin. + apply elem_of_dom in Hin as [fs Hfs]. + apply initial_fuel_map_inv in Hfs as (n&e&?&Hlk&->). + exists e. apply from_locale_from_Some. apply prefixes_from_spec. list_simplifier. + apply take_drop_middle in Hlk. naive_solver. } + { rewrite /model_state_interp. iExists _. + rewrite /usr_state. iFrame. + (iSplit; [|iSplit;[|iSplit]]); iPureIntro; simpl=>//. + - intros ρ Hlive. + change (initial_fuel_map M es fss st) with (ls_map (lm_init es st fss net_init Hfss)). + by apply (ls_map_live (lm_init es st fss net_init Hfss)) in Hlive. + - intros ζ Hnotin. destruct (initial_fuel_map M es fss st !! ζ) as [fs|] eqn:Heq=>//; + last rewrite Heq //. exfalso. + apply initial_fuel_map_inv in Heq as (n&e&?&Hlk&->). + apply Hnotin. + apply locales_of_list_from_locale_from. + exists e. apply from_locale_from_Some. apply prefixes_from_spec. list_simplifier. + apply take_drop_middle in Hlk. naive_solver. } + iIntros (ex atr c Hvalex Hstartex Hstartatr Hendex Hcontr Hstuck Htake) + "Hsi Hposts". + iDestruct "Hsi" as "(%Hvalid&_&Hlive&_)". + iApply fupd_mask_intro; [set_solver|]. + iIntros "_". + pose proof Hvalid as Hvalid'. + rewrite /fuel.valid_state_evolution_fairness in Hvalid. + destruct Hvalid as (Hsteps&Hlabs&Htids). + iSplit; [done|]. + iSplit; [done|]. + iSplit. + { iPureIntro. rewrite /tids_smaller in Htids. + intros ρ ζ Hlk. apply ls_mapping_data_inv in Hlk as [?[??]]. apply Htids=>//. + by eapply elem_of_dom_2. } + iIntros (ζ' e' Hsome Hnoval ρ HSome). simpl. + iAssert (ζ' ↦M ∅)%I with "[Hposts]" as "H". + { destruct (to_val e') as [?|] eqn:Heq; last done. + + rewrite (big_sepL_elem_of (λ x, x.2 x.1) _ (v, (λ _, ζ' ↦M ∅)%I) _) //. + have Hceq: c = trace_last ex. + { symmetry. eapply last_eq_trace_ends_in. done. } + apply elem_of_list_omap. + exists (e', (λ _: aneris_val, ζ' ↦M ∅)%I); split; last first. + - simpl. apply fmap_Some. exists v. split; done. + - destruct (trace_last ex).1 as [|e1' tp] eqn:Htpeq; first set_solver. simpl. + destruct (from_locale_from_elem_of' _ _ ζ' e' Hsome) as [i [Htplk Hloc]]. + apply elem_of_lookup_zip_with. eexists i, _, _. do 2 split =>//. + { rewrite -Htplk Hceq Htpeq //. } + rewrite lookup_app. rewrite list_lookup_fmap. + list_simplifier. + + destruct (prefixes es !! i) as [] eqn:Hlk. + + have Hleni: i < length es. + { rewrite -(prefixes_from_length []). by eapply lookup_lt_Some. } + simpl. f_equiv. destruct p as [tnew e]. simpl. + have -> //: locale_of (take i (e1' :: tp)) e' = aneris_lang.locale_of tnew e. + rewrite Htpeq in Htake. + rewrite Forall2_lookup in Htake. specialize (Htake i). + rewrite Hlk in Htake. + + rewrite prefixes_from_take in Htake. + rewrite lookup_take // in Htake. + apply (prefixes_from_lookup []) in Htplk. + rewrite Htplk /= in Htake. + inversion Htake. done. + + simpl. rewrite list_lookup_fmap. + rewrite Htpeq fmap_length prefixes_from_length. + + have Hleni: i >= length es. + { rewrite -(prefixes_from_length []). by eapply lookup_ge_None. } + + + have Hlk': (drop (length es) (e1' :: tp)) !! (i - length es) = Some e'. + { rewrite lookup_drop. rewrite -Htplk. f_equal. lia. } + + apply (prefixes_from_lookup es) in Hlk'. + rewrite Hlk' /=. f_equal. + rewrite -skipn_firstn_comm. + + have Hequiv: locales_equiv (es ++ drop (length es) (take i (e1' :: tp))) (take i (e1' :: tp)). + { rewrite Htpeq in Htake. + eapply (locales_equiv_transitive _ + ((take (length es) (e1' :: tp)) ++ drop (length es) (take i (e1' :: tp))) (take i (e1' :: tp))). + - eapply locales_equiv_from_app. apply Htake. + list_simplifier. apply locales_equiv_from_refl. done. + - have ->: take (length es) (e1' :: tp) = take (length es) (take i $ e1' :: tp). + { rewrite take_take. f_equal. lia. } + rewrite take_drop. apply locales_equiv_refl. } + rewrite (locale_equiv _ _ _ Hequiv) //. } + (* Now conclude using fuel_map_le somehow *) + unfold model_state_interp. + iDestruct "Hlive" as (fm) "(%Hle & %Hdead & ? & ? & Hfm & ?)". + iDestruct (has_fuels_agree with "Hfm H") as %Hfm. + rewrite /fuel_map_preserve_dead in Hdead. + iPureIntro. intros Ha. destruct (Hdead _ Ha) as (ζ'' & fs' & Hfm' & Hin). + + have Hccl: ζ'' = ζ'; last first. + { rewrite -Hccl in Hfm. set_solver. } + + apply ls_mapping_data_inv in HSome as [fs1 [Hfs1 Hinfs1]]. + + + rewrite /fuel_map_le /fuel_map_le_inner in Hle. + rewrite map_included_utils.map_included_spec in Hle. destruct Hle as [Hle Hdoms]. + destruct (Hle _ _ Hfm') as [fs2 [Hfs2 Hincl2]]. + + opose proof (ls_map_agree Hfs1 Hfs2 Hinfs1 _). + { apply map_included_utils.map_included_subseteq_inv in Hincl2. set_solver. } + naive_solver. +Qed. + +Definition aneris_trace := extrace aneris_lang. +Definition auxtrace (M : Model) := trace (M.(mstate)) (M.(mlabel)). + +Lemma valid_inf_system_trace_implies_traces_match_strong {Λ} {Mdl:Model} + (φ : execution_trace Λ → auxiliary_trace Mdl → Prop) + (Rs : _ → _ → Prop) (Rℓ : _ → _ → Prop) + ex atr iex iatr progtr auxtr : + (∀ extr auxtr, φ extr auxtr → Rs (trace_last extr) (trace_last auxtr)) → + (∀ extr auxtr, φ extr auxtr → + ∀ ζ ℓ, trace_last_label extr = Some ζ → + trace_last_label auxtr = Some ℓ → + Rℓ ζ ℓ) → + (∀ extr auxtr, φ extr auxtr → + match extr, auxtr with + | _ :tr[_]: _, auxtr :tr[ℓ]: ρ => + Mdl.(mtrans) (trace_last auxtr) ℓ ρ + | _,_ => True + end) → + exec_trace_match ex iex progtr → + exec_trace_match atr iatr auxtr → + valid_inf_system_trace φ ex atr iex iatr → + traces_match Rℓ Rs locale_step mtrans progtr auxtr. +Proof. + intros Hφ1 Hφ2 Hφ3. + revert ex atr iex iatr auxtr progtr. cofix IH. + intros ex atr iex iatr auxtr progtr Hem Ham Hval. + inversion Hval as [?? Hphi |ex' atr' c [? σ'] δ' iex' iatr' oζ ℓ Hphi [=] ? Hinf]; simplify_eq. + - inversion Hem; inversion Ham. econstructor; eauto. + pose proof (Hφ1 ex atr Hphi). simplify_eq. by eapply Hφ1. + - inversion Hem; inversion Ham. subst. + pose proof (valid_inf_system_trace_inv _ _ _ _ _ Hinf) as Hphi'. + econstructor. + + eauto. + + eauto. + + match goal with + | [H: exec_trace_match _ iex' _ |- _] => inversion H; clear H; simplify_eq + end; done. + + match goal with + | [H: exec_trace_match _ iatr' _ |- _] => inversion H; clear H; simplify_eq + end; by eapply (Hφ3 (ex :tr[ oζ ]: (l, σ')) (atr :tr[ ℓ ]: δ')). + + eapply IH; eauto. +Qed. + + +Lemma continued_simulation_infinite_model_trace + `(M: UserModel aneris_lang) `{@anerisPreG M net_model LM LMeq Σ} + es σ m0 iex: + continued_simulation_init (valid_state_evolution_fairness LM) (es, σ) m0 → + valid_inf_exec {tr[ (es, σ) ]} iex → + exists iatr, + @valid_inf_system_trace _ LM + (continued_simulation + (valid_state_evolution_fairness LM)) + (trace_singleton (es, σ)) + (trace_singleton m0) + iex + iatr. +Proof. intros Hcs. eexists. (unshelve apply produced_inf_aux_trace_valid_inf)=>//. constructor. Qed. + +Lemma simulation_adequacy_traces Σ + `(M: UserModel aneris_lang) `{@anerisPreG M net_model LM LMeq Σ} + es σ m0 + (extr : aneris_trace) + (Hvex : extrace_valid extr) + (Hexfirst : (trfirst extr) = (es, σ)) + : + continued_simulation_init (valid_state_evolution_fairness LM) (es, σ) m0 → + ∃ (auxtr : auxtrace LM), exaux_traces_match (LM := LM) extr auxtr. +Proof. + intros Hcci. + opose proof (from_trace_preserves_validity _ (trace_singleton (es, σ)) Hvex _ _) as Hval. + { constructor. } + { rewrite Hexfirst //. } + eapply continued_simulation_infinite_model_trace in Hcci=>//. + destruct Hcci as [atr Hatr]. + exists (to_trace m0 atr). + eapply (valid_inf_system_trace_implies_traces_match_strong (valid_state_evolution_fairness LM) + _ _ _ (trace_singleton m0) (from_trace extr) atr + ). + - intros ex atr' Hvse. unfold valid_state_evolution_fairness in Hvse. naive_solver. + - intros ex auxtr (?&Hlm&?) ζ ℓ Hlab Hlab'. + rewrite /trace_labels_match in Hlm. + destruct ex as [|?? [??]]=>//. destruct auxtr=>//. naive_solver. + - intros ex autr (Hsteps&?&?). destruct ex=>//. destruct autr=>//. + inversion Hsteps; simplify_eq. simpl. unfold trace_ends_in in *. naive_solver. + - apply (from_trace_spec (trace_singleton (es, σ))). rewrite Hexfirst //. + - change m0 with (trace_last (L := mlabel LM) (trace_singleton m0)). apply to_trace_spec. + - eapply valid_inf_system_trace_mono; last eassumption. by intros ??[??]%continued_simulation_unfold. +Qed. + +Definition ex_fair_scheduling (tr: aneris_trace) := ∀ ζ, fair_scheduling_ex ζ tr. + +Definition ex_fair (tr: aneris_trace) := + ex_fair_network tr ∧ ex_fair_scheduling tr. + +Section lm_network. + Context {M: UserModel aneris_lang}. + Context `{@anerisPreG M net_model LM LMeq Σ}. + + Definition lm_send_filter msg : mlabel LM → Prop := + λ l, ∃ ρ ζ, l = Take_step ρ (Some $ Send msg : fmaction (joint_model M net_model)) ζ (Some $ Send msg). + Instance lm_send_filter_decision msg l : Decision (lm_send_filter msg l). + Proof. apply make_decision. Qed. + + Definition lm_deliver_filter msg : mlabel LM → Prop := + λ l, l = Config_step (Deliver msg : fmconfig (joint_model M net_model)) (Deliver msg). + Instance lm_deliver_filter_decision msg l : Decision (lm_deliver_filter msg l). + Proof. apply make_decision. Qed. + + Definition lm_network_fair_delivery_of msg : auxtrace LM → Prop := + □ (□◊ ℓ↓lm_send_filter msg → ◊ ℓ↓ lm_deliver_filter msg). + + Definition lm_network_fair_delivery (mtr : auxtrace LM) : Prop := + ∀ msg, lm_network_fair_delivery_of msg mtr. + + Definition lm_fair_scheduling (tr: auxtrace LM) := + ∀ ρ, fair_aux (LM := LM) ρ tr. + + Definition lm_fair (tr: auxtrace LM) := + fuel_network_fair_delivery tr ∧ lm_fair_scheduling tr. + + Notation ff := + (ltl_tme labels_match live_tids locale_step (lm_ls_trans LM)). + + Lemma simulation_adequacy_traces_fairness + es σ m0 + (extr : aneris_trace) + (Hvex : extrace_valid extr) + (Hexfirst : (trfirst extr) = (es, σ)) + : + continued_simulation_init (valid_state_evolution_fairness LM) (es, σ) m0 → + ex_fair extr → + ∃ (auxtr : auxtrace LM), lm_fair auxtr ∧ exaux_traces_match (LM := LM) extr auxtr. + Proof. + intros Hcs [Hfn Hfs]. + destruct (simulation_adequacy_traces _ _ _ _ _ extr Hvex Hexfirst Hcs) as [atr Hatr]. + eexists _; split=>//. split. + - rewrite /lm_network_fair_delivery /ex_fair_network in Hfn *. + rewrite /lm_network_fair_delivery_of /ex_fair_network_of in Hfn *. + intros msg. specialize (Hfn msg). + + unshelve eapply (ltl_tme_use _ _ _ _ _ Hatr Hfn). + apply ltl_tme_always, ltl_tme_impl. + + apply ltl_tme_always, ltl_tme_eventually, ltl_tme_now. + rewrite /labels_match. + rewrite /ex_send_filter /fuel_send_filter /=. + intros [[]|] [] Hlm=>//. + * destruct Hlm as (?&?&Ham). simplify_eq. rewrite actions_match_is_eq in Ham. naive_solver. + * destruct Hlm as (?&?&Ham). simplify_eq. simpl. split; naive_solver. + * destruct Hlm as (?&Ham). simplify_eq. simpl. split; naive_solver. + + apply ltl_tme_eventually, ltl_tme_now. + rewrite /labels_match. + rewrite /ex_deliver_filter /fuel_deliver_filter /=. + intros [[]|] [] Hlm=>//; [naive_solver| naive_solver |]. + destruct Hlm as (?&Ham). simplify_eq. simpl. rewrite cfg_labels_match_is_eq in Ham; naive_solver. + - rewrite /lm_fair_scheduling /ex_fair_scheduling in Hfn *. eapply fairness_preserved=>//. + Qed. + + Notation jmtrace := (trace (joint_model M net_model) (fmlabel (joint_model M net_model))). + Definition jm_fair (tr: jmtrace) := + jm_network_fair_delivery tr ∧ jm_fair_scheduling tr. + + Definition usr_fair (tr: lts_trace M) := + usr_network_fair_send_receive tr ∧ usr_fair_scheduling tr. + + Lemma simulation_adequacy_trace_remove_fuel + (auxtr : auxtrace LM) : + lm_fair auxtr → + auxtrace_valid (LM := LM) auxtr → + ∃ jmtr, jm_fair jmtr ∧ jmtrace_valid jmtr ∧ upto_stutter_aux auxtr jmtr. + Proof. + intros [Hnf Hsf] Hval. have Hval' := Hval. + apply can_destutter_auxtr in Hval as [jmtr Hupto]. + exists jmtr; split; [|split]=>//. + - split. + + eapply fuel_network_fairness_destutter=>//. + + apply (upto_stutter_fairness_ltl _ _) in Hupto=>//. + - eapply (upto_stutter_preserves_validity (Λ := aneris_lang)) =>//. + Qed. + + Lemma simulation_adequacy_trace_trimed + (jmtr : jmtrace) : + jm_fair jmtr → + jmtrace_valid jmtr → + ∃ ttr, jm_fair ttr ∧ jmtrace_valid ttr ∧ trimmed_of jmtr ttr. + Proof. + intros [Ha Hb] Hval. exists (trim_trace jmtr). split; [|split]; last first. + { apply trim_trace_trimmed_of. } + - rewrite /jmtrace_valid in Hval *. by apply trim_trace_valid. + - split. + + eapply trim_preserves_network_fairness =>//. + + eapply trimming_preserves_fair_scheduling=>//. + Qed. + + Lemma simulation_adequacy_trace_trimmed_user + (ttr : jmtrace) : + jm_fair ttr → + jmtrace_valid ttr → + trace_is_trimmed ttr → + ∃ utr, usr_fair utr ∧ usr_trace_valid utr ∧ upto_stutter_env ttr utr. + Proof. + intros [Hnf Hsf] Hval Htrim. + have [utr ?] : ∃ utr, upto_stutter_env ttr utr. + { eapply can_destutter. apply env_steps_dec_unless=>//. } + exists utr. split; [split|split] =>//. + - eapply network_fairness_project_usr=>//. + - eapply usr_project_scheduler_fair=>//. + - eapply usr_project_valid=>//. + Qed. + + Definition model_refinement : rel (auxtrace LM) (lts_trace M) := + upto_stutter_aux + >> trimmed_of + >> upto_stutter_env. + + Definition program_model_refinement : rel (extrace aneris_lang) (lts_trace M) := + exaux_traces_match (LM := LM) >> model_refinement. + + Lemma model_refinement_preserves_upward auxtr : + lm_fair auxtr → + auxtrace_valid (LM := LM) auxtr → + ∃ utr, model_refinement auxtr utr ∧ usr_fair utr ∧ usr_trace_valid utr. + Proof. + intros Hf Hval. + apply simulation_adequacy_trace_remove_fuel in Hval as (?&?&Hval&?) =>//. + apply simulation_adequacy_trace_trimed in Hval as (?&?&Hval&?) =>//. + apply simulation_adequacy_trace_trimmed_user in Hval as (utr&?&Hval&?) =>//; + last by eapply trimmed_of_is_trimmed. + rewrite /model_refinement /rel_compose. naive_solver. + Qed. + + Proposition program_model_refinement_preserves_upward extr m0 es σ : + continued_simulation_init (valid_state_evolution_fairness LM) (es, σ) m0 → + extrace_valid extr → + ex_fair extr → + (trfirst extr) = (es, σ) → + ∃ utr, program_model_refinement extr utr ∧ usr_fair utr ∧ usr_trace_valid utr. + Proof. + intros Hf Hval ??. + eapply simulation_adequacy_traces_fairness in Hval as (?&?&Hmatch) =>//. + have Hmatch' := Hmatch. + apply exaux_preserves_validity in Hmatch. + apply model_refinement_preserves_upward in Hmatch as (utr&?&?&?) =>//. + rewrite /program_model_refinement /rel_compose. naive_solver. + Qed. + + Proposition program_model_refinement_downward_eventually extr utr (P : action aneris_lang → Prop) : + program_model_refinement extr utr → + (◊ ℓ↓ (λ '(_, α), ∃ α', α = Some α' ∧ P α')) utr → + (◊ ℓ↓ (λ ℓ, ∃ ℓ' ζ, ℓ = inl (ζ, Some ℓ') ∧ P ℓ')) extr. + Proof. + rewrite /program_model_refinement /model_refinement /rel_compose. + intros (auxtr&?&jmtr&?&ttr&?&?) Hev. + + have Heq: ltl_se_env (M := M) (N := net_model) + (◊ ℓ↓ (λ ℓ, ∃ ℓ' ζ, ℓ = inl (ζ, Some ℓ') ∧ P ℓ')) ((◊ ℓ↓ λ '(_, α), ∃ α', α = Some α' ∧ P α')) . + { apply ltl_se_eventually_now. intros [[??]|?]; naive_solver. } + rewrite -(Heq ttr) // in Hev. move=> {Heq}. + + have {}Hev : (◊ ℓ↓ (λ ℓ, ∃ ℓ' ζ, ℓ = inl (ζ, Some ℓ') ∧ P ℓ')) jmtr. + { by eapply trimmed_of_eventually_back. } + + have Heq: fuel_se + (◊ ℓ↓ (λ (ℓ : mlabel LM), ∃ ρ α1 (α α': fmaction (joint_model M net_model)) ζ, + α = Some α1 ∧ ℓ = Take_step ρ α ζ α' ∧ P α1)) + (◊ ℓ↓ (λ ℓ, ∃ ℓ' ζ, ℓ = inl (ζ, Some ℓ') ∧ P ℓ')). + { apply ltl_se_eventually_now. intros [? α ??|?|?]; [|naive_solver|naive_solver]. split. + - intros (?&?&?&?&?). simplify_eq. naive_solver. + - intros (?&?&?&?&?&?). simpl in *. simplify_eq. naive_solver. } + rewrite -(Heq auxtr) // in Hev. move=> {Heq}. + + have Heq: exaux_tme (LM := LM) + (◊ ℓ↓ (λ ℓ, ∃ ℓ' ζ, ℓ = inl (ζ, Some ℓ') ∧ P ℓ')) + (◊ ℓ↓ (λ (ℓ : mlabel LM), ∃ ρ α1 (α α': fmaction (joint_model M net_model)) ζ, + α = Some α1 ∧ ℓ = Take_step ρ α ζ α' ∧ P α1)). + { apply ltl_tme_eventually, ltl_tme_now. rewrite /labels_match. + intros [[ζ oα]|?]; last naive_solver. intros [?|?|?]; last naive_solver. + - intros (?&?&?%actions_match_is_eq). naive_solver. + - intros (?&?&?). simplify_eq. naive_solver. } + rewrite -(Heq extr) // in Hev. + Qed. +End lm_network. + +(* OBS: This is not needed. *) +Lemma valid_inf_system_trace_implies_traces_match + ex atr iex iatr progtr auxtr : + exec_trace_match ex iex progtr → + exec_trace_match atr iatr auxtr → + valid_inf_system_trace + (continued_simulation valid_state_evolution_fairness) ex atr iex iatr → + live_traces_match progtr auxtr. +Proof. + intros. + eapply (valid_inf_system_trace_implies_traces_match_strong + (continued_simulation valid_state_evolution_fairness)); [| | |done..]. + - by intros ?? (?&?&?&?)%continued_simulation_rel. + - intros [][] (?&?&?)%continued_simulation_rel; try done. + intros. simpl in *. by simplify_eq. + - intros [][] (Hvalid&?&?)%continued_simulation_rel; try done. + simpl in *. inversion Hvalid. simplify_eq. by rewrite H7. +Qed. + +Definition extrace_matching_mtrace_exists + {Λ} {M} (Rs : cfg Λ → M.(mstate) → Prop) Rℓ st extr := + ∃ mtr, trfirst mtr = st ∧ + traces_match Rℓ Rs language.locale_step (M.(mtrans)) extr mtr. + +Lemma continued_simulation_traces_match {Λ} {M} + (ξ : _ → _ → Prop) (Rs : cfg Λ → M.(mstate) → Prop) (Rℓ : _ → _ → Prop) + extr st : + (∀ extr auxtr, continued_simulation ξ extr auxtr → + Rs (trace_last extr) (trace_last auxtr)) → + (∀ extr auxtr, continued_simulation ξ extr auxtr → + ∀ ζ ℓ, trace_last_label extr = Some ζ → + trace_last_label auxtr = Some ℓ → + Rℓ ζ ℓ) → + (∀ extr auxtr, continued_simulation ξ extr auxtr → + match extr, auxtr with + | _ :tr[_]: _, auxtr :tr[ℓ]: ρ => + mtrans (trace_last auxtr) ℓ ρ + | _,_ => True + end) → + extrace_valid extr → + continued_simulation_init ξ (trfirst extr) st → + extrace_matching_mtrace_exists Rs Rℓ st extr. +Proof. + intros HRs HRℓ Htrans Hvalid Hsim. + assert (∃ iatr, + valid_inf_system_trace + (continued_simulation ξ) + (trace_singleton (trfirst extr)) + (trace_singleton (st)) + (from_trace extr) + iatr) as [iatr Hiatr]. + { eexists _. eapply produced_inf_aux_trace_valid_inf. econstructor. + Unshelve. + - done. + - eapply from_trace_preserves_validity; eauto; first econstructor. } + eexists _. + split; last first. + { eapply (valid_inf_system_trace_implies_traces_match_strong); eauto. + - by apply from_trace_spec. + - by apply to_trace_spec. } + destruct iatr; [done|by destruct x]. +Qed. + +Definition extrace_matching_mtrace_exists_live st extr := + extrace_matching_mtrace_exists (live_tids : cfg aneris_lang → mstate (fair_model_to_model retransmit_fair_model) → Prop) labels_match st extr. + +Lemma continued_simulation_traces_match_live extr st : + extrace_valid extr → + continued_simulation_init valid_state_evolution_fairness + (trfirst extr) st → + extrace_matching_mtrace_exists_live st extr. +Proof. + intros. eapply continued_simulation_traces_match; eauto. + - by intros ?? (?&?&?&?)%continued_simulation_rel. + - intros [][] (?&?&?)%continued_simulation_rel; try done. + intros. simpl in *. by simplify_eq. + - intros [][] (Hvalid&?&?)%continued_simulation_rel; try done. + simpl in *. inversion Hvalid. simplify_eq. by rewrite H6. +Qed. + +Definition matching_mtrace_exists c st := + extrace_property c (extrace_matching_mtrace_exists_live st). + +(** A continued simulation exists between some initial configuration [c] + and the initial state [init_state] of a fair model. *) +Definition live_simulation (c : cfg aneris_lang) (st : retransmit_state) := + continued_simulation_init valid_state_evolution_fairness c st. + +Lemma continued_simulation_traces_match_init c st : + live_simulation c st → matching_mtrace_exists c st. +Proof. + intros Hsim extr <- Hvalid. + apply (continued_simulation_traces_match_live) in Hsim + as (mtr & Hmtr & Hmatch); [by eexists _|done]. +Qed. + +Definition extrace_fairly_terminating_locale ζ (extr : extrace aneris_lang) := + extrace_fair extr -> extrace_terminating_locale ζ extr. + +Definition fairly_terminating ζ (c : cfg aneris_lang) := + extrace_property c (extrace_fairly_terminating_locale ζ). + +Lemma traces_match_fair_termination_preserved_init c st : + matching_mtrace_exists c st → fairly_terminating localeB c. +Proof. + intros Hmatches. + eapply extrace_property_impl; [done|]. + intros extr Hstart Hvalid (mtr & Hstart' & Hmtr) Hfair. + eapply terminating_role_preserved; + [done|done|done|]. + apply retransmit_fair_traces_terminate. + - by eapply traces_match_valid_preserved. + - by eapply traces_match_fairness_preserved. +Qed. + +Theorem continued_simulation_fair_termination c st : + live_simulation c st → fairly_terminating localeB c. +Proof. + intros ?. + by eapply traces_match_fair_termination_preserved_init, + continued_simulation_traces_match_init. +Qed. + +Theorem simulation_adequacy_fair_termination_multiple + `{anerisPreG retransmit_fair_model Σ} + A s (es : list aneris_expr) σ st : + role_enabled_locale_exists (es, σ) st → + config_state_valid (es, σ) st → + length es >= 1 → + (* aneris_model_rel_finitary Mdl → *) + dom (state_heaps σ) = dom (state_sockets σ) → + (* Port coherence *) + ((∀ ip ps, (GSet <$> (addrs_to_ip_ports_map + (A ∖ (ports_in_use $ state_sockets σ)))) + !! ip = Some (GSet ps) → + ∀ Sn, (state_sockets σ) !! ip = Some Sn → + ∀ p, p ∈ ps → port_not_in_use p Sn)) → + (* Socket buffers are initially empty *) + map_Forall (λ ip s, map_Forall (λ sh sb, sb.2 = []) s) (state_sockets σ) → + map_Forall (λ ip s, socket_handlers_coh s) (state_sockets σ) → + map_Forall (λ ip s, socket_addresses_coh s ip) (state_sockets σ) → + (* Message soup is initially empty *) + state_ms σ = ∅ → + wp_proto_multiple_strong A σ s es st (* φs *) → + fairly_terminating localeB (es,σ). +Proof. + intros. eapply continued_simulation_fair_termination, + simulation_adequacy_multiple_strong; try done. +Qed. diff --git a/fairneris/aneris_lang/aneris_lang.v b/fairneris/aneris_lang/aneris_lang.v new file mode 100644 index 0000000..9831559 --- /dev/null +++ b/fairneris/aneris_lang/aneris_lang.v @@ -0,0 +1,5 @@ +From fairneris.aneris_lang Require Export lang. + +Canonical Structure aneris_ectxi_lang := EctxiLanguage head_step config_step locale_of (* config_enabled *) aneris_lang_mixin. +Canonical Structure aneris_ectx_lang := EctxLanguageOfEctxi aneris_ectxi_lang. +Canonical Structure aneris_lang := LanguageOfEctx aneris_ectx_lang. diff --git a/fairneris/aneris_lang/ast.v b/fairneris/aneris_lang/ast.v new file mode 100644 index 0000000..cc6b84b --- /dev/null +++ b/fairneris/aneris_lang/ast.v @@ -0,0 +1,363 @@ +From stdpp Require Export binders. + + +(** Basic Network *) +Definition ip_address := string. + +Definition port := positive. + +Inductive socket_address := +| SocketAddressInet (address : ip_address) (port : positive). + +Definition ip_of_address (sa : socket_address) : ip_address := + match sa with + | SocketAddressInet ip _ => ip + end. +Definition port_of_address (sa : socket_address) : positive := + match sa with + | SocketAddressInet _ p => p + end. + +Record socket := mkSocket { + saddress : option socket_address; + sblock : bool; +}. + +(** Grammar of AnerisLang *) +Delimit Scope expr_scope with E. +Delimit Scope val_scope with V. + +Open Scope Z_scope. + +Definition socket_handle := positive. + +(** Expressions and vals. *) +Definition loc := positive. (* Really, any countable type. *) + +Inductive base_lit : Set := +| LitInt (n : Z) | LitBool (b : bool) | LitUnit | LitLoc (l : loc) +| LitString (s : string) +| LitSocket (s : socket_handle) | LitSocketAddress (s : socket_address). +Inductive un_op : Set := +| NegOp | MinusUnOp | StringOfInt | IntOfString | StringLength. +Inductive bin_op : Set := +| PlusOp | MinusOp | MultOp | QuotOp | RemOp (* Arithmetic *) +| AndOp | OrOp | XorOp (* Bitwise *) +| ShiftLOp | ShiftROp (* Shifts *) +| LeOp | LtOp | EqOp (* Relations *) +| StringApp. + +Inductive expr := +(* Values *) +| Val (v : val) +(* Base lambda calculus *) +| Var (x : string) +| Rec (f x : binder) (e : expr) +| App (e1 e2 : expr) +(* Base types and their operations *) +| UnOp (op : un_op) (e : expr) +| BinOp (op : bin_op) (e1 e2 : expr) +| If (e0 e1 e2 : expr) +| FindFrom (e0 e1 e2 : expr) +| Substring (e0 e1 e2 : expr) +| Rand (e : expr) +(* Products *) +| Pair (e1 e2 : expr) +| Fst (e : expr) +| Snd (e : expr) +(* Sums *) +| InjL (e : expr) +| InjR (e : expr) +| Case (e0 : expr) (e1 : expr) (e2 : expr) +(* Node-local concurrency *) +| Fork (e : expr) +(* Heap *) +| Alloc (lbl : option string) (e : expr) +| Load (e : expr) +| Store (e1 : expr) (e2 : expr) +| CAS (e0 : expr) (e1 : expr) (e2 : expr) +(* Sockets/Network *) +| MakeAddress (e1 : expr) (e2 : expr) +| GetAddressInfo (e : expr) +| NewSocket (e : expr) +| SocketBind (e1 : expr) (e2 : expr) +| SendTo (e1 : expr) (e2 : expr) (e3 : expr) +| SendToRepeat (e1 : expr) (e2 : expr) (e3 : expr) +| ReceiveFrom (e1 : expr) +| SetReceiveTimeout (e1 : expr) (e2 e3 : expr) +| Start (ip : base_lit) (e : expr) + +with val := +| LitV (l : base_lit) +| RecV (f x : binder) (e : expr) +| PairV (v1 v2 : val) +| InjLV (v : val) +| InjRV (v : val). + +Bind Scope expr_scope with expr. +Bind Scope val_scope with val. + +Notation of_val := Val (only parsing). + +Delimit Scope expr_scope with E. +Delimit Scope val_scope with V. + +(** Notations for some derived forms *) +Notation Lam x e := (Rec BAnon x e) (only parsing). +Notation Let x e1 e2 := (App (Lam x e2) e1) (only parsing). +Notation Seq e1 e2 := (Let BAnon e1 e2) (only parsing). +Notation LamV x e := (RecV BAnon x e) (only parsing). + +Notation Skip := (App (Val $ LamV BAnon (Val $ LitV LitUnit)) (Val $ LitV LitUnit)) (only parsing). +Notation Match e0 x1 e1 x2 e2 := (Case e0 (Lam x1 e1) (Lam x2 e2)) (only parsing). +Notation i2s e := (UnOp StringOfInt e)%E (only parsing). +Notation s2i e := (UnOp IntOfString e)%E (only parsing). +Notation strlen e := (UnOp StringLength e)%E (only parsing). + +Notation "½" := (1/2)%Qp. +Notation "¼" := (1/4)%Qp. +Notation "¾" := (3/4)%Qp. + +Coercion LitInt : Z >-> base_lit. +Coercion LitBool : bool >-> base_lit. +Coercion LitLoc : loc >-> base_lit. +Coercion LitSocketAddress : socket_address >-> base_lit. +Coercion LitString : string >-> base_lit. + +Coercion App : expr >-> Funclass. +Coercion of_val : val >-> expr. + +Coercion Var : string >-> expr. + +(* Note that the scope for expressions and values are NOT the same: + Expressions have brackets that comes from the sequence \<, with name + MATHEMATICAL LEFT ANGLE BRACKET where as values has brackets + that come from \〈 (name: LEFT-POINTING ANGLE BRACKET) *) +(* Notation "⟨ n ; e ⟩" := (mkExpr n e) (at level 0, right associativity). *) +(* Notation "〈 n ; v 〉" := (mkVal n v%V). *) + +(* No scope for the values, does not conflict and scope is often not inferred +properly. *) +Notation "# l" := (LitV l%Z%V%stdpp) (at level 8, format "# l"). + +(** Syntax inspired by Coq/Ocaml. Constructions with higher precedence come + first. *) +Notation "( e1 , e2 , .. , en )" := (Pair .. (Pair e1 e2) .. en) : expr_scope. +Notation "( e1 , e2 , .. , en )" := (PairV .. (PairV e1 e2) .. en) : val_scope. + +(* +Using the '[hv' ']' printing box, we make sure that when the notation for match +does not fit on a single line, line breaks will be inserted for *each* breaking +point '/'. Note that after each breaking point /, one can put n spaces (for +example '/ '). That way, when the breaking point is turned into a line break, +indentation of n spaces will appear after the line break. As such, when the +match does not fit on one line, it will print it like: + + match: e0 with + InjL x1 => e1 + | InjR x2 => e2 + end + +Moreover, if the branches do not fit on a single line, it will be printed as: + + match: e0 with + InjL x1 => + + | InjR x2 => + even more stuff bla bla bla bla bla bla bla bla + end + *) +Notation "'match:' e0 'with' 'InjL' x1 => e1 | 'InjR' x2 => e2 'end'" := + (Match e0 x1%binder e1 x2%binder e2) + (e0, x1, e1, x2, e2 at level 200, + format "'[hv' 'match:' e0 'with' '/ ' '[' 'InjL' x1 => '/ ' e1 ']' '/' '[' | 'InjR' x2 => '/ ' e2 ']' '/' 'end' ']'") : expr_scope. +Notation "'match:' e0 'with' 'InjR' x1 => e1 | 'InjL' x2 => e2 'end'" := + (Match e0 x2%binder e2 x1%binder e1) + (e0, x1, e1, x2, e2 at level 200, only parsing) : expr_scope. + +Notation "()" := LitUnit : val_scope. +Notation "! e" := (Load e%E) (at level 9, right associativity) : expr_scope. +Notation "'ref<<' lbl '>>' e" := (Alloc (Some lbl%string) e%E) (at level 10) : expr_scope. +Notation "'ref' e" := (Alloc None e%E) (at level 10) : expr_scope. +Notation "- e" := (UnOp MinusUnOp e%E) : expr_scope. +Notation "e1 + e2" := (BinOp PlusOp e1%E e2%E) : expr_scope. +Notation "e1 - e2" := (BinOp MinusOp e1%E e2%E) : expr_scope. +Notation "e1 * e2" := (BinOp MultOp e1%E e2%E) : expr_scope. +Notation "e1 `quot` e2" := (BinOp QuotOp e1%E e2%E) : expr_scope. +Notation "e1 `rem` e2" := (BinOp RemOp e1%E e2%E) : expr_scope. +Notation "e1 ≤ e2" := (BinOp LeOp e1%E e2%E) : expr_scope. +Notation "e1 < e2" := (BinOp LtOp e1%E e2%E) : expr_scope. +Notation "e1 = e2" := (BinOp EqOp e1%E e2%E) : expr_scope. +Notation "e1 ^^ e2" := (BinOp StringApp e1%E e2%E) (at level 70) : expr_scope. +Notation "e1 ≠ e2" := (UnOp NegOp (BinOp EqOp e1%E e2%E)) : expr_scope. +Notation "~ e" := (UnOp NegOp e%E) (at level 75, right associativity) : expr_scope. +(* The unicode ← is already part of the notation "_ ← _; _" for bind. *) +Notation "e1 <- e2" := (Store e1%E e2%E) (at level 80) : expr_scope. + +(* The breaking point '/ ' makes sure that the body of the rec is indented +by two spaces in case the whole rec does not fit on a single line. *) +Notation "'rec:' f x := e" := (Rec f%binder x%binder e%E) + (at level 200, f at level 1, x at level 1, e at level 200, + format "'[' 'rec:' f x := '/ ' e ']'") : expr_scope. +Notation "'rec:' f x := e" := (RecV f%binder x%binder e%E) + (at level 200, f at level 1, x at level 1, e at level 200, + format "'[' 'rec:' f x := '/ ' e ']'") : val_scope. +Notation "'if:' e1 'then' e2 'else' e3" := (If e1%E e2%E e3%E) + (at level 200, e1, e2, e3 at level 200) : expr_scope. + +(** Derived notions, in order of declaration. The notations for let and seq +are stated explicitly instead of relying on the Notations Let and Seq as +defined above. This is needed because App is now a coercion, and these +notations are otherwise not pretty printed back accordingly. *) +Notation "'rec:' f x y .. z := e" := (Rec f%binder x%binder (Lam y%binder .. (Lam z%binder e%E) ..)) + (at level 200, f, x, y, z at level 1, e at level 200, + format "'[' 'rec:' f x y .. z := '/ ' e ']'") : expr_scope. +Notation "'rec:' f x y .. z := e" := (RecV f%binder x%binder (Lam y%binder .. (Lam z%binder e%E) ..)) + (at level 200, f, x, y, z at level 1, e at level 200, + format "'[' 'rec:' f x y .. z := '/ ' e ']'") : val_scope. + +(* The breaking point '/ ' makes sure that the body of the λ: is indented +by two spaces in case the whole λ: does not fit on a single line. *) +Notation "λ: x , e" := (Lam x%binder e%E) + (at level 200, x at level 1, e at level 200, + format "'[' 'λ:' x , '/ ' e ']'") : expr_scope. +Notation "λ: x y .. z , e" := (Lam x%binder (Lam y%binder .. (Lam z%binder e%E) ..)) + (at level 200, x, y, z at level 1, e at level 200, + format "'[' 'λ:' x y .. z , '/ ' e ']'") : expr_scope. + +Notation "λ: x , e" := (LamV x%binder e%E) + (at level 200, x at level 1, e at level 200, + format "'[' 'λ:' x , '/ ' e ']'") : val_scope. +Notation "λ: x y .. z , e" := (LamV x%binder (Lam y%binder .. (Lam z%binder e%E) .. )) + (at level 200, x, y, z at level 1, e at level 200, + format "'[' 'λ:' x y .. z , '/ ' e ']'") : val_scope. + +Notation "'let:' x := e1 'in' e2" := (Lam x%binder e2%E e1%E) + (at level 200, x at level 1, e1, e2 at level 200, + format "'[' 'let:' x := '[' e1 ']' 'in' '/' e2 ']'") : expr_scope. +Notation "e1 ;; e2" := (Lam BAnon e2%E e1%E) + (at level 100, e2 at level 200, + format "'[' '[hv' '[' e1 ']' ;; ']' '/' e2 ']'") : expr_scope. + +(* Shortcircuit Boolean connectives *) +Notation "e1 && e2" := + (If e1%E e2%E (LitV (LitBool false))) (only parsing) : expr_scope. +Notation "e1 || e2" := + (If e1%E (LitV (LitBool true)) e2%E) (only parsing) : expr_scope. + +(** Notations for option *) +Notation NONE := (InjL #()) (only parsing). +Notation SOME x := (InjR x) (only parsing). +Notation NONEV := (InjLV #()) (only parsing). +Notation SOMEV x := (InjRV x) (only parsing). + +Notation "'match:' e0 'with' 'NONE' => e1 | 'SOME' x => e2 'end'" := + (Match e0 BAnon e1 x%binder e2) + (e0, e1, x, e2 at level 200, only parsing) : expr_scope. +Notation "'match:' e0 'with' 'SOME' x => e2 | 'NONE' => e1 'end'" := + (Match e0 BAnon e1 x%binder e2) + (e0, e1, x, e2 at level 200, only parsing). + + +(* Shortcut for recursive definitions *) +Notation "'letrec:' f x := e1 'in' e2" := + (Lam f%binder e2%E (Rec f%binder x%binder e1%E)) + (at level 200, f at level 1, x at level 1, e1, e2 at level 200, + format "'[' 'letrec:' f x := '/ ' '[' e1 ']' 'in' '/' e2 ']'") + : expr_scope. + +Notation "'letrec:' f x y .. z := e1 'in' e2" := + (Lam f%binder e2%E + (Rec f%binder x%binder (Lam y%binder .. (Lam z%binder e1%E) ..))) + (at level 200, f at level 1, x,y,z at level 1, e1, e2 at level 200, + format "'[' 'letrec:' f x y .. z := '/ ' '[' e1 ']' 'in' '/' e2 ']'") + : expr_scope. + +(** Constructions on top of the language *) + +(** Serializer data type *) +Record serializer := + { s_ser : val; + s_deser : val }. + + +(** Assert construction *) +Definition assert : val := + λ: "v", if: "v" #() then #() else #0 #0. (* #0 #0 is unsafe *) + +Notation "'assert:' e" := (assert (λ: <>, e))%E (at level 99) : expr_scope. + +(** Mutex implementation using CAS *) +Definition newlock : val := λ: <>, ref #false. +Definition try_acquire : val := λ: "l", CAS "l" #false #true. +Definition acquire : val := + rec: "acquire" "l" := if: try_acquire "l" then #() else "acquire" "l". +Definition release : val := λ: "l", "l" <- #false. + +(** Shim for monitors. *) + +Definition new_monitor_def : val + := λ: <>, (#(), newlock #()). +Definition monitor_try_acquire_def : val + := λ: "mon", try_acquire (Snd "mon"). +Definition monitor_acquire_def : val + := λ: "mon", acquire (Snd "mon"). +Definition monitor_release_def : val + := λ: "mon", release (Snd "mon"). +Definition monitor_signal_def : val + := λ: "mon", #(). +Definition monitor_broadcast_def : val + := λ: "mon", #(). +Definition monitor_wait_def : val + := λ: "mon", + release (Snd "mon");; + acquire (Snd "mon"). + +Definition new_monitor_aux : seal (new_monitor_def). + by eexists. Qed. +Definition new_monitor := + new_monitor_aux.(unseal). +Definition new_monitor_eq : new_monitor = new_monitor_def + := new_monitor_aux.(seal_eq). + +Definition monitor_try_acquire_aux : seal (monitor_try_acquire_def). + by eexists. Qed. +Definition monitor_try_acquire + := monitor_try_acquire_aux.(unseal). +Definition monitor_try_acquire_eq : monitor_try_acquire = monitor_try_acquire_def + := monitor_try_acquire_aux.(seal_eq). + +Definition monitor_acquire_aux : seal (monitor_acquire_def). + by eexists. Qed. +Definition monitor_acquire + := monitor_acquire_aux.(unseal). +Definition monitor_acquire_eq : monitor_acquire = monitor_acquire_def + := monitor_acquire_aux.(seal_eq). + +Definition monitor_release_aux : seal (monitor_release_def). + by eexists. Qed. +Definition monitor_release + := monitor_release_aux.(unseal). +Definition monitor_release_eq : monitor_release = monitor_release_def + := monitor_release_aux.(seal_eq). + +Definition monitor_signal_aux : seal (monitor_signal_def). + by eexists. Qed. +Definition monitor_signal + := monitor_signal_aux.(unseal). +Definition monitor_signal_eq : monitor_signal = monitor_signal_def + := monitor_signal_aux.(seal_eq). + +Definition monitor_broadcast_aux : seal (monitor_broadcast_def). + by eexists. Qed. +Definition monitor_broadcast + := monitor_broadcast_aux.(unseal). +Definition monitor_broadcast_eq : monitor_broadcast = monitor_broadcast_def + := monitor_broadcast_aux.(seal_eq). + +Definition monitor_wait_aux : seal (monitor_wait_def). + by eexists. Qed. +Definition monitor_wait + := monitor_wait_aux.(unseal). +Definition monitor_wait_eq : monitor_wait = monitor_wait_def + := monitor_wait_aux.(seal_eq). diff --git a/fairneris/aneris_lang/base_lang.v b/fairneris/aneris_lang/base_lang.v new file mode 100644 index 0000000..2b8b562 --- /dev/null +++ b/fairneris/aneris_lang/base_lang.v @@ -0,0 +1,5 @@ +From fairneris.aneris_lang Require Export lang. + +Canonical Structure base_ectxi_lang := EctxiLanguage base_lang.head_step base_config_step base_lang.locale_of (* base_lang.base_config_enabled *) base_mixin. +Canonical Structure base_ectx_lang := EctxLanguageOfEctxi base_ectxi_lang. +Canonical Structure base_lang := LanguageOfEctx base_ectx_lang. diff --git a/fairneris/aneris_lang/events.v b/fairneris/aneris_lang/events.v new file mode 100644 index 0000000..03a0259 --- /dev/null +++ b/fairneris/aneris_lang/events.v @@ -0,0 +1,288 @@ +From trillium.events Require Export event. +From trillium.program_logic Require Import + language ectx_language ectxi_language. +From fairneris.aneris_lang Require Import aneris_lang base_lang. +From RecordUpdate Require Import RecordSet. +From fairneris.algebra Require Import disj_gsets. + +Import ast. +Import RecordSetNotations. + +Lemma fill_mkExpr ip K e : + fill K (mkExpr ip e) = mkExpr ip (fill (Λ := base_ectxi_lang) K e). +Proof. + induction K as [|? ? IH] using rev_ind; first done. + rewrite /= !fill_app /= IH //=. +Qed. + +Lemma is_Some_to_val_mkExpr ip e : + is_Some (ectx_language.to_val (mkExpr ip e)) ↔ is_Some (ectx_language.to_val e). +Proof. + rewrite /= /aneris_to_val /=; destruct (to_val e); simpl. + - split; eauto. + - split; intros [? ?]; done. +Qed. + +Program Definition allocEV (lbl : string) : Event aneris_lang := + {| is_triggered e σ e' σ' := + ∃ ip v h (ℓ : loc), + e = (mkExpr ip (ref<> (Val v))%E) ∧ + e' = (mkExpr ip #ℓ) ∧ + σ.(state_heaps) !! ip = Some h ∧ + h !! ℓ = None ∧ + σ' = σ <| state_heaps := <[ip:=<[ℓ:=v]>h]>(state_heaps σ) |> + |}. +Next Obligation. +Proof. + simpl; intros ?????(?&?&?&?&->&?); done. +Qed. +Next Obligation. +Proof. + simpl; intros ?????(?&?&h&?&->&?&?&?&?). + intros K [ip' e1'] He1. + rewrite fill_mkExpr in He1. + simplify_eq He1; intros -> He1'. + rewrite is_Some_to_val_mkExpr. + eapply (ectx_language.head_ctx_step_val (Λ := base_ectx_lang) _ _ h). + rewrite /= -He1'; constructor; done. +Qed. +Next Obligation. +Proof. + simpl; intros ?????(?&?&?&?&->&->&?). + intros Heq; simplify_eq/=. +Qed. + +Lemma allocEV_impure lbl eo : + validEventObservation (allocEV lbl) eo → eo.(pre_state) ≠ eo.(post_state). +Proof. + destruct 1 as (ip&v&h&ℓ&?&?&Hiplu&Hℓ&Hsts); intros Heq. + rewrite -Heq in Hsts. + pose proof (f_equal (λ σ, σ.(state_heaps) !! ip) Hsts) as Hsts2. + rewrite /= lookup_insert Hiplu in Hsts2. + simplify_eq Hsts2; intros Hsts3. + pose proof (f_equal (λ h, h !! ℓ) Hsts3) as Hsts4. + rewrite /= lookup_insert Hℓ in Hsts4; done. +Qed. + +Lemma allocEV_inj lbl lbl' e1 σ1 e2 σ2 : + allocEV lbl e1 σ1 e2 σ2 → allocEV lbl' e1 σ1 e2 σ2 → lbl = lbl'. +Proof. by intros (?&?&?&?&?&?&?&?&?) (?&?&?&?&?&?&?&?&?); simplify_eq. Qed. + +Definition allocObs (ip : ip_address) (lbl : string) (l : loc) (v : val) + (σ : state) (h : heap) := + mkEventObservation + (mkExpr ip (ref<> (Val v))) + σ + (mkExpr ip #l) + (σ <| state_heaps := <[ip:=<[l:=v]>h]>(state_heaps σ) |>). + +Definition valid_allocObs (ip : ip_address) (l : loc) (σ : state) (h : heap) := + σ.(state_heaps) !! ip = Some h ∧ h !! l = None. + +Program Definition sendonEV_groups (sag : gset socket_address) : Event aneris_lang := + {| is_triggered e σ e' σ' := + ∃ (sa : socket_address) (sh: socket_handle) + (mbody: string) (to: socket_address) skts skt r, + sa ∈ sag ∧ + σ.(state_sockets) !! (ip_of_address sa) = Some skts ∧ + skts !! sh = Some (skt, r) ∧ + saddress skt = Some sa ∧ + e = (mkExpr (ip_of_address sa) (SendTo #(LitSocket sh) #mbody #to)) ∧ + e' = (mkExpr (ip_of_address sa) #(String.length mbody)) ∧ + σ' = σ <| state_ms := {[+ mkMessage sa to mbody +]} ⊎ σ.(state_ms) |> + |}. +Next Obligation. +Proof. + simpl. intros ?????(?&?&?&?&?&?&?&?&?&?&?&->&?); done. +Qed. +Next Obligation. +Proof. + simpl; intros ?????(?&?&?&?&?&?&?&?&?&?&?&->&?&?). + intros K [ip' e1'] He1. + rewrite fill_mkExpr in He1. + simplify_eq He1; intros <- He1'. + eapply (ectx_language.head_ctx_step_val (Λ := aneris_ectx_lang) _ _ σ1). + rewrite /= fill_mkExpr. + rewrite /= -He1'. eapply SocketStepS; last done. + econstructor; done. +Qed. +Next Obligation. +Proof. + simpl; intros ?????(?&?&?&?&?&?&?&?&?&?&?&->&->&?). + intros Heq; simplify_eq/=. +Qed. + +Definition sendonEV (sa : socket_address) : Event aneris_lang := + sendonEV_groups {[sa]}. + +Lemma sendonEV_groups_impure sag eo : + validEventObservation (sendonEV_groups sag) eo → eo.(pre_state) ≠ eo.(post_state). +Proof. + destruct 1 as (sa&sh&mbody&to&skts&skt&r&Hsa&Hiplu&Hskts&Hskt&?&?&Hsts); intros Heq. + rewrite -Heq in Hsts. + set (msg := {| m_sender := sa; m_destination := to; m_body := mbody |}). + pose proof (f_equal (λ σ, multiplicity msg σ.(state_ms)) Hsts) as Hsts2. + rewrite /= multiplicity_disj_union multiplicity_singleton in Hsts2; lia. +Qed. + +Lemma sendonEV_groups_inj sag sag' e1 σ1 e2 σ2 : + eq_or_disj sag sag' → + sendonEV_groups sag e1 σ1 e2 σ2 → sendonEV_groups sag' e1 σ1 e2 σ2 → sag = sag'. +Proof. + intros Hdisj. + intros (sa&?&?&?&?&?&?&Hsa&?&?&?&?&?&?) (sa'&?&?&?&?&?&?&Hsa'&?&?&?&?&?&?). + destruct Hdisj as [ Hdisj | Hdisj ]; [ done | ]. + assert (sa = sa'). + { destruct sa; destruct sa'. simplify_eq/=. done. } + subst. + pose proof (elem_of_disjoint sag sag') as [Hfalso _]. + specialize (Hfalso Hdisj _ Hsa Hsa'). + done. +Qed. + +Lemma sendonEV_inj sa sa' e1 σ1 e2 σ2 : + sendonEV sa e1 σ1 e2 σ2 → sendonEV sa' e1 σ1 e2 σ2 → sa = sa'. +Proof. + intros H1 H2. + assert ({[sa]} = ({[sa']}:gset _)). + { eapply sendonEV_groups_inj; [apply eq_or_disj_singleton|done..]. } + set_solver. +Qed. + +Definition sendonObs (sa : socket_address) (σ : state) (sh : socket_handle) + (mbody: string) (to : socket_address) (skt : socket) := + mkEventObservation + (mkExpr (ip_of_address sa) (SendTo #(LitSocket sh) #mbody #to)) + σ + (mkExpr (ip_of_address sa) #(String.length mbody)) + (σ <| state_ms := {[+ mkMessage sa to mbody +]} ⊎ σ.(state_ms) |>). + +Definition valid_sendonObs (sa : socket_address) (σ : state) (sh : socket_handle) + (skts : sockets) (skt : socket) (r : list message) := + σ.(state_sockets) !! (ip_of_address sa) = Some skts ∧ + skts !! sh = Some (skt, r) ∧ + saddress skt = Some sa. + +Program Definition receiveonEV_groups + (sag : gset socket_address) : Event aneris_lang := + {| is_triggered e σ e' σ' := + ∃ (sa : socket_address) (sh: socket_handle) skts skt r m, + sa ∈ sag ∧ + σ.(state_sockets) !! (ip_of_address sa) = Some skts ∧ + skts !! sh = Some (skt, r ++ [m]) ∧ + saddress skt = Some sa ∧ + e = (mkExpr (ip_of_address sa) (ReceiveFrom #(LitSocket sh))) ∧ + e' = (mkExpr (ip_of_address sa) (SOMEV (#(m_body m),#(m_sender m)))) ∧ + σ' = σ <| state_sockets := <[(ip_of_address sa) := + <[sh := (skt, r)]>skts]> σ.(state_sockets) |> + |}. +Next Obligation. +Proof. + simpl; intros ?????(?&?&?&?&?&?&?&?&?&?&->&?); done. +Qed. +Next Obligation. +Proof. + simpl; intros ?????(?&?&?&?&?&?&?&?&?&?&->&?&?). + intros K [ip' e1'] He1. + rewrite fill_mkExpr in He1. + simplify_eq He1; intros <- He1'. + eapply (ectx_language.head_ctx_step_val (Λ := aneris_ectx_lang) _ _ σ1). + rewrite /= fill_mkExpr. + rewrite /= -He1'. eapply SocketStepS; last done. + econstructor; done. +Qed. +Next Obligation. +Proof. + simpl; intros ?????(?&?&?&?&?&?&?&?&?&?&->&->&?). + intros Heq; simplify_eq/=. +Qed. + +Definition receiveonEV (sa : socket_address) : Event aneris_lang := + receiveonEV_groups {[sa]}. + +Lemma receiveonEV_groups_impure sag eo : + validEventObservation (receiveonEV_groups sag) eo → eo.(pre_state) ≠ eo.(post_state). +Proof. + destruct 1 as (sa&sh&skts&skt&r&m&Hsa&Hiplu&Hskts&Hskt&?&?&Hsts); intros Heq. + rewrite -Heq in Hsts. + pose proof (f_equal (λ σ, σ.(state_sockets) !! (ip_of_address sa)) Hsts) as Hsts2. + rewrite /= lookup_insert Hiplu in Hsts2. + simplify_eq Hsts2; intros Hsts3. + pose proof (f_equal (λ h, h !! sh) Hsts3) as Hsts4. + rewrite /= lookup_insert Hskts in Hsts4. + list_simplifier. assert ([m] = []); last done. + eapply (inj (app r)). by list_simplifier. +Qed. + +Lemma receiveonEV_groups_inj sag sag' e1 σ1 e2 σ2 : + eq_or_disj sag sag' → + receiveonEV_groups sag e1 σ1 e2 σ2 → receiveonEV_groups sag' e1 σ1 e2 σ2 → sag = sag'. +Proof. + intros Hdisj. + intros (sa&?&?&?&?&?&Hsa&?&?&?&?&?&?) (sa'&?&?&?&?&?&Hsa'&?&?&?&?&?&?). + destruct Hdisj as [ Hdisj | Hdisj ]; [ done | ]. + assert (sa = sa'). + { destruct sa; destruct sa'. simplify_eq/=. done. } + subst. + pose proof (elem_of_disjoint sag sag') as [Hfalso _]. + specialize (Hfalso Hdisj _ Hsa Hsa'). + done. +Qed. + +Lemma receiveonEV_inj sa sa' e1 σ1 e2 σ2 : + receiveonEV sa e1 σ1 e2 σ2 → receiveonEV sa' e1 σ1 e2 σ2 → sa = sa'. +Proof. + intros H1 H2. + assert ({[sa]} = ({[sa']}:gset _)). + { eapply receiveonEV_groups_inj; [apply eq_or_disj_singleton|done..]. } + set_solver. +Qed. + +Definition receiveonObs (sa : socket_address) (σ : state) (sh : socket_handle) + (m: message) (skts : sockets) (skt : socket) (r : list message) := + mkEventObservation + (mkExpr (ip_of_address sa) (ReceiveFrom #(LitSocket sh))) + σ + (mkExpr (ip_of_address sa) (SOMEV (#(m_body m),#(m_sender m)))) + (σ <| state_sockets := + <[(ip_of_address sa):= <[sh := (skt, r)]>skts]> σ.(state_sockets) |>). + +Definition valid_receiveonObs (sa : socket_address) (σ : state) + (sh : socket_handle) (m: message) + (skts : sockets) (skt : socket) (r : list message) := + σ.(state_sockets) !! (ip_of_address sa) = Some skts ∧ + skts !! sh = Some (skt, r ++ [m]) ∧ saddress skt = Some sa. + +(** if one event is triggered, the other two are not *) +Lemma ev_not_others_alloc_groups lbl e1 σ1 e2 σ2 : + allocEV lbl e1 σ1 e2 σ2 → + (∀ sag, ¬ sendonEV_groups sag e1 σ1 e2 σ2) ∧ + (∀ sag, ¬ receiveonEV_groups sag e1 σ1 e2 σ2). +Proof. + destruct 1 as (?&?&?&?&?&?&?&?&?); simplify_eq. + split. + - intros ? (?&?&?&?&?&?&?&?&?&?&?&?&?); done. + - intros ? (?&?&?&?&?&?&?&?&?&?&?&?&?); done. +Qed. + +Lemma ev_not_others_sendon_groups sag e1 σ1 e2 σ2 : + sendonEV_groups sag e1 σ1 e2 σ2 → + (∀ lbl, ¬ allocEV lbl e1 σ1 e2 σ2) ∧ + (∀ sag', ¬ receiveonEV_groups sag' e1 σ1 e2 σ2). +Proof. + destruct 1 as (?&?&?&?&?&?&?&?&?&?&?&?&?&?); simplify_eq. + split. + - intros ? (?&?&?&?&?&?&?&?&?); done. + - intros ? (?&?&?&?&?&?&?&?&?&?&?&?&?); done. +Qed. + +Lemma ev_not_others_receiveon_groups sag e1 σ1 e2 σ2 : + receiveonEV_groups sag e1 σ1 e2 σ2 → + (∀ sag', ¬ sendonEV_groups sag' e1 σ1 e2 σ2) ∧ + (∀ sag', ¬ allocEV sag' e1 σ1 e2 σ2). +Proof. + destruct 1 as (?&?&?&?&?&?&?&?&?&?&?&?&?); simplify_eq. + split. + - intros ? (?&?&?&?&?&?&?&?&?&?&?&?&?&?); done. + - intros ? (?&?&?&?&?&?&?&?&?); done. +Qed. diff --git a/fairneris/aneris_lang/lang.v b/fairneris/aneris_lang/lang.v new file mode 100644 index 0000000..e02c574 --- /dev/null +++ b/fairneris/aneris_lang/lang.v @@ -0,0 +1,1171 @@ +From fairneris.aneris_lang Require Export ast. +From fairneris.prelude Require Export strings. +From trillium.program_logic Require Export + language ectx_language ectxi_language adequacy. +From iris.algebra Require Export ofe gset. +From stdpp Require Export strings. +From stdpp Require Import gmap fin pretty. +From stdpp Require Export binders. +From RecordUpdate Require Import RecordSet. +From fairneris.aneris_lang Require Export network. + +Set Default Proof Using "Type". + +Delimit Scope expr_scope with E. +Delimit Scope val_scope with V. + +Module base_lang. +Open Scope Z_scope. + +Export ast. +Definition to_val (e : expr) : option val := + match e with + | Val v => Some v + | _ => None + end. + +(** The state: heaps of vals. *) +Definition state := gmap loc val. + +(** Equality and other typeclass stuff *) +Lemma to_of_val v : to_val (of_val v) = Some v. +Proof. by destruct v. Qed. + +Lemma of_to_val e v : to_val e = Some v → of_val v = e. +Proof. destruct e=>//=. by intros [= <-]. Qed. + +#[global] Instance of_val_inj : Inj (=) (=) of_val. +Proof. intros ??. congruence. Qed. + +#[global] Instance base_lit_eq_dec : EqDecision base_lit. +Proof. solve_decision. Defined. +#[global] Instance un_op_eq_dec : EqDecision un_op. +Proof. solve_decision. Defined. +#[global] Instance bin_op_eq_dec : EqDecision bin_op. +Proof. solve_decision. Defined. +#[global] Instance expr_eq_dec : EqDecision expr. +Proof. + refine ( + fix go (e1 e2 : expr) {struct e1} : Decision (e1 = e2) := + match e1, e2 with + | Val v, Val v' => cast_if (decide (v = v')) + | Var x, Var x' => cast_if (decide (x = x')) + | Rec f x e, Rec f' x' e' => + cast_if_and3 (decide (f = f')) (decide (x = x')) (decide (e = e')) + | App e1 e2, App e1' e2' => + cast_if_and (decide (e1 = e1')) (decide (e2 = e2')) + | UnOp o e, UnOp o' e' => cast_if_and (decide (o = o')) (decide (e = e')) + | BinOp o e1 e2, BinOp o' e1' e2' => + cast_if_and3 (decide (o = o')) (decide (e1 = e1')) (decide (e2 = e2')) + | If e0 e1 e2, If e0' e1' e2' => + cast_if_and3 + (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2')) + | FindFrom e0 e1 e2, FindFrom e0' e1' e2' => + cast_if_and3 + (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2')) + | Substring e0 e1 e2, Substring e0' e1' e2' => + cast_if_and3 + (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2')) + | Rand e, Rand e' => cast_if (decide (e = e')) + | Pair e1 e2, Pair e1' e2' => + cast_if_and (decide (e1 = e1')) (decide (e2 = e2')) + | Fst e, Fst e' => cast_if (decide (e = e')) + | Snd e, Snd e' => cast_if (decide (e = e')) + | InjL e, InjL e' => cast_if (decide (e = e')) + | InjR e, InjR e' => cast_if (decide (e = e')) + | Case e0 e1 e2, Case e0' e1' e2' => + cast_if_and3 + (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2')) + | Fork e, Fork e' => cast_if (decide (e = e')) + | Alloc lbl e, Alloc lbl' e' => + cast_if_and (decide (lbl = lbl')) (decide (e = e')) + | Load e, Load e' => cast_if (decide (e = e')) + | Store e1 e2, Store e1' e2' => + cast_if_and (decide (e1 = e1')) (decide (e2 = e2')) + | CAS e0 e1 e2, CAS e0' e1' e2' => + cast_if_and3 + (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2')) + | MakeAddress e1 e2, MakeAddress e1' e2' => + cast_if_and (decide (e1 = e1')) (decide (e2 = e2')) + | GetAddressInfo e, GetAddressInfo e' => + cast_if (decide (e = e')) + | NewSocket e, NewSocket e' => cast_if (decide (e = e')) + | SocketBind e1 e2, SocketBind e1' e2' => + cast_if_and (decide (e1 = e1')) (decide (e2 = e2')) + | SendTo e0 e1 e2, SendTo e0' e1' e2' => + cast_if_and3 + (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2')) + | SendToRepeat e0 e1 e2, SendToRepeat e0' e1' e2' => + cast_if_and3 + (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2')) + | ReceiveFrom e, ReceiveFrom e' => cast_if (decide (e = e')) + | SetReceiveTimeout e0 e1 e2, SetReceiveTimeout e0' e1' e2' => + cast_if_and3 + (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2')) + | Start e0 e1, Start e0' e1' => + cast_if_and (decide (e0 = e0')) (decide (e1 = e1')) + | _, _ => right _ + end + with gov (v1 v2 : val) {struct v1} : Decision (v1 = v2) := + match v1, v2 with + | LitV l, LitV l' => cast_if (decide (l = l')) + | RecV f x e, RecV f' x' e' => + cast_if_and3 (decide (f = f')) (decide (x = x')) (decide (e = e')) + | PairV e1 e2, PairV e1' e2' => + cast_if_and (decide (e1 = e1')) (decide (e2 = e2')) + | InjLV e, InjLV e' => cast_if (decide (e = e')) + | InjRV e, InjRV e' => cast_if (decide (e = e')) + | _, _ => right _ + end + for go); try (clear go gov; abstract intuition congruence). +Defined. +#[global] Instance val_eq_dec : EqDecision val. +Proof. solve_decision. Defined. + +#[global] Instance base_lit_countable : Countable base_lit. +Proof. + refine (inj_countable' (λ l, match l with + | LitInt n => inl (inl (inl (inl n))) + | LitBool b => inl (inl (inl (inr b))) + | LitUnit => inl (inl (inr (inl ()))) + | LitLoc l => inl (inl (inr (inr l))) + | LitString s => inl (inr (inl (inl s))) + | LitSocket s => inr (inl (inl (inl s))) + | LitSocketAddress a => inr (inl (inl (inr a))) + end) (λ l, match l with + | inl (inl (inl (inl n))) => LitInt n + | inl (inl (inl (inr b))) => LitBool b + | inl (inl (inr (inl ()))) => LitUnit + | inl (inl (inr (inr l))) => LitLoc l + | inl (inr (inl (inl s))) => LitString s + | inl (inr (inl (inr ()))) => LitUnit + | inl (inr (inr (inl ()))) => LitUnit + | inl (inr (inr (inr ()))) => LitUnit + | inr (inl (inl (inl s))) => LitSocket s + | inr (inl (inl (inr a))) => LitSocketAddress a + | inr (inl (inr (inl ()))) => LitUnit + | inr (inl (inr (inr ()))) => LitUnit + | inr (inr (inl (inl ()))) => LitUnit + | inr (inr (inl (inr ()))) => LitUnit + | inr (inr (inr (inl ()))) => LitUnit + | inr (inr (inr (inr ()))) => LitUnit + end) _); by intros []. +Qed. + +#[global] Instance un_op_countable : Countable un_op. +Proof. + refine (inj_countable' (λ op, match op with + | NegOp => 0 + | MinusUnOp => 1 + | StringOfInt => 2 + | IntOfString => 3 + | StringLength => 4 + end) (λ n, match n with + | 0 => NegOp + | 1 => MinusUnOp + | 2 => StringOfInt + | 3 => IntOfString + | _ => StringLength + end) _); by intros []. +Qed. + +#[global] Instance bin_op_countable : Countable bin_op. +Proof. + refine (inj_countable' (λ op, match op with + | PlusOp => 0 + | MinusOp => 1 + | MultOp => 2 + | QuotOp => 3 + | RemOp => 4 + | AndOp => 5 + | OrOp => 6 + | XorOp => 7 + | ShiftLOp => 8 + | ShiftROp => 9 + | LeOp => 10 + | LtOp => 11 + | EqOp => 12 + | StringApp => 13 + end) (λ n, match n with + | 0 => PlusOp + | 1 => MinusOp + | 2 => MultOp + | 3 => QuotOp + | 4 => RemOp + | 5 => AndOp + | 6 => OrOp + | 7 => XorOp + | 8 => ShiftLOp + | 9 => ShiftROp + | 10 => LeOp + | 11 => LtOp + | 12 => EqOp + | _ => StringApp + end) _); by intros []. +Qed. + +#[global] Instance expr_countable : Countable expr. +Proof. + set (enc := + fix go e := + match e with + | Val v => GenNode 0 [gov v] + | Var x => GenLeaf (inl (inl (inl x))) + | Rec f x e => + GenNode 1 [GenLeaf (inl (inl (inr f))); GenLeaf (inl (inl (inr x))); go e] + | App e1 e2 => GenNode 2 [go e1; go e2] + | UnOp op e => GenNode 3 [GenLeaf (inl (inr (inr (inl op)))); go e] + | BinOp op e1 e2 => GenNode 4 [GenLeaf (inl (inr (inr (inr op)))); go e1; go e2] + | If e0 e1 e2 => GenNode 5 [go e0; go e1; go e2] + | Pair e1 e2 => GenNode 6 [go e1; go e2] + | Fst e => GenNode 7 [go e] + | Snd e => GenNode 8 [go e] + | InjL e => GenNode 9 [go e] + | InjR e => GenNode 10 [go e] + | Case e0 e1 e2 => GenNode 11 [go e0; go e1; go e2] + | Fork e => GenNode 12 [go e] + | Alloc lbl e => GenNode 13 [GenLeaf (inr lbl); go e] + | Load e => GenNode 14 [go e] + | Store e1 e2 => GenNode 15 [go e1; go e2] + | MakeAddress e1 e2 => GenNode 16 [go e1; go e2] + | NewSocket e => GenNode 17 [go e] + | SocketBind e1 e2 => GenNode 18 [go e1; go e2] + | SendTo e1 e2 e3 => GenNode 19 [go e1; go e2; go e3] + | ReceiveFrom e => GenNode 20 [go e] + | SetReceiveTimeout e1 e2 e3 => GenNode 21 [go e1; go e2; go e3] + | Start i e => GenNode 22 [GenLeaf (inl (inr (inl i))); go e] + | FindFrom e1 e2 e3 => GenNode 23 [go e1; go e2; go e3] + | Substring e1 e2 e3 => GenNode 24 [go e1; go e2; go e3] + | CAS e1 e2 e3 => GenNode 25 [go e1; go e2; go e3] + | GetAddressInfo e => GenNode 26 [go e] + | Rand e => GenNode 27 [go e] + | SendToRepeat e1 e2 e3 => GenNode 28 [go e1; go e2; go e3] + end + with gov v := + match v with + | LitV l => GenLeaf (inl (inr (inl l))) + | RecV f x e => + GenNode 0 [GenLeaf (inl (inl (inr f))); GenLeaf (inl (inl (inr x))); go e] + | PairV v1 v2 => GenNode 1 [gov v1; gov v2] + | InjLV v => GenNode 2 [gov v] + | InjRV v => GenNode 3 [gov v] + end + for go). + set (dec := + fix go e := + match e with + | GenNode 0 [v] => Val (gov v) + | GenLeaf (inl (inl (inl x))) => Var x + | GenNode + 1 [GenLeaf (inl (inl (inr f))); GenLeaf (inl (inl (inr x))); e] => + Rec f x (go e) + | GenNode 2 [e1; e2] => App (go e1) (go e2) + | GenNode 3 [GenLeaf (inl (inr (inr (inl op)))); e] => UnOp op (go e) + | GenNode + 4 [GenLeaf (inl (inr (inr (inr op)))); e1; e2] => BinOp op (go e1) (go e2) + | GenNode 5 [e0; e1; e2] => If (go e0) (go e1) (go e2) + | GenNode 6 [e1; e2] => Pair (go e1) (go e2) + | GenNode 7 [e] => Fst (go e) + | GenNode 8 [e] => Snd (go e) + | GenNode 9 [e] => InjL (go e) + | GenNode 10 [e] => InjR (go e) + | GenNode 11 [e0; e1; e2] => Case (go e0) (go e1) (go e2) + | GenNode 12 [e] => Fork (go e) + | GenNode 13 [GenLeaf (inr lbl);e] => Alloc lbl (go e) + | GenNode 14 [e] => Load (go e) + | GenNode 15 [e1; e2] => Store (go e1) (go e2) + | GenNode 16 [e1; e2] => MakeAddress (go e1) (go e2) + | GenNode 17 [e] => NewSocket (go e) + | GenNode 18 [e1; e2] => SocketBind (go e1) (go e2) + | GenNode 19 [e1; e2; e3] => SendTo (go e1) (go e2) (go e3) + | GenNode 20 [e] => ReceiveFrom (go e) + | GenNode 21 [e1; e2; e3] => SetReceiveTimeout (go e1) (go e2) (go e3) + | GenNode 22 [GenLeaf (inl (inr (inl i))); e2] => Start i (go e2) + | GenNode 23 [e1; e2; e3] => FindFrom (go e1) (go e2) (go e3) + | GenNode 24 [e1; e2; e3] => Substring (go e1) (go e2) (go e3) + | GenNode 25 [e1; e2; e3] => CAS (go e1) (go e2) (go e3) + | GenNode 26 [e] => GetAddressInfo (go e) + | GenNode 27 [e] => Rand (go e) + | GenNode 28 [e1; e2; e3] => SendToRepeat (go e1) (go e2) (go e3) + | _ => Val $ LitV LitUnit (* dummy *) + end + with gov v := + match v with + | GenLeaf (inl (inr (inl l))) => LitV l + | GenNode + 0 [GenLeaf (inl (inl (inr f))); GenLeaf (inl (inl (inr x))); e] => RecV f x (go e) + | GenNode 1 [v1; v2] => PairV (gov v1) (gov v2) + | GenNode 2 [v] => InjLV (gov v) + | GenNode 3 [v] => InjRV (gov v) + | _ => LitV LitUnit (* dummy *) + end + for go). + refine (inj_countable' enc dec _). + refine (fix go (e : expr) {struct e} + := _ with gov (v : val) {struct v} := _ for go). + - destruct e; simpl; f_equal; [exact (gov v)|done..]. + - destruct v; by f_equal. +Qed. + +#[global] Instance val_countable : Countable val. +Proof. refine (inj_countable of_val to_val _); auto using to_of_val. Qed. + +#[global] Instance val_inhabited : Inhabited val := populate (LitV LitUnit). +#[global] Instance expr_inhabited : Inhabited expr := populate (Val inhabitant). + +Definition stateC := leibnizO state. +Definition valC := leibnizO val. +Definition exprC := leibnizO expr. + +(** Evaluation contexts *) +Inductive ectx_item := +| AppLCtx (v2 : val) +| AppRCtx (e1 : expr) +| UnOpCtx (op : un_op) +| BinOpLCtx (op : bin_op) (v2 : val) +| BinOpRCtx (op : bin_op) (e1 : expr) +| IfCtx (e1 e2 : expr) +| FindFromLCtx (v1 v2 : val) +| FindFromMCtx (e0 : expr) (v2 : val) +| FindFromRCtx (e0 e1 : expr) +| SubstringLCtx (v1 v2 : val) +| SubstringMCtx (e0 : expr) (v2 : val) +| SubstringRCtx (e0 e1 : expr) +| RandCtx +| PairLCtx (v2 : val) +| PairRCtx (e1 : expr) +| FstCtx +| SndCtx +| InjLCtx +| InjRCtx +| CaseCtx (e1 : expr) (e2 : expr) +| AllocCtx (lbl : option string) +| LoadCtx +| StoreLCtx (v2 : val) +| StoreRCtx (e1 : expr) +| CasLCtx (v1 v2 : val) +| CasMCtx (e0 : expr) (v2 : val) +| CasRCtx (e0 e1 : expr) +| MakeAddressLCtx (v2 : val) +| MakeAddressRCtx (e1 : expr) +| GetAddressInfoCtx +| NewSocketCtx +| SocketBindLCtx (v2 : val) +| SocketBindRCtx (e1 : expr) +| SendToLCtx (v1 v2 : val) +| SendToMCtx (e0 : expr) (v2 : val) +| SendToRCtx (e0 e1 : expr) +| SetReceiveTimeoutLCtx (v1 v2 : val) +| SetReceiveTimeoutMCtx (e0 : expr) (v2 : val) +| SetReceiveTimeoutRCtx (e0 e1 : expr) +| ReceiveFromCtx. + +Definition fill_item (Ki : ectx_item) (e : expr) : expr := + match Ki with + | AppLCtx v2 => App e (Val v2) + | AppRCtx e1 => App e1 e + | UnOpCtx op => UnOp op e + | BinOpLCtx op v2 => BinOp op e (Val v2) + | BinOpRCtx op e1 => BinOp op e1 e + | IfCtx e1 e2 => If e e1 e2 + | FindFromLCtx v1 v2 => FindFrom e (Val v1) (Val v2) + | FindFromMCtx e0 v2 => FindFrom e0 e (Val v2) + | FindFromRCtx e0 e1 => FindFrom e0 e1 e + | SubstringLCtx v1 v2 => Substring e (Val v1) (Val v2) + | SubstringMCtx e0 v2 => Substring e0 e (Val v2) + | SubstringRCtx e0 e1 => Substring e0 e1 e + | RandCtx => Rand e + | PairLCtx v2 => Pair e (Val v2) + | PairRCtx e1 => Pair e1 e + | FstCtx => Fst e + | SndCtx => Snd e + | InjLCtx => InjL e + | InjRCtx => InjR e + | CaseCtx e1 e2 => Case e e1 e2 + | AllocCtx lbl => Alloc lbl e + | LoadCtx => Load e + | StoreLCtx v2 => Store e (Val v2) + | StoreRCtx e1 => Store e1 e + | CasLCtx v1 v2 => CAS e (Val v1) (Val v2) + | CasMCtx e0 v2 => CAS e0 e (Val v2) + | CasRCtx e0 e1 => CAS e0 e1 e + | MakeAddressLCtx v2 => MakeAddress e (Val v2) + | MakeAddressRCtx e1 => MakeAddress e1 e + | GetAddressInfoCtx => GetAddressInfo e + | NewSocketCtx => NewSocket e + | SocketBindLCtx v2 => SocketBind e (Val v2) + | SocketBindRCtx e1 => SocketBind e1 e + | SendToLCtx v1 v2 => SendTo e (Val v1) (Val v2) + | SendToMCtx e0 v2 => SendTo e0 e (Val v2) + | SendToRCtx e0 e1 => SendTo e0 e1 e + | SetReceiveTimeoutLCtx v1 v2 => SetReceiveTimeout e (Val v1) (Val v2) + | SetReceiveTimeoutMCtx e0 v2 => SetReceiveTimeout e0 e (Val v2) + | SetReceiveTimeoutRCtx e0 e1 => SetReceiveTimeout e0 e1 e + | ReceiveFromCtx => ReceiveFrom e + end. + +(** Substitution *) +Fixpoint subst (x : string) (v : val) (e : expr) : expr := + match e with + | Val _ => e + | Var y => if decide (x = y) then Val v else Var y + | Rec f y e => + Rec f y $ if decide (BNamed x ≠ f ∧ BNamed x ≠ y) then subst x v e else e + | App e1 e2 => App (subst x v e1) (subst x v e2) + | UnOp op e => UnOp op (subst x v e) + | BinOp op e1 e2 => BinOp op (subst x v e1) (subst x v e2) + | If e0 e1 e2 => If (subst x v e0) (subst x v e1) (subst x v e2) + | FindFrom e0 e1 e2 => FindFrom (subst x v e0) (subst x v e1) (subst x v e2) + | Substring e0 e1 e2 => Substring (subst x v e0) (subst x v e1) (subst x v e2) + | Rand e => Rand (subst x v e) + | Pair e1 e2 => Pair (subst x v e1) (subst x v e2) + | Fst e => Fst (subst x v e) + | Snd e => Snd (subst x v e) + | InjL e => InjL (subst x v e) + | InjR e => InjR (subst x v e) + | Case e0 e1 e2 => Case (subst x v e0) (subst x v e1) (subst x v e2) + | Fork e => Fork (subst x v e) + | Alloc lbl e => Alloc lbl (subst x v e) + | Load e => Load (subst x v e) + | Store e1 e2 => Store (subst x v e1) (subst x v e2) + | CAS e0 e1 e2 => CAS (subst x v e0) (subst x v e1) (subst x v e2) + | MakeAddress e1 e2 => MakeAddress (subst x v e1) (subst x v e2) + | GetAddressInfo e => GetAddressInfo (subst x v e) + | NewSocket e => NewSocket (subst x v e) + | SocketBind e1 e2 => SocketBind (subst x v e1) (subst x v e2) + | SendTo e0 e1 e2 => SendTo (subst x v e0) (subst x v e1) (subst x v e2) + | SendToRepeat e0 e1 e2 => SendToRepeat (subst x v e0) (subst x v e1) (subst x v e2) + | SetReceiveTimeout e0 e1 e2 => + SetReceiveTimeout (subst x v e0) (subst x v e1) (subst x v e2) + | ReceiveFrom e => ReceiveFrom (subst x v e) + | Start i e => Start i (subst x v e) + end. + +Definition subst' (mx : binder) (v : val) : expr → expr := + match mx with BNamed x => subst x v | BAnon => id end. + +(** The stepping relation *) +Definition un_op_eval (op : un_op) (v : val) : option val := + match op, v with + | NegOp, LitV (LitBool b) => Some $ LitV $ LitBool (negb b) + | NegOp, LitV (LitInt n) => Some $ LitV $ LitInt (Z.lnot n) + | MinusUnOp, LitV (LitInt n) => Some $ LitV $ LitInt (- n) + | StringOfInt, LitV (LitInt n) => Some $ LitV $ LitString (StringOfZ n) + | IntOfString, LitV (LitString s) => + match ZOfString s with + Some z => Some $ InjRV $ LitV (LitInt z) + | None => Some $ InjLV (LitV (LitUnit)) + end + | StringLength, LitV (LitString s) => Some $ LitV $ LitInt (String.length s) + | _, _ => None + end. + +Definition bin_op_eval_int (op : bin_op) (n1 n2 : Z) : base_lit := + match op with + | PlusOp => LitInt (n1 + n2) + | MinusOp => LitInt (n1 - n2) + | MultOp => LitInt (n1 * n2) + | QuotOp => LitInt (n1 `quot` n2) + | RemOp => LitInt (n1 `rem` n2) + | AndOp => LitInt (Z.land n1 n2) + | OrOp => LitInt (Z.lor n1 n2) + | XorOp => LitInt (Z.lxor n1 n2) + | ShiftLOp => LitInt (n1 ≪ n2) + | ShiftROp => LitInt (n1 ≫ n2) + | LeOp => LitBool (bool_decide (n1 ≤ n2)) + | LtOp => LitBool (bool_decide (n1 < n2)) + | EqOp => LitBool (bool_decide (n1 = n2)) + | StringApp => LitInt 0 + end. + +Definition bin_op_eval_bool (op : bin_op) (b1 b2 : bool) : option base_lit := + match op with + | PlusOp | MinusOp | MultOp | QuotOp | RemOp => None (* Arithmetic *) + | AndOp => Some (LitBool (b1 && b2)) + | OrOp => Some (LitBool (b1 || b2)) + | XorOp => Some (LitBool (xorb b1 b2)) + | ShiftLOp | ShiftROp => None (* Shifts *) + | LeOp | LtOp | StringApp => None (* InEquality *) + | EqOp => Some (LitBool (bool_decide (b1 = b2))) + end. + +Definition bin_op_eval (op : bin_op) (v1 v2 : val) : option val := + match v1, v2, op with + | LitV (LitInt n1), LitV (LitInt n2), op => + Some $ LitV $ bin_op_eval_int op n1 n2 + | LitV (LitBool b1), LitV (LitBool b2), op => + LitV <$> bin_op_eval_bool op b1 b2 + | LitV (LitString s1), LitV (LitString s2), StringApp => + Some $ LitV $ LitString (String.append s1 s2) + | v1, v2, op => + guard (op = EqOp);; Some $ LitV $ LitBool $ bool_decide (v1 = v2) + end. + +Lemma bin_op_eval_eq_val k k' : + bin_op_eval EqOp k' k = Some (LitV $ LitBool $ bool_decide (k' = k)). +Proof. + destruct k, k'; cbn; try reflexivity; try (destruct l; reflexivity). + destruct l, l0; try reflexivity; repeat f_equal. + { rewrite /bool_decide. + case (decide_rel _ _ n), (decide_rel _ _ (LitV $ LitInt n)); congruence. } + { rewrite /bool_decide. + case (decide_rel _ _ b), (decide_rel _ _ (LitV $ LitBool b)); congruence. } +Qed. + +Definition option_nat_to_val (v : option nat) := + match v with + | None => InjLV (LitV LitUnit) + | Some v' => InjRV (LitV $ LitInt (Z.of_nat v')) + end. + +Inductive head_step + : expr → state → option unit → expr → state → list expr → Prop := + | RecS f x e σ : + head_step (Rec f x e) σ None (Val $ RecV f x e) σ [] + | PairS v1 v2 σ : + head_step (Pair (Val v1) (Val v2)) σ None (Val $ PairV v1 v2) σ [] + | InjLS v σ : + head_step (InjL $ Val v) σ None (Val $ InjLV v) σ [] + | InjRS v σ : + head_step (InjR $ Val v) σ None (Val $ InjRV v) σ [] + | BetaS f x e1 v2 e' σ : + e' = subst' x v2 (subst' f (RecV f x e1) e1) → + head_step (App (Val $ RecV f x e1) (Val v2)) σ None e' σ [] + | UnOpS op v v' σ : + un_op_eval op v = Some v' → + head_step (UnOp op (Val v)) σ None (Val v') σ [] + | BinOpS op v1 v2 v' σ : + bin_op_eval op v1 v2 = Some v' → + head_step (BinOp op (Val v1) (Val v2)) σ None (Val v') σ [] + | IfTrueS e1 e2 σ : + head_step (If (Val $ LitV $ LitBool true) e1 e2) σ None e1 σ [] + | IfFalseS e1 e2 σ : + head_step (If (Val $ LitV $ LitBool false) e1 e2) σ None e2 σ [] + | FindFromS v0 v1 v2 σ : + head_step (FindFrom + (Val $ LitV $ LitString v0) + (Val $ LitV $ LitInt (Z.of_nat v1)) + (Val $ LitV $ LitString v2)) σ None + (of_val (option_nat_to_val (index v1 v2 v0))) σ + [] + | SubstringS v0 v1 v2 σ : + head_step (Substring (Val (LitV $ LitString v0)) + (Val (LitV $ LitInt (Z.of_nat v1))) + (Val (LitV $ LitInt (Z.of_nat v2)))) σ None + (Val $ LitV $ LitString (substring v1 v2 v0)) σ + [] + | RandS n n' σ : + n' >= 0 -> + n' < n -> + head_step (Rand $ Val $ LitV $ LitInt n) σ None (Val $ LitV $ LitInt n') σ [] + | FstS v1 v2 σ : + head_step (Fst (Val $ PairV v1 v2)) σ None (Val v1) σ [] + | SndS v1 v2 σ : + head_step (Snd (Val $ PairV v1 v2)) σ None (Val v2) σ [] + | CaseLS v e1 e2 σ : + head_step (Case (Val $ InjLV v) e1 e2) σ None (App e1 (Val v)) σ [] + | CaseRS v e1 e2 σ : + head_step (Case (Val $ InjRV v) e1 e2) σ None (App e2 (Val v)) σ [] + | ForkS e σ : + head_step (Fork e) σ None (Val $ LitV LitUnit) σ [e] + | AllocS lbl v σ l : + σ !! l = None → + head_step (Alloc lbl (Val v)) σ None (Val $ LitV $ LitLoc l) (<[l:=v]>σ) [] + | LoadS l v σ : + σ !! l = Some v → + head_step (Load (Val $ LitV $ LitLoc l)) σ None (Val v) σ [] + | StoreS l v σ : + head_step (Store (Val $ LitV $ LitLoc l) (Val v)) σ + None (Val $ LitV $ LitUnit) (<[l:=v]>σ) + [] + | CasFailS l v1 v2 vl σ : + σ !! l = Some vl → vl ≠ v1 → + head_step (CAS (Val $ LitV $ LitLoc l) (Val v1) (Val v2)) σ + None (Val $ LitV $ LitBool false) σ + [] + | CasSucS l v1 v2 σ : + σ !! l = Some v1 → + head_step (CAS (Val $ LitV $ LitLoc l) (Val v1) (Val v2)) σ + None (Val $ LitV $ LitBool true) (<[l:=v2]>σ) + [] + | MakeAddressS s p σ : + head_step (MakeAddress + (Val $ LitV $ (LitString s)) + (Val $ LitV $ (LitInt p))) σ + None (Val $ LitV $ LitSocketAddress + (SocketAddressInet s (Z.to_pos p))) σ + [] + | GetAddressInfoS s σ : + head_step (GetAddressInfo + (Val $ LitV $ (LitSocketAddress s))) σ + None (Val $ PairV #(ip_of_address s) #(Zpos (port_of_address s))) σ []. + +(** Basic properties about the language *) +#[global] Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki). +Proof. destruct Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. + +Lemma fill_item_val Ki e : + is_Some (to_val (fill_item Ki e)) → is_Some (to_val e). +Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed. + +Lemma val_head_stuck e1 σ1 α e2 σ2 efs : + head_step e1 σ1 α e2 σ2 efs → to_val e1 = None. +Proof. destruct 1; naive_solver. Qed. + +Lemma head_ctx_step_val Ki e σ1 α e2 σ2 efs : + head_step (fill_item Ki e) σ1 α e2 σ2 efs → is_Some (to_val e). +Proof. destruct Ki; inversion_clear 1; simplify_option_eq; by eauto. Qed. + +Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 : + to_val e1 = None → to_val e2 = None → + fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2. +Proof. revert Ki1. induction Ki2, Ki1; naive_solver eauto with f_equal. Qed. + +Lemma alloc_fresh lbl v σ : + let l := fresh (dom σ) in + head_step (Alloc lbl (Val v)) σ None (Val $ LitV (LitLoc l)) (<[l:=v]>σ) []. +Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset loc)), is_fresh. Qed. + +Definition base_locale := nat. +Definition locale_of (c: list expr) (e : expr) := length c. + +Lemma locale_step e1 e2 t1 α σ1 σ2 efs: + head_step e1 σ1 α e2 σ2 efs -> + locale_of t1 e1 = locale_of t1 e2. +Proof. done. Qed. + +Lemma locale_fill e K t1: locale_of t1 (fill_item K e) = locale_of t1 e. +Proof. done. Qed. + +Lemma base_locale_injective tp0 e0 tp1 tp e : + (tp, e) ∈ prefixes_from (tp0 ++ [e0]) tp1 → + locale_of tp0 e0 ≠ locale_of tp e. +Proof. + intros (?&?&->&?)%prefixes_from_spec. + rewrite /locale_of !app_length /=. lia. +Qed. + +Definition base_config_label := unit. +Definition base_config_step (σ : state) (lbl : base_config_label) (σ' : state) := False. +(* Definition base_config_enabled (lbl : base_config_label) (σ : state) := False. *) + +Lemma base_mixin : EctxiLanguageMixin of_val to_val fill_item head_step (* base_config_step *) locale_of (* base_config_enabled *). +Proof. + split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck, + fill_item_val, fill_item_no_val_inj, head_ctx_step_val, locale_step, base_locale_injective. + { intros ??? H%Forall2_length. rewrite !prefixes_from_length // in H. } + (* { apply base_config_enabled_step. } *) +Qed. + +End base_lang. + +(** The network-aware layer of the language *) +Module aneris_lang. +Import base_lang. +Import RecordSetNotations. +Import ast. + +Record aneris_expr := mkExpr { expr_n : ip_address; + expr_e : expr }. + +Record aneris_val := mkVal { val_n : ip_address; + val_e : val }. + +#[global] Instance expr_inhabited : Inhabited aneris_expr := + populate {| expr_n := ""; + expr_e := Val inhabitant |}. +#[global] Instance val_inhabited : Inhabited aneris_val := + populate {| val_n := ""; + val_e := inhabitant |}. + +Definition aneris_fill_item Ki e := + {| expr_n := expr_n e; + expr_e := (base_lang.fill_item Ki (expr_e e)) |}. + +Definition aneris_of_val v : aneris_expr := + {| expr_n := val_n v; + expr_e := of_val (val_e v) |}. +Arguments aneris_of_val !v. + +Definition aneris_to_val e : option aneris_val := + (λ v, {| val_n := expr_n e; val_e := v |}) <$> base_lang.to_val (expr_e e). + +(** For each node of the network, its local state is defined as a triple + - a map [H] that maps pointers to values, + - a map [Sn] associating each socket handler with a tuple of a socket and + the receive buffer, and + - a map [P] tracking for each ip address the ports in use on the ip. *) +Definition heap := gmap loc val. +Definition sockets := gmap socket_handle (socket * list message). + +(** The global state of the system + - maps each node of the system to it local state (H, S, P) + - keeps track of all messages that has been sent throught the network *) +Record state := mkState { + state_heaps : gmap ip_address heap; + state_sockets : gmap ip_address sockets; + state_ms : message_multi_soup; +}. + +(* Definition for helping us decide wheter ports are free *) +Definition port_not_in_use (p : port) (sockets : gmap socket_handle (socket * list message)) : Prop := + ∀ sh skt a r, + sockets !! sh = Some (skt, r) → + saddress skt = Some a → + port_of_address a ≠ p. + +#[global] Instance etaState : Settable _ := + settable! mkState + . + +Definition option_socket_address_to_val (sa : option socket_address) := + match sa with + | None => InjLV (LitV LitUnit) + | Some addr => InjRV (LitV $ LitSocketAddress addr) + end. + +Implicit Types σ : state. +Implicit Types h : heap. +Implicit Types H : gmap ip_address heap. +Implicit Types S : gmap ip_address sockets. +Implicit Types Sn : sockets. +Implicit Types ps : gset port. +Implicit Types M : message_multi_soup. +Implicit Types R : list message. +Implicit Types A B : gset socket_address. +Implicit Types sis : gmap socket_address gname. +Implicit Types a : socket_address. +Implicit Types ip : ip_address. +Implicit Types sh : socket_handle. +Implicit Types skt : socket. + +Inductive aneris_action := +| Send : message → aneris_action +| Recv : socket_address → option message → aneris_action +. + +#[global] Instance aneris_action_eqdec : EqDecision aneris_action. +Proof. solve_decision. Defined. +#[global] Instance aneris_action_countable : Countable aneris_action. +Proof. Admitted. +#[global] Instance aneris_action_inhabited : Inhabited aneris_action. +Proof. Admitted. + +(* The network-aware reduction step relation for a given node *) +Inductive socket_step ip : + expr -> sockets -> message_multi_soup -> option aneris_action → + expr -> sockets -> message_multi_soup -> + Prop := +| NewSocketS sh Sn M : + (* The socket handle is fresh *) + Sn !! sh = None → + socket_step ip (NewSocket #()) Sn M None + (* reduces to *) + (Val $ LitV $ LitSocket sh) + (<[sh:=(mkSocket None true, [])]>Sn) M +| SocketBindS sh a skt Sn M : + (* The socket handle is bound to a socket. *) + Sn !! sh = Some (skt, []) → + (* The socket has no assigned address. *) + saddress skt = None → + (* The port is not in use *) + port_not_in_use (port_of_address a) Sn → + ip = ip_of_address a → + socket_step + ip + (SocketBind + (Val $ LitV $ LitSocket sh) + (Val $ LitV $ LitSocketAddress a)) + Sn M + None + (* reduces to *) + (Val $ LitV $ LitInt 0) + (<[sh:=((skt <| saddress := Some a |>), [])]>Sn) + M +| SendToS sh a mbody r skt Sn M f : + (* There is a socket that has been allocated for the handle *) + Sn !! sh = Some (skt, r) → + (* The socket has an assigned address *) + saddress skt = Some f → + let new_message := mkMessage f a mbody in + socket_step + ip + (SendTo (Val $ LitV $ LitSocket sh) + (Val $ LitV $ LitString mbody) + (Val $ LitV $ LitSocketAddress a)) + Sn M + (Some (Send new_message)) + (* reduces to *) + (Val $ LitV $ LitInt (String.length mbody)) + Sn ({[+ new_message +]} ⊎ M) +| SendToRepeatS sh a mbody r skt Sn M f : + (* There is a socket that has been allocated for the handle *) + Sn !! sh = Some (skt, r) → + (* The socket has an assigned address *) + saddress skt = Some f -> + let new_message := mkMessage f a mbody in + socket_step + ip + (SendToRepeat (Val $ LitV $ LitSocket sh) + (Val $ LitV $ LitString mbody) + (Val $ LitV $ LitSocketAddress a)) + Sn M + (Some (Send new_message)) + (* reduces to *) + (SendToRepeat (Val $ LitV $ LitSocket sh) + (Val $ LitV $ LitString mbody) + (Val $ LitV $ LitSocketAddress a)) + Sn ({[+ new_message +]} ⊎ M) +| ReceiveFromSomeS sh r skt a m Sn M : + (* The socket handle is bound to a socket with a message *) + Sn !! sh = Some (skt, r ++ [m]) → + (* The socket has an assigned address *) + saddress skt = Some a → + ip = ip_of_address a → + socket_step + ip + (ReceiveFrom (Val $ LitV $ LitSocket sh)) + Sn M (Some (Recv a (Some m))) + (* reduces to *) + (Val $ InjRV (PairV (LitV $ LitString (m_body m)) + (LitV $ LitSocketAddress (m_sender m)))) + (<[sh:=(skt, r)]>Sn) M +| ReceiveFromNoneS sh skt a Sn M : + (* The socket handle is bound to some socket + and there is nothing to receive + and the operation should not block forever + (a positive timeout was set). *) + Sn !! sh = Some (skt, []) → + sblock skt = false → + saddress skt = Some a → + ip = ip_of_address a → + socket_step + ip + (ReceiveFrom (Val $ LitV $ LitSocket sh)) Sn M (Some (Recv a None)) + (* reduces to *) + (Val $ InjLV (LitV LitUnit)) Sn M +| ReceiveFromBlockS sh skt a Sn M : + (* The socket handle is bound to some socket + and there is nothing to receive + and the operation should block + (either no timeout, or timeout 0.0 was set). *) + Sn !! sh = Some (skt, []) → + sblock skt = true → + saddress skt = Some a → + ip = ip_of_address a → + socket_step + ip + (ReceiveFrom (Val $ LitV $ LitSocket sh)) Sn M (Some (Recv a None)) + (* reduces to *) + (ReceiveFrom (Val $ LitV $ LitSocket sh)) Sn M +| SetReceiveTimeoutPositiveS sh skt a R Sn M m n : + Sn !! sh = Some (skt, R) → + (0 <= m ∧ 0 <= n ∧ 0 < (m+n)) → + saddress skt = Some a → + ip = ip_of_address a → + socket_step + ip + (SetReceiveTimeout + (Val $ LitV $ LitSocket sh) + (Val $ LitV $ LitInt m) + (Val $ LitV $ LitInt n)) Sn M None + (* reduces to *) + (Val $ (LitV LitUnit)) + (<[sh:=((skt<|sblock := false|>), R)]>Sn) M +| SetReceiveTimeoutZeroS sh skt a R Sn M : + Sn !! sh = Some (skt, R) → + saddress skt = Some a → + ip = ip_of_address a → + socket_step + ip + (SetReceiveTimeout + (Val $ LitV $ LitSocket sh) + (Val $ LitV $ LitInt 0) + (Val $ LitV $ LitInt 0)) Sn M None + (* reduces to *) + (Val $ (LitV LitUnit)) + (<[sh:=(skt<|sblock := true|>, R)]>Sn) M. + +Definition is_head_step_pure (e : expr) : bool := + match e with + | Alloc _ _ + | Load _ + | Store _ _ + | CAS _ _ _ + | NewSocket _ + | SocketBind _ _ + | SendTo _ _ _ + | ReceiveFrom _ + | Rand _ + | SetReceiveTimeout _ _ _ => false + | _ => true + end. + +Inductive head_step : aneris_expr → state → option aneris_action → + aneris_expr → state → list aneris_expr → Prop := +| LocalStepPureS n h e α e' ef σ + (is_pure : is_head_step_pure e = true) + (BaseStep : base_lang.head_step e h α e' h ef) + : head_step (mkExpr n e) σ + None + (mkExpr n e') σ + (map (mkExpr n) ef) +| LocalStepS n h h' e α e' ef σ + (is_pure : is_head_step_pure e = false) + (BaseStep : base_lang.head_step e h α e' h' ef) + : state_heaps σ !! n = Some h → + head_step (mkExpr n e ) σ + None + (mkExpr n e') (σ <| state_heaps := <[n:=h']>(state_heaps σ) |>) + (map (mkExpr n) ef) +| AssignNewIpStepS ip e σ : + ip ≠ "system" → + state_heaps σ !! ip = None → + state_sockets σ !! ip = None → + head_step (mkExpr "system" (Start (LitString ip) e)) σ + None + (mkExpr "system" (Val $ LitV $ LitUnit)) + {| + state_heaps := <[ip:=∅]>(state_heaps σ); + state_sockets := <[ip:=∅]>(state_sockets σ); + state_ms := state_ms σ |} + [mkExpr ip e] +| SocketStepS n e α e' Sn Sn' M' σ + (SocketStep : socket_step n + e Sn (state_ms σ) α + e' Sn' M') + : state_sockets σ !! n = Some Sn -> + head_step (mkExpr n e) σ + α + (mkExpr n e') + {| state_heaps := state_heaps σ; + state_sockets := <[n:=Sn']>(state_sockets σ); + state_ms := M'; |} + []. + +Lemma aneris_to_of_val v : aneris_to_val (aneris_of_val v) = Some v. +Proof. by destruct v. Qed. + +Lemma aneris_of_to_val e v : aneris_to_val e = Some v → aneris_of_val v = e. +Proof. + case e, v. cbv. rewrite -/(base_lang.to_val expr_e0). + case C: (base_lang.to_val expr_e0) =>//. move=> [<- <-]. + f_equal. exact: base_lang.of_to_val. +Qed. + +Lemma to_base_aneris_val e v: + aneris_to_val e = Some v → to_val (expr_e e) = Some (val_e v). +Proof. destruct e, v. cbv -[base_lang.to_val]. case_match; naive_solver. Qed. + +Lemma to_base_aneris_val' n e v: + aneris_to_val {| expr_n := n ; expr_e := e |} = + Some {| val_n := n ; val_e := v |} → + base_lang.to_val e = Some v. +Proof. cbv -[base_lang.to_val]. case_match; naive_solver. Qed. + +Lemma to_base_aneris_val_inv e v n: + base_lang.to_val e = Some v → aneris_to_val (mkExpr n e) = Some (mkVal n v). +Proof. cbv -[base_lang.to_val]. by move => ->. Qed. + +Lemma of_base_aneris_val e v: + aneris_of_val v = e → of_val (val_e v) = (expr_e e). +Proof. destruct e,v. by inversion 1. Qed. + +Lemma aneris_val_head_stuck σ1 e1 α σ2 e2 ef : + head_step e1 σ1 α e2 σ2 ef → aneris_to_val e1 = None. +Proof. + inversion 1; subst; last inversion SocketStep; subst; + try (cbv -[base_lang.to_val]; + by erewrite base_lang.val_head_stuck; last eassumption); + eauto. +Qed. + +Lemma fill_item_aneris_val Ki e : + is_Some (aneris_to_val (aneris_fill_item Ki e)) → is_Some (aneris_to_val e). +Proof. + move/fmap_is_Some/base_lang.fill_item_val => H. + exact/fmap_is_Some. +Qed. + +Lemma fill_item_no_aneris_val_inj Ki1 Ki2 e1 e2 : + aneris_to_val e1 = None → aneris_to_val e2 = None → + aneris_fill_item Ki1 e1 = aneris_fill_item Ki2 e2 → Ki1 = Ki2. +Proof. + move => /fmap_None H1 /fmap_None H2 [] H3 H4. + exact: base_lang.fill_item_no_val_inj H1 H2 H4. +Qed. + +Lemma head_ctx_step_aneris_val Ki e σ α e2 σ2 ef : + head_step (aneris_fill_item Ki e) σ α e2 σ2 ef → is_Some (aneris_to_val e). +Proof. + inversion 1; subst; last inversion SocketStep; subst; simplify_option_eq; + try + (apply/fmap_is_Some; exact: base_lang.head_ctx_step_val); + apply/fmap_is_Some. + all: destruct Ki; try (by eauto); + inversion H0; subst; by eauto. +Qed. + +#[global] Instance of_aneris_val_inj : Inj (=) (=) aneris_of_val. +Proof. by intros ?? Hv; apply (inj Some); rewrite -!aneris_to_of_val Hv. Qed. + +#[global] Instance fill_item_inj Ki : Inj (=) (=) (λ e, aneris_fill_item Ki e). +Proof. destruct Ki; move => [? ?] [? ?] [? ?]; + simplify_eq/=; auto with f_equal. Qed. + +Inductive aneris_config_label : Type := +| Deliver : message → aneris_config_label +| Duplicate : message → aneris_config_label +| Drop : message → aneris_config_label. + +#[global] Instance message_inhabited : Inhabited message. +Proof. Admitted. + +#[global] Instance aneris_config_label_eqdec : EqDecision aneris_config_label. +Proof. solve_decision. Defined. +#[global] Instance aneris_config_label_countable : Countable aneris_config_label. +Proof. Admitted. +#[global] Instance aneris_config_label_inhabited : Inhabited aneris_config_label := + populate (Deliver inhabitant). + +Inductive config_step : + state → aneris_config_label → state → Prop := +| MessageDeliverStep n σ Sn Sn' sh a skt r m: + m ∈ messages_to_receive_at_multi_soup a (state_ms σ) → + state_sockets σ !! n = Some Sn -> + Sn !! sh = Some (skt, r) → + Sn' = <[sh := (skt, m :: r)]>Sn → + saddress skt = Some a → + config_step σ (Deliver m) + {| state_heaps := state_heaps σ; + state_sockets := <[n:=Sn']>(state_sockets σ); + state_ms := state_ms σ ∖ {[+ m +]}; |} +| MessageDuplicateStep σ m : + m ∈ state_ms σ → + config_step σ (Duplicate m) + {| state_heaps := state_heaps σ; + state_sockets := state_sockets σ; + state_ms := state_ms σ ⊎ {[+ m +]}; |} +| MessageDropStep σ m : + m ∈ state_ms σ → + config_step σ (Drop m) + {| state_heaps := state_heaps σ; + state_sockets := state_sockets σ; + state_ms := state_ms σ ∖ {[+ m +]}; |}. + +Definition aneris_locale := (ip_address * nat)%type. +Definition locale_of (c: list aneris_expr) (e : aneris_expr) := (e.(expr_n), length $ (filter (λ e', e'.(expr_n) = e.(expr_n))) c). + +Lemma locale_step e1 e2 α t1 σ1 σ2 efs: + head_step e1 σ1 α e2 σ2 efs -> + locale_of t1 e1 = locale_of t1 e2. +Proof. + intros Hstep. + assert (expr_n e1 = expr_n e2) as Heq. + { inversion Hstep =>//. } + rewrite /locale_of. f_equal=>//. rewrite !Heq //. +Qed. + +Lemma locale_fill e K t1: locale_of t1 (aneris_fill_item K e) = locale_of t1 e. +Proof. done. Qed. + +Lemma filter_length_equiv {A B: Type} (P1: A -> Prop) (P2: B -> Prop) `{∀ x, Decision (P1 x)} `{∀ y, Decision (P2 y) } (l1: list A) (l2: list B): + (Forall2 (λ x1 x2, P1 x1 <-> P2 x2) l1 l2) -> + length (filter P1 l1) = length (filter P2 l2). +Proof. + revert l2. induction l1 as [|x1 l1]; intros l2 Hfa; + destruct l2 as [|x2 l2]; try by apply Forall2_length in Hfa. + rewrite !filter_cons. destruct (decide (P1 x1)). + - rewrite decide_True; last by inversion Hfa; simplify_eq; intuition. + rewrite /=. erewrite IHl1 =>//. by inversion Hfa. + - rewrite decide_False; last by inversion Hfa; simplify_eq; intuition. + rewrite /=. erewrite IHl1 =>//. by inversion Hfa. +Qed. + +Lemma filter_locales_equiv t0 t0' t1 t2 e: + Forall2 (λ '(t0, e) '(t'0, e'), locale_of t0 e = locale_of t'0 e') + (prefixes t0) (prefixes t0') -> + Forall2 (λ '(t0, e) '(t'0, e'), locale_of t0 e = locale_of t'0 e') + (prefixes_from t0 t1) (prefixes_from t0' t2) -> + Forall2 + (λ x1 x2 : aneris_expr, expr_n x1 = expr_n e ↔ expr_n x2 = expr_n e) t1 t2. +Proof. + revert t0 t0' e t1. induction t2 as [|e2 t2 IH]; intros t0 t0' e t1 H0 H; + destruct t1 as [|e1 t1]; try by apply Forall2_length in H. + simpl; constructor. + { inversion H as [|???? Heq]; simplify_eq. rewrite Heq //. } + inversion H; simplify_eq. + apply (IH (t0 ++ [e1]) (t0' ++ [e2])) =>//. + rewrite !prefixes_from_app. apply Forall2_app =>//. list_simplifier =>//. + constructor =>//. unfold locale_of; f_equal =>//. +Qed. + +#[global] Instance aneris_expr_eq_dec : EqDecision (aneris_expr). +Proof. intros ? ?; unfold Decision; solve_decision. Qed. +#[global] Instance aneris_state_eq_dec : EqDecision state. +Proof. intros ? ?; unfold Decision; solve_decision. Qed. + +Lemma aneris_locale_injective tp0 e0 tp1 tp e : + (tp, e) ∈ prefixes_from (tp0 ++ [e0]) tp1 → + locale_of tp0 e0 ≠ locale_of tp e. +Proof. + intros (?&?&->&?)%prefixes_from_spec. + rewrite /locale_of !filter_app !app_length /=. + intros contra. injection contra => Heq Heq'. + rewrite filter_cons_True //= Heq' in Heq. lia. +Qed. + +(* Needs to be refined for support multiple messages *) +Definition config_enabled (lbl : aneris_config_label) (σ : state) := σ.(state_ms) ≠ ∅. + +Lemma aneris_lang_mixin : + EctxiLanguageMixin aneris_of_val aneris_to_val aneris_fill_item head_step locale_of. +Proof. + split; apply _ || eauto using aneris_to_of_val, aneris_of_to_val, + aneris_val_head_stuck, fill_item_aneris_val, + fill_item_no_aneris_val_inj, head_ctx_step_aneris_val, + locale_step, locale_fill, aneris_locale_injective. + { intros t1 t2 e H . rewrite /locale_of. f_equal. + apply filter_length_equiv, (filter_locales_equiv [] []) =>//. } +Qed. + +#[global] Instance state_inhabited : Inhabited state. +Proof. + exact {| + inhabitant := + {| + state_heaps := ∅; + state_sockets := ∅; + state_ms := ∅; + |} + |}. +Qed. + +Lemma newsocket_fresh n Sn M : + let h := fresh (dom Sn) in + socket_step n + (NewSocket #()) Sn M + None + (Val $ LitV (LitSocket h)) + (<[h:=(mkSocket None true, [])]>Sn) M. +Proof. + intros; apply NewSocketS. + apply (not_elem_of_dom (D:=gset loc)), is_fresh. +Qed. + +End aneris_lang. + +Coercion of_val : val >-> expr. +Coercion aneris_lang.aneris_of_val : aneris_lang.aneris_val >-> aneris_lang.aneris_expr. +Notation LetCtx x e2 := (base_lang.AppRCtx (LamV x e2)) (only parsing). +Notation SeqCtx e2 := (LetCtx BAnon e2) (only parsing). + + +(* Prefer base names over ectx_language names. *) +Export base_lang. +Export aneris_lang. + +Global Arguments aneris_fill_item /_ _. +Global Arguments set {_ _} _ {_} /. diff --git a/fairneris/aneris_lang/lib/serialization/serialization_code.v b/fairneris/aneris_lang/lib/serialization/serialization_code.v new file mode 100644 index 0000000..c868226 --- /dev/null +++ b/fairneris/aneris_lang/lib/serialization/serialization_code.v @@ -0,0 +1,167 @@ +(* (* This file is automatically generated from the OCaml source file *) +(* /ml_sources/aneris_lang/lib/serialization/serialization_code.ml *) *) + +(* From fairneris.aneris_lang Require Import ast. *) +(* From fairneris.aneris_lang.lib Require Import list_code. *) +(* From fairneris.aneris_lang.lib Require Import network_util_code. *) + +(* Definition int_ser : val := λ: "v", i2s "v". *) + +(* Definition int_deser : val := λ: "v", unSOME (s2i "v"). *) + +(* Definition int_serializer := *) +(* {| *) +(* s_ser := int_ser; *) +(* s_deser := int_deser; *) +(* |}. *) + +(* Definition bool_ser : val := λ: "v", i2s ((if: "v" *) +(* then #1 *) +(* else #0)). *) + +(* Definition bool_deser : val := *) +(* λ: "v", *) +(* let: "i" := s2i "v" in *) +(* (if: "i" = (SOME #1) *) +(* then #true *) +(* else #false). *) + +(* Definition bool_serializer := *) +(* {| *) +(* s_ser := bool_ser; *) +(* s_deser := bool_deser; *) +(* |}. *) + +(* Definition unit_ser : val := λ: "_u", #"". *) + +(* Definition unit_deser : val := λ: "_s", #(). *) + +(* Definition unit_serializer := *) +(* {| *) +(* s_ser := unit_ser; *) +(* s_deser := unit_deser; *) +(* |}. *) + +(* Definition string_ser : val := λ: "x", "x". *) + +(* Definition string_deser : val := λ: "x", "x". *) + +(* Definition string_serializer := *) +(* {| *) +(* s_ser := string_ser; *) +(* s_deser := string_deser; *) +(* |}. *) + +(* Definition prod_ser (serA : val) (serB : val) : val := *) +(* λ: "v", *) +(* let: "s1" := serA (Fst "v") in *) +(* let: "s2" := serB (Snd "v") in *) +(* (i2s (strlen "s1")) ^^ (#"_" ^^ ("s1" ^^ "s2")). *) + +(* Definition prod_deser (deserA : val) (deserB : val) : val := *) +(* λ: "s", *) +(* match: FindFrom "s" #0 #"_" with *) +(* SOME "i" => *) +(* let: "len" := unSOME (s2i (Substring "s" #0 "i")) in *) +(* let: "s1" := Substring "s" ("i" + #1) "len" in *) +(* let: "s2" := Substring "s" (("i" + #1) + "len") ((strlen "s") - (("i" + #1) + "len")) in *) +(* let: "v1" := deserA "s1" in *) +(* let: "v2" := deserB "s2" in *) +(* ("v1", "v2") *) +(* | NONE => assert: #false *) +(* end. *) + +(* Definition prod_serializer (sA : serializer) (sB : serializer) := *) +(* {| *) +(* s_ser := prod_ser sA.(s_ser) sB.(s_ser); *) +(* s_deser := prod_deser sA.(s_deser) sB.(s_deser); *) +(* |}. *) + +(* Definition saddr_ser : val := *) +(* λ: "s", prod_ser string_ser int_ser (GetAddressInfo "s"). *) + +(* Definition saddr_deser : val := *) +(* λ: "s", *) +(* let: "ipp" := prod_deser string_deser int_deser "s" in *) +(* MakeAddress (Fst "ipp") (Snd "ipp"). *) + +(* Definition saddr_serializer := *) +(* {| *) +(* s_ser := saddr_ser; *) +(* s_deser := saddr_deser; *) +(* |}. *) + +(* Definition sum_ser (serA : val) (serB : val) : val := *) +(* λ: "v", *) +(* match: "v" with *) +(* InjL "x" => #"L" ^^ (#"_" ^^ (serA "x")) *) +(* | InjR "x" => #"R" ^^ (#"_" ^^ (serB "x")) *) +(* end. *) + +(* Definition sum_deser (deserA : val) (deserB : val) : val := *) +(* λ: "s", *) +(* let: "tag" := Substring "s" #0 #2 in *) +(* let: "rest" := Substring "s" #2 ((strlen "s") - #2) in *) +(* (if: "tag" = #"L_" *) +(* then InjL (deserA "rest") *) +(* else (if: "tag" = #"R_" *) +(* then InjR (deserB "rest") *) +(* else assert: #false)). *) + +(* Definition sum_serializer (sA : serializer) (sB : serializer) := *) +(* {| *) +(* s_ser := sum_ser sA.(s_ser) sB.(s_ser); *) +(* s_deser := sum_deser sA.(s_deser) sB.(s_deser); *) +(* |}. *) + +(* Definition option_ser (ser : val) : val := *) +(* λ: "v", *) +(* match: "v" with *) +(* NONE => #"L" ^^ (#"_" ^^ #"") *) +(* | SOME "x" => #"R" ^^ (#"_" ^^ (ser "x")) *) +(* end. *) + +(* Definition option_deser (deser : val) : val := *) +(* λ: "s", *) +(* let: "tag" := Substring "s" #0 #2 in *) +(* let: "rest" := Substring "s" #2 ((strlen "s") - #2) in *) +(* (if: "tag" = #"L_" *) +(* then NONE *) +(* else (if: "tag" = #"R_" *) +(* then SOME (deser "rest") *) +(* else assert: #false)). *) + +(* Definition option_serializer (s : serializer) := *) +(* {| *) +(* s_ser := option_ser s.(s_ser); *) +(* s_deser := option_deser s.(s_deser); *) +(* |}. *) + +(* Definition list_ser (ser : val) : val := *) +(* rec: "list_ser" "v" := *) +(* match: "v" with *) +(* SOME "a" => *) +(* let: "hd" := ser (Fst "a") in *) +(* let: "tl" := "list_ser" (Snd "a") in *) +(* (i2s (strlen "hd")) ^^ (#"_" ^^ ("hd" ^^ "tl")) *) +(* | NONE => #"" *) +(* end. *) + +(* Definition list_deser (deser : val) : val := *) +(* rec: "list_deser" "s" := *) +(* match: FindFrom "s" #0 #"_" with *) +(* SOME "i" => *) +(* let: "len" := unSOME (s2i (Substring "s" #0 "i")) in *) +(* let: "h" := Substring "s" ("i" + #1) "len" in *) +(* let: "t" := Substring "s" (("i" + #1) + "len") ((strlen "s") - (("i" + #1) + "len")) in *) +(* let: "hd" := deser "h" in *) +(* let: "tail" := "list_deser" "t" in *) +(* "hd" :: "tail" *) +(* | NONE => NONE *) +(* end. *) + +(* Definition list_serializer (s : serializer) := *) +(* {| *) +(* s_ser := list_ser s.(s_ser); *) +(* s_deser := list_deser s.(s_deser); *) +(* |}. *) diff --git a/fairneris/aneris_lang/lifting.v b/fairneris/aneris_lang/lifting.v new file mode 100644 index 0000000..a9eb9df --- /dev/null +++ b/fairneris/aneris_lang/lifting.v @@ -0,0 +1,1141 @@ +From RecordUpdate Require Import RecordSet. +From stdpp Require Import binders. +From iris.proofmode Require Import tactics. +From trillium.program_logic Require Import weakestpre lifting ectx_lifting atomic. +From fairneris Require Import fuel fair_resources. +From fairneris.aneris_lang Require Import network_model aneris_lang base_lang resources. +From fairneris.aneris_lang.state_interp Require Import + state_interp state_interp_events. +Set Default Proof Using "Type". + +Import uPred. +Import RecordSetNotations. + +(** The tactic [inv_head_step] performs inversion on hypotheses of the shape + [head_step]. The tactic will discharge head-reductions starting from values, + and simplifies hypothesis related to conversions from and to values, and + finite map operations. This tactic is slightly ad-hoc and tuned for proving + our lifting lemmas. *) +Ltac inv_head_step := + repeat + match goal with + | _ => progress simplify_map_eq/= (* simplify memory stuff *) + | H : aneris_to_val _ = Some _ |- _ => apply to_base_aneris_val in H + | H : base_lang.head_step ?e _ _ _ _ _ |- _ => + try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable + and can thus better be avoided. *) + inversion H; subst; clear H + | H : head_step ?e _ _ _ _ _ |- _ => + try (is_var e; fail 1); + inversion H; subst; clear H + | H: socket_step _ ?e _ _ _ _ _ _ |- _ => + try (is_var e; fail 1); + inversion H; subst; clear H + end. + +Local Ltac solve_exec_safe := + intros; + repeat match goal with + | H: _ ∧ _ |- _ => destruct H as [??] + end; + simplify_eq; + do 4 eexists; eapply (LocalStepPureS _ ∅); econstructor; eauto. +Local Ltac solve_exec_puredet := + simpl; intros; inv_head_step; + first (by repeat match goal with + | H: _ ∧ _ |- _ => destruct H as [??]; simplify_eq + | H : to_val _ = Some _ |- _ => + rewrite to_of_val in H; simplify_eq + end); + try by match goal with + | H : socket_step _ _ _ _ _ _ _ _ |- _ => + inversion H + end. +Local Ltac solve_pure_exec := + simplify_eq; rewrite /PureExec; intros; + apply nsteps_once, pure_head_step_pure_step; + constructor; [solve_exec_safe | solve_exec_puredet]. + +Local Hint Constructors head_step : core. +Local Hint Resolve alloc_fresh : core. +Local Hint Resolve to_of_val : core. + +#[global] Instance into_val_val n v : IntoVal (mkExpr n (Val v)) (mkVal n v). +Proof. done. Qed. +#[global] Instance as_val_val n v : AsVal (mkExpr n (Val v)). +Proof. by exists (mkVal n v). Qed. + +#[global] Instance into_val_base_val v : IntoVal (Val v) v. +Proof. done. Qed. +#[global] Instance as_val_base_val v : AsVal (Val v). +Proof. by exists v. Qed. + +Local Ltac solve_atomic := + apply strongly_atomic_atomic, ectx_language_atomic; + [inversion 1; inv_head_step; naive_solver + |apply ectxi_language_sub_redexes_are_values; intros [] **; inv_head_step; + rewrite /aneris_to_val /is_Some /=; eexists; by + match goal with + | H: _ = _ |- _ => rewrite -H + end + ]. + +Lemma aneris_base_fill K ip e : + mkExpr ip (fill (Λ := base_ectxi_lang) K e) = + fill (Λ := aneris_ectxi_lang) K (mkExpr ip e). +Proof. + revert e; induction K as [|k K IHK] using rev_ind; first done. + intros e. + rewrite !fill_app /= -IHK /=; done. +Qed. + +#[global] Instance aneris_pure_exec_fill + (K : list ectx_item) ip (φ : Prop) (n : nat) e1 e2 : + PureExec φ n (mkExpr ip e1) (mkExpr ip e2) → + @PureExec aneris_lang φ n + (mkExpr ip (@fill base_ectxi_lang K e1)) + (mkExpr ip (@fill base_ectxi_lang K e2)). +Proof. + intros. + rewrite !aneris_base_fill. + eapply pure_exec_ctx; first apply _; done. +Qed. + +#[global] Instance binop_atomic n s op v1 v2 : + Atomic s (mkExpr n (BinOp op (Val v1) (Val v2))). +Proof. solve_atomic. Qed. +#[global] Instance alloc_atomic lbl n s v : Atomic s (mkExpr n (Alloc lbl (Val v))). +Proof. solve_atomic. Qed. +#[global] Instance load_atomic n s v : Atomic s (mkExpr n (Load (Val v))). +Proof. solve_atomic. Qed. +#[global] Instance store_atomic n s v1 v2 : Atomic s (mkExpr n (Store (Val v1) (Val v2))). +Proof. solve_atomic. Qed. +#[global] Instance cmpxchg_atomic n s v0 v1 v2 : + Atomic s (mkExpr n (CAS (Val v0) (Val v1) (Val v2))). +Proof. solve_atomic. Qed. +#[global] Instance fork_atomic n s e : Atomic s (mkExpr n (Fork e)). +Proof. solve_atomic. Qed. +#[global] Instance skip_atomic n s : Atomic s (mkExpr n Skip). +Proof. solve_atomic. Qed. +#[global] Instance rec_atomic n s f x e: Atomic s (mkExpr n (Rec f x e)). +Proof. solve_atomic. Qed. +#[global] Instance injr_atomic n s v : Atomic s (mkExpr n (InjR (Val v))). +Proof. solve_atomic. Qed. +#[global] Instance injl_atomic n s v : Atomic s (mkExpr n (InjL (Val v))). +Proof. solve_atomic. Qed. +#[global] Instance fst_atomic n s v : Atomic s (mkExpr n (Fst (Val v))). +Proof. solve_atomic. Qed. +#[global] Instance snd_atomic n s v : Atomic s (mkExpr n (Snd (Val v))). +Proof. solve_atomic. Qed. + +#[global] Instance newsocket_atomic n s : + Atomic s (mkExpr n (NewSocket #())). +Proof. solve_atomic. Qed. +#[global] Instance socketbind_atomic n v0 v1 s : + Atomic s (mkExpr n (SocketBind (Val v0) (Val v1))). +Proof. solve_atomic. Qed. +#[global] Instance sendto_atomic n v0 v1 v2 s : + Atomic s (mkExpr n (SendTo (Val v0) (Val v1) (Val v2))). +Proof. solve_atomic. Qed. + +#[global] Instance setreceivetimeout_atomic n v0 v1 v2 s: + Atomic s (mkExpr n (SetReceiveTimeout (Val v0) (Val v1) (Val v2))). +Proof. solve_atomic. Qed. + +#[global] Instance receive_from_stutteringatomic n sh s : + StutteringAtomic s (mkExpr n (ReceiveFrom (Val $ LitV $ sh))). +Proof. + apply strongly_stutteringatomic_stutteringatomic, + ectx_language_stutteringatomic. + - inversion 1; inv_head_step; try naive_solver; []. + rewrite insert_id; last done. + match goal with + |- context [state_heaps ?st] => by destruct st; eauto + end. + - apply ectxi_language_sub_redexes_are_values; intros [] **; inv_head_step; + rewrite /aneris_to_val /is_Some /=; eexists; by + match goal with + | H: _ = _ |- _ => rewrite -H + end. +Qed. + +Class AsRecV (v : val _) (f x : binder) (erec : expr _) := + as_recv : v = RecV f x erec. +Global Hint Mode AsRecV ! - - - : typeclass_instances. +Definition AsRecV_recv f x e : AsRecV (RecV f x e) f x e := eq_refl. +Global Hint Extern 0 (AsRecV (RecV _ _ _) _ _ _) => + apply AsRecV_recv : typeclass_instances. + +#[global] Instance pure_rec n f x erec : + PureExec True 1 (mkExpr n (Rec f x erec)) (mkExpr n (Val $ RecV f x erec)). +Proof. solve_pure_exec. Qed. +#[global] Instance pure_pairc n v1 v2: + PureExec True 1 (mkExpr n (Pair (Val v1) (Val v2))) + (mkExpr n (Val $ PairV v1 v2)). +Proof. solve_pure_exec. Qed. +#[global] Instance pure_injlc n v : + PureExec True 1 (mkExpr n (InjL $ Val v)) (mkExpr n (Val $ InjLV v)). +Proof. solve_pure_exec. Qed. +#[global] Instance pure_injrc n v : + PureExec True 1 (mkExpr n (InjR $ Val v)) (mkExpr n (Val $ InjRV v)). +Proof. solve_pure_exec. Qed. + +#[global] Instance pure_beta n f x erec v1 v2 `{!AsRecV v1 f x erec} : + PureExec True 1 (mkExpr n (App (Val v1) (Val v2))) + (mkExpr n (subst' x v2 (subst' f v1 erec))). +Proof. unfold AsRecV in *. solve_pure_exec. Qed. + +#[global] Instance pure_unop n op v v' : + PureExec (un_op_eval op v = Some v') 1 (mkExpr n (UnOp op (Val v))) + (mkExpr n (of_val v')). +Proof. solve_pure_exec. Qed. + +#[global] Instance pure_binop n op v1 v2 v' : + PureExec (bin_op_eval op v1 v2 = Some v') 1 + (mkExpr n (BinOp op (Val v1) (Val v2))) (mkExpr n (of_val v')). +Proof. solve_pure_exec. Qed. + +#[global] Instance pure_if_true n e1 e2 : + PureExec True 1 (mkExpr n (If (Val $ LitV $ LitBool true) e1 e2)) (mkExpr n e1). +Proof. solve_pure_exec. Qed. + +#[global] Instance pure_if_false n e1 e2 : + PureExec True 1 (mkExpr n (If (Val $ LitV $ LitBool false) e1 e2)) + (mkExpr n e2). +Proof. solve_pure_exec. Qed. + +#[global] Instance pure_fst n v1 v2 : + PureExec True 1 (mkExpr n (Fst (PairV v1 v2))) (mkExpr n (Val v1)). +Proof. solve_pure_exec. Qed. + +#[global] Instance pure_snd n v1 v2 : + PureExec True 1 (mkExpr n (Snd (PairV v1 v2))) (mkExpr n (Val v2)). +Proof. solve_pure_exec. Qed. + +#[global] Instance pure_find_from n v0 v1 n1 v2 v' : + PureExec (index n1 v2 v0 = v' ∧ Z.of_nat n1 = v1) 1 + (mkExpr n (FindFrom (Val $ LitV $ LitString v0) + (Val $ LitV $ LitInt v1) + (Val $ LitV $ LitString v2))) + (mkExpr n (of_val (option_nat_to_val v'))). +Proof. solve_pure_exec. Qed. + +#[global] Instance pure_substring n v0 v1 n1 v2 n2 v' : + PureExec (substring n1 n2 v0 = v' ∧ Z.of_nat n1 = v1 ∧ Z.of_nat n2 = v2) 1 + (mkExpr + n (Substring + (LitV $ LitString v0) (LitV $ LitInt v1) (LitV $ LitInt v2))) + (mkExpr n (of_val (LitV $ LitString v'))). +Proof. solve_pure_exec. Qed. + +#[global] Instance pure_case_inl n v e1 e2 : + PureExec True 1 (mkExpr n (Case (Val $ InjLV v) e1 e2)) + (mkExpr n (App e1 (Val v))). +Proof. solve_pure_exec. Qed. + +#[global] Instance pure_case_inr n v e1 e2 : + PureExec True 1 (mkExpr n (Case (Val $ InjRV v) e1 e2)) + (mkExpr n (App e2 (Val v))). +Proof. solve_pure_exec. Qed. + +#[global] Instance pure_make_address n v1 v2 : + PureExec True 1 + (mkExpr n (MakeAddress (LitV (LitString v1)) (LitV (LitInt (v2))))) + (mkExpr + n (LitV (LitSocketAddress (SocketAddressInet v1 (Z.to_pos v2))))). +Proof. solve_pure_exec. Qed. + +#[global] Instance pure_get_address_info n ip p : + PureExec True 1 + (mkExpr n (GetAddressInfo (LitV (LitSocketAddress (SocketAddressInet ip p))))) + (mkExpr n (PairV #ip #(Zpos p))). +Proof. solve_pure_exec. Qed. + +Opaque aneris_state_interp. + +Notation state_interp_oos ζ α := (aneris_state_interp_opt (Some (ζ,α))). + +Definition sswp `{LM:LiveModel aneris_lang (joint_model M Net)} + `{!LiveModelEq LM} + `{!anerisG LM Σ} (s : stuckness) + E ζ (e1:aneris_expr) (Φ : aneris_expr → option (action aneris_lang) → iProp Σ) : iProp Σ := + ⌜TCEq (aneris_to_val e1) None⌝ ∧ + ∀ (extr : execution_trace aneris_lang) (atr : auxiliary_trace LM) K + (tp1 tp2:list aneris_expr) σ1, + ⌜valid_exec extr⌝ -∗ + ⌜locale_of tp1 (ectx_fill K e1) = ζ⌝ -∗ + ⌜trace_ends_in extr (tp1 ++ ectx_fill K e1 :: tp2, σ1)⌝ -∗ + state_interp extr atr ={E,∅}=∗ + ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ + ∀ α e2 σ2 efs, + ⌜prim_step e1 σ1 α e2 σ2 efs⌝ ={∅}▷=∗^(S $ trace_length extr) |={∅,E}=> + state_interp_oos ζ α + (trace_extend extr (inl (ζ,α)) (tp1 ++ ectx_fill K e2 :: tp2, σ2)) + atr ∗ Φ e2 α ∗ ⌜efs = []⌝. + +Definition MU `{LM:LiveModel aneris_lang (joint_model M Net)} + `{!LiveModelEq LM} + `{!anerisG LM Σ} E ζ α (P : iProp Σ) : iProp Σ := + ∀ (extr : execution_trace aneris_lang) (atr : auxiliary_trace LM), + state_interp_oos ζ α extr atr ={E}=∗ + ∃ δ2 ℓ, state_interp extr (trace_extend atr ℓ δ2) ∗ P. + +Lemma sswp_MU_wp_fupd `{LM:LiveModel aneris_lang (joint_model M Net)} + `{!LiveModelEq LM} + `{!anerisG LM Σ} s E E' ζ e Φ : + (|={E,E'}=> sswp s E' ζ e (λ e' α, MU E' ζ α ((|={E',E}=> WP e' @ s; ζ; E {{ Φ }}))))%I -∗ + WP e @ s; ζ; E {{ Φ }}. +Proof. + rewrite wp_unfold /wp_pre. + iIntros "Hsswp". + replace (language.to_val e) with (aneris_to_val e) by eauto. + destruct (aneris_to_val e) eqn:Heqn. + { iMod "Hsswp" as (Hval) "_". inversion Hval as [Heq]. by simplify_eq. } + iIntros (extr atr K tp1 tp2 σ1 Hvalid Hζ Hextr) "Hσ". + iMod "Hsswp" as "[_ Hsswp]". + iMod ("Hsswp" with "[//] [//] [//] Hσ") as (Hs) "Hsswp". + iModIntro. iSplit; [done|]. + iIntros (α e2 σ2 efs Hstep). + iDestruct ("Hsswp" with "[//]") as "Hsswp". + iApply (step_fupdN_wand with "Hsswp"). iIntros ">(Hσ & HMU & ->)". + iMod ("HMU" with "Hσ") as (??) "[Hσ Hwp]". iMod "Hwp". iModIntro. + iExists _, _. rewrite right_id_L. by iFrame. +Qed. + +Lemma sswp_wand `{LM:LiveModel aneris_lang (joint_model M Net)} + `{!LiveModelEq LM} + `{!anerisG LM Σ} s E ζ e + (Φ Ψ : aneris_expr → option (action aneris_lang) → iProp Σ) : + (∀ e α, Φ e α -∗ Ψ e α) -∗ sswp s E ζ e Φ -∗ sswp s E ζ e Ψ. +Proof. + rewrite /sswp. iIntros "HΦΨ [%Hval Hsswp]". + iSplit; [done|]. + iIntros (extr atr K tp1 tp2 σ1 Hvalid Hζ Hextr) "Hσ". + iMod ("Hsswp" with "[//] [//] [//] Hσ") as (Hs) "Hsswp". + iModIntro. iSplit; [done|]. + iIntros (α e2 σ2 efs Hstep). + iDestruct ("Hsswp" with "[//]") as "Hsswp". + iApply (step_fupdN_wand with "Hsswp"). iIntros ">(Hσ & HMU & ->)". + iFrame. iModIntro. iSplit; [|done]. by iApply "HΦΨ". +Qed. + +Lemma MU_wand `{LM:LiveModel aneris_lang (joint_model M Net)} + `{!LiveModelEq LM} + `{!anerisG LM Σ} E ζ α (P Q : iProp Σ) : + (P -∗ Q) -∗ MU E ζ α P -∗ MU E ζ α Q. +Proof. + rewrite /MU. iIntros "HPQ HMU". + iIntros (extr atr) "Hσ". + iMod ("HMU" with "Hσ") as (??) "[Hσ HP]". iModIntro. + iExists _, _. iFrame. by iApply "HPQ". +Qed. + +Lemma sswp_MU_wp `{LM:LiveModel aneris_lang (joint_model M Net)} + `{!LiveModelEq LM} + `{!anerisG LM Σ} s E ζ e (Φ : aneris_val → iProp Σ) : + sswp s E ζ e (λ e' α, MU E ζ α (WP e' @ s; ζ; E {{ Φ }})) -∗ + WP e @ s; ζ; E {{ Φ }}. +Proof. + iIntros "Hsswp". iApply sswp_MU_wp_fupd. iModIntro. + iApply (sswp_wand with "[] Hsswp"). + iIntros (??) "HMU". iApply (MU_wand with "[] HMU"). by iIntros "$ !>". +Qed. + +Section primitive_laws. + Context `{LM: LiveModel aneris_lang (joint_model Mod net_model)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + Implicit Types P Q : iProp Σ. + Implicit Types Φ : aneris_val → iProp Σ. + Implicit Types e : expr aneris_lang. + Implicit Types σ : base_lang.state. + Implicit Types M R T : message_soup. + Implicit Types m : message. + Implicit Types A B : gset socket_address. + Implicit Types a : socket_address. + Implicit Types ip : ip_address. + Implicit Types sh : socket_handle. + Implicit Types skt : socket. + Implicit Types mh : messages_history. + + Lemma mu_step_fuel ζ E fs P : + fs ≠ ∅ → ▷ ζ ↦M++ fs -∗ + (ζ ↦M fs -∗ P) -∗ + MU E ζ None P. + Proof. + iIntros (?) ">HfuelS HP". + iIntros (ex atr) "[Hσ Hm]". + iDestruct "Hm" as (ex' Hex' Hvalid Hstep) "Hmi". + iMod (update_fuel_step with "HfuelS [//] Hmi") as (δ2) "(%Hvse & Hfuel & Hmod)" =>//. + iIntros "!>". + iExists _, (Silent_step ζ None). iFrame. + iSplit; [by destruct Hex' as [ex'' ->]|]. + by iApply "HP". + Qed. + + Lemma mu_step_model `{!LiveModelEq LM} ζ ρ α (f1 : nat) fs fr s1 s2 E P : + lts_trans Mod s1 (ρ, α) s2 → + Mod.(usr_live_roles) s2 ⊆ Mod.(usr_live_roles) s1 → + ρ ∉ dom fs → + ▷ frag_model_is s1 -∗ + ▷ ζ ↦M ({[ρ:=f1]} ∪ fmap S fs) -∗ + ▷ frag_free_roles_are fr -∗ + (frag_model_is s2 -∗ + ζ ↦M ({[ρ:=(Mod.(usr_fl) s2)]} ∪ fs) -∗ + frag_free_roles_are fr -∗ P) -∗ + MU E ζ α P. + Proof. + iIntros (Htrans Hlive Hdom) ">Hst >Hfuel1 >Hfr HP". + iIntros (ex atr) "[Hσ Hm]". + iDestruct "Hm" as (ex' Hex' Hstep Hvalid) "Hmi". + iAssert (⌜(trace_last atr).(ls_data).(ls_under).1 = s1⌝)%I + with "[Hst Hmi]" as %Heq. + { iDestruct "Hmi" as (fm Hfmle Hfmdead Hfmtp) "[Hauth Hmi]". + by iDestruct (model_agree with "Hauth Hst") as %Heq. } + destruct α; last first. + { + iAssert (⌜config_net_match (trace_last ex) (trace_last atr).(ls_data).(ls_under).2⌝)%I as %Hmatch. + { iDestruct "Hmi" as (fm Hfmle Hfmdead Hfmtp) "[Hauth [Hmi %Hmatch]]". + destruct Hmatch. simpl in *. iPureIntro. + simpl. + inversion Hstep. subst. + inversion H7. subst. + inv_head_step. + rewrite H3 in H. simpl in *. rewrite H5. + admit. } + (* set (δ2 := (s2, trace_last atr).2). *) + iMod (update_model_step _ _ _ + ((trace_last atr).(ls_data).(ls_under).1, (trace_last atr).(ls_data).(ls_under).2) ((s2, (trace_last atr).(ls_data).(ls_under).2)) _ _ _ _ _ None + with "[$Hfuel1] [Hst] [//] [$Hmi]") as + (δ2 Hvse) "(Hfuel & Hst & Hmod)"; [|done|done|done|..]. + { simpl. rewrite Heq. apply Hlive. } + { simpl. done. } + { simpl. econstructor. rewrite Heq. done. } + { done. } + { simpl. rewrite Heq. done. } + iModIntro. + iExists δ2. + iExists (Take_step (ρ:fmrole (joint_model Mod _)) None ζ None). + iFrame. + destruct Hex' as [ex'' ->]. + simpl in *. iSplit; [done|]. + iApply ("HP" with "Hst Hfuel Hfr"). } + destruct a. + - admit. (* Send case: Construct new model state, where a message has been added, and prove config_net_match *) + - admit. (* Recv case: Construct new model state, depending on whether a message was received or not, and prove config_net_match *) + Admitted. + + Lemma has_fuels_decr E tid fs : + tid ↦M++ fs -∗ |~{E}~| tid ↦M fs. + Proof. + iIntros "Hf". rewrite weakestpre.pre_step_unseal. + iIntros (extr atr) "[Hσ [% Hm]]"=> /=. + iMod (model_state_interp_has_fuels_decr with "Hm Hf") as "[$ $]". by iFrame. + Qed. + + Lemma has_fuels_dealloc E tid fs ρ (δ:joint_model Mod net_model) : + ρ ∉ live_roles _ δ → frag_model_is δ.1 -∗ tid ↦M fs -∗ + |~{E}~| frag_model_is δ.1 ∗ tid ↦M (delete ρ fs). + Proof. + iIntros (Hnin) "Hst Hf". rewrite weakestpre.pre_step_unseal. + iIntros (extr atr) "[Hσ [% Hm]]". + iMod (model_state_interp_has_fuels_dealloc with "Hm Hst Hf") as "[Hm Hf]"; + [done|by iFrame]. + Qed. + + Lemma message_history_evolution_id x y mh : + mh = message_history_evolution x x y y mh. + Proof. + rewrite /message_history_evolution !gmultiset_difference_diag. + destruct mh. f_equal; set_solver. + Qed. + + Lemma sswp_pure_step s E ζ (e1 e2 : aneris_expr) (Φ : Prop) (Ψ : aneris_expr → option (action aneris_lang) → iProp Σ) : + PureExec Φ 1 e1 e2 → Φ → ▷ (Ψ e2 None) -∗ + sswp s E ζ e1 Ψ. + Proof. + iIntros (Hpe HΦ) "HΨ". + assert (pure_step e1 e2) as Hps. + { specialize (Hpe HΦ). by apply nsteps_once_inv in Hpe. } + rewrite /sswp /=. + assert (aneris_to_val e1 = None) as ->. + { destruct Hps as [Hred _]. + specialize (Hred (mkState ∅ ∅ ∅)). + by eapply reducible_not_val. } + iSplit; [done|]. + iIntros (extr atr K tp1 tp2 σ1 Hvalid Htp1 Hex) "Hσ". + iMod fupd_mask_subseteq as "Hclose"; last iModIntro; [by set_solver|]. + iSplit. + { destruct s; [|done]. by destruct Hps as [Hred _]. } + iIntros (α e2' σ2 efs Hstep) "!>!>!>". + iDestruct "Hσ" as "[[Hσ Hauth] [%Hvalid' Hm]]". + iApply step_fupdN_intro; [done|]. iIntros "!>". + iMod (steps_auth_update _ (S (trace_length extr)) with "Hauth") + as "[Hauth _]"; [by eauto|]. + iMod "Hclose" as "_". iModIntro. destruct Hps as [H' Hstep']. + pose proof Hstep as Hstep''. + apply Hstep' in Hstep as [-> [-> [-> ->]]]. iFrame. + inv_head_step. + simpl. + iFrame. + iSplit; [|done]. + iSplitL "Hσ"; last first. + { simpl. + iExists extr. + iSplit. + { iPureIntro. simpl. by eexists _. } + rewrite /aneris_state_interp_δ. rewrite Hex. iFrame. + iSplit; [|done]. + iPureIntro. + eapply (locale_step_atomic _ _ _ _ _ _ _ []); try done. + { by rewrite right_id_L. } + apply fill_step. + done. } + iFrame. + simpl. + rewrite Hex. + rewrite -message_history_evolution_id. + done. + Qed. + + Lemma wp_alloc n s E ζ v (Φ : aneris_expr → option (action aneris_lang) → iProp Σ) : + ▷ is_node n -∗ + (∀ (l:loc), l ↦[n] v -∗ Φ (mkExpr n (Val $ LitV $ LitLoc l)) None) -∗ + sswp s E ζ (mkExpr n (Alloc None (Val v))) Φ. + Proof. + iIntros "Hn HΦ". + rewrite /sswp. + iSplit; [done|]. + iIntros (ex atr K tp1 tp2 σ Hexvalid Hlocale Hex) "([Hσ Hauth] & [% Hm])". + iMod "Hn". + rewrite (last_eq_trace_ends_in _ _ Hex). + iDestruct (is_node_heap_valid with "Hσ Hn") as (h) "%Hσ". + iApply fupd_mask_intro; [set_solver|]. iIntros "Hclose". + iSplitR; [iPureIntro; eauto|]. + { destruct s; [|done]. do 4 eexists. eapply head_prim_step. + eapply LocalStepS; eauto. } + iIntros (α v2 σ2 efs Hstep). + apply head_reducible_prim_step in Hstep; last first. + { do 4 eexists. eapply LocalStepS; eauto. } + pose proof (conj Hstep I) as Hstep'. + inv_head_step. + destruct Hstep' as [Hstep' _]. + iApply step_fupdN_intro; [done|]. + iIntros "!>!>". + iMod (aneris_state_interp_alloc_heap _ _ _ l with "Hn Hσ") + as "[Hσ Hl]"; [done..|]. + iModIntro. iIntros "!>". + iMod (steps_auth_update _ (S (trace_length ex)) with "Hauth") + as "[Hauth _]"; [by eauto|]. + iMod "Hclose" as "_". + iModIntro. iFrame. simpl. + rewrite (last_eq_trace_ends_in _ _ Hex). simpl. + rewrite -message_history_evolution_id; iFrame. + iSplitL "Hm". + { iExists ex. + iSplit. + { iPureIntro. simpl. by eexists _. } + rewrite /aneris_state_interp_δ. rewrite Hex. iFrame. + iSplit; [|done]. + iPureIntro. + eapply (locale_step_atomic _ _ _ _ _ _ _ []); try done. + { by rewrite right_id_L. } + apply fill_step. + eapply head_prim_step. simpl. done. } + iSplit; [|done]. by iApply "HΦ". + Qed. + + Lemma wp_load n s E ζ l q v (Φ : aneris_expr → option (action aneris_lang) → iProp Σ) : + ▷ l ↦[n]{q} v -∗ + ▷ (l ↦[n]{q} v -∗ Φ (mkExpr n v) None) -∗ + sswp s E ζ (mkExpr n (Load (Val $ LitV $ LitLoc l))) Φ. + Proof. + iIntros "Hl HΦ". + rewrite /sswp. + iSplit; [done|]. + iIntros (ex atr K tp1 tp2 σ Hexvalid Hlocale Hex) "([Hσ Hauth] & [% Hm])". + rewrite (last_eq_trace_ends_in _ _ Hex). + iDestruct (aneris_state_interp_heap_valid with "Hσ Hl") as (h') "#>[%Hσ %Hl]". + simpl in *. + iApply fupd_mask_intro; [set_solver|]. iIntros "Hclose". + iSplitR; [iPureIntro; eauto|]. + { destruct s; [|done]. do 4 eexists. eapply head_prim_step. + eapply LocalStepS; eauto. by constructor. } + iIntros (α v2 σ2 efs Hstep). + apply head_reducible_prim_step in Hstep; last first. + { do 4 eexists. eapply LocalStepS; eauto. by constructor. } + pose proof (conj Hstep I) as Hstep'. + inv_head_step. + destruct Hstep' as [Hstep' _]. + iApply step_fupdN_intro; [done|]. + iIntros "!>!>". + iModIntro. iIntros "!>". + iMod (steps_auth_update _ (S (trace_length ex)) with "Hauth") + as "[Hauth _]"; [by eauto|]. + iMod "Hclose" as "_". + iModIntro. iFrame. simpl. + rewrite (last_eq_trace_ends_in _ _ Hex). simpl. + rewrite -message_history_evolution_id; iFrame. + rewrite insert_id //; iFrame. + rewrite insert_id in Hstep'=> //. + iSplitL "Hm". + { iExists ex. + iSplit. + { iPureIntro. simpl. by eexists _. } + rewrite /aneris_state_interp_δ. rewrite Hex. iFrame. + iSplit; [|done]. + iPureIntro. + eapply (locale_step_atomic _ _ _ _ _ _ _ []); try done. + { by rewrite right_id_L. } + apply fill_step. + eapply head_prim_step. simpl. done. } + iSplit; [|done]. by iApply "HΦ". + Qed. + + Lemma wp_store n s E ζ l v1 v2 (Φ : aneris_expr → option (action aneris_lang) → iProp Σ) : + ▷ l ↦[n] v1 -∗ + ▷ (l ↦[n] v2 -∗ Φ (mkExpr n #()) None) -∗ + sswp s E ζ (mkExpr n (Store #l (Val v2))) Φ. + Proof. + iIntros "Hl HΦ". + rewrite /sswp. + iSplit; [done|]. + iIntros (ex atr K tp1 tp2 σ Hexvalid Hlocale Hex) "([Hσ Hauth] & [% Hm])". + rewrite (last_eq_trace_ends_in _ _ Hex). + iDestruct (aneris_state_interp_heap_valid with "Hσ Hl") as (h') "#>[%Hσ %Hl]". + simpl in *. + iApply fupd_mask_intro; [set_solver|]. iIntros "Hclose". + iSplitR; [iPureIntro; eauto|]. + { destruct s; [|done]. do 4 eexists. eapply head_prim_step. + eapply LocalStepS; eauto. by constructor. } + iIntros (α w σ2 efs Hstep). + apply head_reducible_prim_step in Hstep; last first. + { do 4 eexists. eapply LocalStepS; eauto. by constructor. } + pose proof (conj Hstep I) as Hstep'. + inv_head_step. + destruct Hstep' as [Hstep' _]. + iApply step_fupdN_intro; [done|]. + iIntros "!>!>". + iModIntro. iIntros "!>". + iMod (aneris_state_interp_heap_update with "[$Hσ $Hl]") as "[Hσ Hl]"; + [done|]. + iMod (steps_auth_update _ (S (trace_length ex)) with "Hauth") + as "[Hauth _]"; [by eauto|]. + iMod "Hclose" as "_". + iModIntro. iFrame. simpl. + rewrite (last_eq_trace_ends_in _ _ Hex). simpl. + rewrite -message_history_evolution_id; iFrame. + iSplitL "Hm". + { iExists ex. + iSplit. + { iPureIntro. simpl. by eexists _. } + rewrite /aneris_state_interp_δ. rewrite Hex. iFrame. + iSplit; [|done]. + iPureIntro. + eapply (locale_step_atomic _ _ _ _ _ _ _ []); try done. + { by rewrite right_id_L. } + apply fill_step. + eapply head_prim_step. simpl. done. } + iSplit; [|done]. by iApply "HΦ". + Qed. + + Lemma wp_new_socket ip s E ζ (Φ : aneris_expr → option (action aneris_lang) → iProp Σ) : + ▷ is_node ip -∗ + (∀ sh, sh ↪[ip] (mkSocket None true) -∗ Φ (mkVal ip (LitV (LitSocket sh))) None) -∗ + sswp s E ζ (mkExpr ip (NewSocket #())) Φ. + Proof. + iIntros "Hn HΦ". + rewrite /sswp. + iSplit; [done|]. + iIntros (ex atr K tp1 tp2 σ Hexvalid Hlocale Hex) "([Hσ Hauth] & [% Hm])". + iMod "Hn". + rewrite (last_eq_trace_ends_in _ _ Hex). + iDestruct (is_node_valid_sockets with "Hσ Hn") as (?) "%". + iApply fupd_mask_intro; [set_solver|]. iIntros "Hclose". + iSplitR; [iPureIntro; eauto|]. + { destruct s; [|done]. do 4 eexists. eapply head_prim_step. + eapply SocketStepS; eauto. + apply newsocket_fresh. } + iIntros (α v2 σ2 efs Hstep). + apply head_reducible_prim_step in Hstep; last first. + { do 4 eexists. eapply SocketStepS; eauto. + apply newsocket_fresh. } + pose proof (conj Hstep I) as Hstep'. + inv_head_step. + destruct Hstep' as [Hstep' _]. + iApply step_fupdN_intro; [done|]. + iIntros "!>!>". + set (sock := {| saddress := None; + sblock := true |}). + iMod (aneris_state_interp_alloc_socket sock with "Hn Hσ") + as "[Hσ Hsh]"; try done. + iModIntro. iIntros "!>". + iMod (steps_auth_update _ (S (trace_length ex)) with "Hauth") + as "[Hauth _]"; [by eauto|]. + iMod "Hclose" as "_". + iModIntro. iFrame. simpl. + rewrite (last_eq_trace_ends_in _ _ Hex). simpl. + rewrite -message_history_evolution_new_socket; [|done|done]. + iFrame. + iSplitL "Hm". + { iExists ex. + iSplit. + { iPureIntro. simpl. by eexists _. } + rewrite /aneris_state_interp_δ. rewrite Hex. iFrame. + iSplit; [|done]. + iPureIntro. + eapply (locale_step_atomic _ _ _ _ _ _ _ []); try done. + { by rewrite right_id_L. } + apply fill_step. + eapply head_prim_step. simpl. done. } + iSplit; [|done]. by iApply "HΦ". + Qed. + + (* Lemma wp_socketbind A E ζ sh skt k a : *) + (* saddress skt = None → *) + (* {{{ ▷ free_ports (ip_of_address a) {[port_of_address a]} ∗ *) + (* ▷ sh ↪[ip_of_address a] skt }}} *) + (* (mkExpr (ip_of_address a) *) + (* (SocketBind (Val $ LitV $ LitSocket sh) *) + (* (Val $ LitV $ LitSocketAddress a))) @ k; ζ; E *) + (* {{{ RET (mkVal (ip_of_address a) #0); *) + (* sh ↪[ip_of_address a] (skt<| saddress := Some a |>) }}}. *) + + Lemma wp_socketbind s E ζ sh skt a (Φ : aneris_expr → option (action aneris_lang) → iProp Σ) : + saddress skt = None → + ▷ free_ports (ip_of_address a) {[port_of_address a]} -∗ + ▷ sh ↪[ip_of_address a] skt -∗ + (sh ↪[ip_of_address a] (skt<| saddress := Some a |>) -∗ Φ (mkVal (ip_of_address a) #0) None) -∗ + sswp s E ζ (mkExpr (ip_of_address a) + (SocketBind (Val $ LitV $ LitSocket sh) + (Val $ LitV $ LitSocketAddress a))) Φ. + Proof. + iIntros (?) "Hp Hsh HΦ". + rewrite /sswp. + iSplit; [done|]. + iIntros (ex atr K tp1 tp2 σ Hexvalid Hlocale Hex) "([Hσ Hauth] & [% Hm])". + iMod "Hp". + iMod "Hsh". + rewrite (last_eq_trace_ends_in _ _ Hex). + iDestruct (aneris_state_interp_socket_valid with "Hσ Hsh") + as (Sn r) "[%HSn (%Hr & %Hreset)]". + iDestruct (aneris_state_interp_free_ports_valid with "Hσ Hp") as "%HP". + { apply HSn. } + iApply fupd_mask_intro; [set_solver|]. iIntros "Hclose". + iSplitR; [iPureIntro; eauto|]. + { destruct s; [|done]. do 4 eexists. eapply head_prim_step. + eapply SocketStepS; eauto. + econstructor; naive_solver. } + iIntros (α v2 σ2 efs Hstep). + apply head_reducible_prim_step in Hstep; last first. + { do 4 eexists. eapply SocketStepS; eauto. + econstructor; naive_solver. } + pose proof (conj Hstep I) as Hstep'. + inv_head_step. + destruct Hstep' as [Hstep' _]. + iApply step_fupdN_intro; [done|]. + iIntros "!>!>". + iMod (aneris_state_interp_socketbind with "Hσ Hsh Hp") + as "(Hσ & Hsh)"; [set_solver..|]. + iModIntro. iIntros "!>". + iMod (steps_auth_update _ (S (trace_length ex)) with "Hauth") + as "[Hauth _]"; [by eauto|]. + iMod "Hclose" as "_". + iModIntro. iFrame. simpl. + rewrite (last_eq_trace_ends_in _ _ Hex). simpl. + rewrite -message_history_evolution_socketbind; [|done|done]. + iFrame. + iSplitL "Hm". + { iExists ex. + iSplit. + { iPureIntro. simpl. by eexists _. } + rewrite /aneris_state_interp_δ. rewrite Hex. iFrame. + iSplit; [|done]. + iPureIntro. + eapply (locale_step_atomic _ _ _ _ _ _ _ []); try done. + { by rewrite right_id_L. } + apply fill_step. + eapply head_prim_step. simpl. done. } + iSplit; [|done]. by iApply "HΦ". + Qed. + + Lemma wp_rcvtimeo_block s E ζ sh skt a + (Φ : aneris_expr → option (action aneris_lang) → iProp Σ) : + let ip := ip_of_address a in + saddress skt = Some a → + ▷ sh ↪[ip] skt -∗ + (sh ↪[ip] skt<|sblock := true|> -∗ Φ (mkVal ip #()) None) -∗ + sswp s E ζ (mkExpr ip (SetReceiveTimeout + (Val $ LitV $ LitSocket sh) + (Val $ LitV $ LitInt 0) + (Val $ LitV $ LitInt 0))) Φ. + Proof. + iIntros (??) "Hsh HΦ". + rewrite /sswp. + iSplit; [done|]. + iIntros (ex atr K tp1 tp2 σ Hexvalid Hlocale Hex) "([Hσ Hauth] & [% Hm])". + iMod "Hsh". + rewrite (last_eq_trace_ends_in _ _ Hex). + iDestruct (aneris_state_interp_socket_valid with "Hσ Hsh") + as (Sn r) "[%HSn (%Hr & %Hreset)]". + iApply fupd_mask_intro; [set_solver|]. iIntros "Hclose". + iSplitR; [iPureIntro; eauto|]. + { destruct s; [|done]. do 4 eexists. eapply head_prim_step. + eapply SocketStepS; eauto. + econstructor; naive_solver. } + iIntros (α v2 σ2 efs Hstep). + apply head_reducible_prim_step in Hstep; last first. + { do 4 eexists. eapply SocketStepS; eauto. + econstructor; naive_solver. } + pose proof (conj Hstep I) as Hstep'. + inv_head_step; first by lia. + destruct Hstep' as [Hstep' _]. + iApply step_fupdN_intro; [done|]. + iIntros "!>!>". + iMod (aneris_state_interp_sblock_update with "Hσ Hsh") as "(Hσ&Hsh)"; eauto. + iModIntro. iIntros "!>". + iMod (steps_auth_update _ (S (trace_length ex)) with "Hauth") + as "[Hauth _]"; [by eauto|]. + iMod "Hclose" as "_". + iModIntro. iFrame. simpl. + rewrite (last_eq_trace_ends_in _ _ Hex). simpl. + rewrite -message_history_evolution_update_sblock; [|done|done]. + iFrame. + iSplitL "Hm". + { iExists ex. + iSplit. + { iPureIntro. simpl. by eexists _. } + rewrite /aneris_state_interp_δ. rewrite Hex. iFrame. + iSplit; [|done]. + iPureIntro. + eapply (locale_step_atomic _ _ _ _ _ _ _ []); try done. + { by rewrite right_id_L. } + apply fill_step. + eapply head_prim_step. simpl. done. } + iSplit; [|done]. by iApply "HΦ". + Qed. + + Lemma wp_rcvtimeo_ublock s E ζ sh skt a n1 n2 + (Φ : aneris_expr → option (action aneris_lang) → iProp Σ) : + let ip := ip_of_address a in + saddress skt = Some a → + (0 ≤ n1 ∧ 0 <= n2 ∧ 0 < n1 + n2)%Z → + ▷ sh ↪[ip] skt -∗ + (sh ↪[ip] skt<|sblock := false|> -∗ Φ (mkVal ip #()) None) -∗ + sswp s E ζ (mkExpr ip (SetReceiveTimeout + (Val $ LitV $ LitSocket sh) + (Val $ LitV $ LitInt n1) + (Val $ LitV $ LitInt n2))) Φ. + Proof. + iIntros (???) "Hsh HΦ". + rewrite /sswp. + iSplit; [done|]. + iIntros (ex atr K tp1 tp2 σ Hexvalid Hlocale Hex) "([Hσ Hauth] & [% Hm])". + iMod "Hsh". + rewrite (last_eq_trace_ends_in _ _ Hex). + iDestruct (aneris_state_interp_socket_valid with "Hσ Hsh") + as (Sn r) "[%HSn (%Hr & %Hreset)]". + iApply fupd_mask_intro; [set_solver|]. iIntros "Hclose". + iSplitR; [iPureIntro; eauto|]. + { destruct s; [|done]. do 4 eexists. eapply head_prim_step. + eapply SocketStepS; eauto. + econstructor; naive_solver. } + iIntros (α v2 σ2 efs Hstep). + apply head_reducible_prim_step in Hstep; last first. + { do 4 eexists. eapply SocketStepS; eauto. + econstructor; naive_solver. } + pose proof (conj Hstep I) as Hstep'. + inv_head_step; last by lia. + destruct Hstep' as [Hstep' _]. + iApply step_fupdN_intro; [done|]. + iIntros "!>!>". + iMod (aneris_state_interp_sblock_update with "Hσ Hsh") as "(Hσ&Hsh)"; eauto. + iModIntro. iIntros "!>". + iMod (steps_auth_update _ (S (trace_length ex)) with "Hauth") + as "[Hauth _]"; [by eauto|]. + iMod "Hclose" as "_". + iModIntro. iFrame. simpl. + rewrite (last_eq_trace_ends_in _ _ Hex). simpl. + rewrite -message_history_evolution_update_sblock; [|done|done]. + iFrame. + iSplitL "Hm". + { iExists ex. + iSplit. + { iPureIntro. simpl. by eexists _. } + rewrite /aneris_state_interp_δ. rewrite Hex. iFrame. + iSplit; [|done]. + iPureIntro. + eapply (locale_step_atomic _ _ _ _ _ _ _ []); try done. + { by rewrite right_id_L. } + apply fill_step. + eapply head_prim_step. simpl. done. } + iSplit; [|done]. by iApply "HΦ". + Qed. + + Lemma wp_recv + (φ : socket_interp Σ) k saR E sh skt ζ R T + (Φ : (aneris_expr → option (action aneris_lang) → iProp Σ)) : + saddress skt = Some saR → + sblock skt = false → + ▷ sh ↪[ip_of_address saR] skt -∗ + ▷ saR ⤳ (R, T) -∗ + saR ⤇ φ -∗ + (∀ om r, + ((⌜r = NONEV⌝ ∗ ⌜om = Recv saR None⌝ ∗ + sh ↪[ip_of_address saR] skt ∗ saR ⤳ (R, T)) ∨ + (∃ msg, + ⌜r = SOMEV (PairV (LitV $ LitString (m_body msg)) + (LitV $ LitSocketAddress (m_sender msg)))⌝ ∗ + ⌜om = Recv saR (Some msg)⌝ ∗ + ⌜m_destination msg = saR⌝ ∗ + sh ↪[ip_of_address saR] skt ∗ + saR ⤳ ({[msg]} ∪ R, T) ∗ + (⌜msg ∉ R⌝ -∗ φ msg))) -∗ + Φ (mkVal (ip_of_address saR) r) (Some om)) -∗ + sswp k E ζ + (mkExpr (ip_of_address saR) + (ReceiveFrom (Val $ LitV $ LitSocket sh))) Φ. + Proof. + iIntros (Hskt Hblock) "Hsh Hrt #Hφ HΦ". + iAssert (▷ socket_address_group_own {[saR]})%I as "#HsaR". + { iDestruct "Hrt" as "[(%send & %recv & _ & _ & _ & $ & _) _]". } + iDestruct "Hrt" as "[Hrt Hown]". + rewrite /sswp. + iSplit; [done|]. + iIntros (ex atr K tp1 tp2 σ Hexvalid Hlocale Hex) "[[Hσ Hauth] [%Hvalid Hm]]". + iMod (steps_auth_update_S with "Hauth") as "Hauth". + iMod "Hsh". iMod "Hrt". + rewrite (last_eq_trace_ends_in _ _ Hex). + iDestruct (aneris_state_interp_network_sockets_coh_valid with "Hσ") as %Hcoh. + iDestruct (aneris_state_interp_socket_valid with "Hσ Hsh") + as (Sn r) "[%HSn (%Hr & %Hreset)]". + destruct (decide (r = [])) as [-> | Hneq]. + - iApply fupd_mask_intro; [set_solver|]. + iIntros "Hclose". + iSplitR. + { destruct k; [|done]. + iPureIntro; do 4 eexists. eapply head_prim_step. + eapply SocketStepS; eauto. + by eapply ReceiveFromNoneS. } + iIntros (α e2 σ2 efs Hstep). + apply head_reducible_prim_step in Hstep; last first. + { do 4 eexists. eapply SocketStepS; eauto. by econstructor. } + pose proof (conj Hstep I) as Hstep'. + inv_head_step. + { assert (length (r ++ [m]) = length ([] : list message)) as Hdone; first by f_equal. + rewrite app_length /= in Hdone. lia. } + 2: { assert (false = true) by by rewrite -Hblock. done. } + iIntros "!>!>". + iModIntro. + iApply step_fupdN_intro; [done|]. + destruct Hstep' as [Hstep' _]. + iIntros "!>". + iMod "Hclose". iModIntro. + simpl. + iSplitL "Hσ Hauth Hm". + { iFrame. + iSplitL "Hσ". + - simpl. + rewrite insert_id; [|done]. + rewrite (last_eq_trace_ends_in _ _ Hex). simpl. + rewrite -message_history_evolution_id. + iFrame. + - simpl. + iExists ex. + iSplit. + { iPureIntro. simpl. by eexists _. } + rewrite /aneris_state_interp_δ. rewrite Hex. iFrame. + iSplit; [|done]. + iPureIntro. + eapply (locale_step_atomic _ _ _ _ _ _ _ []); try done. + { by rewrite right_id_L. } + apply fill_step. + eapply head_prim_step. simpl. done. } + iSplit; [|done]. + iApply ("HΦ" with "[Hsh Hrt Hown]"). + iLeft. by iFrame. + - iApply fupd_mask_intro; [set_solver|]. + iIntros "Hclose". + apply last_is_Some in Hneq as [m Hneq]. + apply last_Some in Hneq as [? ->]. + iSplitR. + { destruct k; [|done]. + iPureIntro; do 4 eexists. eapply head_prim_step. + eapply SocketStepS; eauto. + by eapply ReceiveFromSomeS. } + iIntros (α e2 σ2 efs Hstep). + apply head_reducible_prim_step in Hstep; last first. + { do 4 eexists. eapply SocketStepS; eauto. + by eapply ReceiveFromSomeS. } + pose proof (conj Hstep I) as Hstep'. + inv_head_step. + 2: { assert (length (x ++ [m]) = length ([] : list message)) as Hdone; first by f_equal. + rewrite app_length /= in Hdone. lia. } + 2: { assert (false = true) by by rewrite -Hblock. done. } + iDestruct (messages_mapsto_observed with "Hrt") + as "[Hrt (%As & %Ar & _ & _ & #Hvalid & _)]". + simpl. + iMod "Hown". + iMod "HsaR". + iDestruct (aneris_state_interp_receive_some saR {[saR]} _ _ _ _ (Some (from_singleton φ)) + with "[] [] [$Hσ] [$Hsh] [$Hrt]") as (R' sagT) "(% & [%Hhst #Hin] & %Hhist & %HR & Hrt & Hrest)"; [try set_solver..|]. + { iFrame "HsaR". iPureIntro. set_solver. } + iMod "Hrest" as "(Hσ & Hsh & Ha)". + iModIntro. + simpl. + assert (m0 = m) as ->. + { by eapply app_inj_tail_iff. } + assert (r = x) as ->. + { by eapply app_inv_tail. } + destruct (decide (m ∈ R)) as [Hin|Hnin]. + + iDestruct "Hrt" as "[Hrt|Hrt]". + { iDestruct "Hrt" as "(%Hm & Hrt)". + specialize (Hm m Hin). + assert (false). + { apply Hm. apply message_group_equiv_refl. set_solver. set_solver. } + done. } + iIntros "!>!>". + iApply step_fupdN_intro; [done|]. + destruct Hstep' as [Hstep' _]. + iIntros "!>". + iMod "Hclose". iModIntro. + simpl. + iSplitL "Hσ Hauth Hm". + { iFrame. + iSplitL "Hσ". + - simpl. + simpl in *. + rewrite (last_eq_trace_ends_in _ _ Hex). simpl. + rewrite Hhist. iFrame. + - simpl. + iExists ex. + iSplit. + { iPureIntro. simpl. by eexists _. } + rewrite /aneris_state_interp_δ. rewrite Hex. iFrame. + iSplit; [|done]. + iPureIntro. + eapply (locale_step_atomic _ _ _ _ _ _ _ []); try done. + { by rewrite right_id_L. } + apply fill_step. + eapply head_prim_step. simpl. done. } + iSplit; [|done]. + iApply ("HΦ"). + iRight. + iExists m. + iSplit; [done|]. + iSplit; [done|]. + iFrame. + rewrite HR. iFrame. + simpl. replace ({[m]} ∪ R) with R by set_solver. + iFrame. iSplit; [done|]. + iIntros (Hnin). set_solver. + + iDestruct "Hrt" as "[Hrt|Hrt]"; last first. + { iDestruct "Hrt" as %Hm. + destruct Hm as [m' [Hmin Hmeq]]. + iAssert (⌜sagT = {[m_sender m']}⌝)%I as %->. + { + iDestruct (big_sepS_elem_of with "Hown") as "Hown_m"; [done|]. + destruct Hmeq as (Hm11 & Hm12 & _). + iApply (socket_address_group_own_agree with "Hin Hown_m"); + set_solver. + } + assert (m = m'). + { destruct m, m'. rewrite /message_group_equiv in Hmeq. + simpl in *. + destruct Hmeq as (Hm11 & Hm12 & Hm21 & Hm22 & <-). + (* destruct Hmeq as (<- & <- & <- & Hm1 & Hm2). *) + assert (m_sender = m_sender0) as <- by set_solver. + assert (m_destination = m_destination0) as <- by set_solver. + done. } + set_solver. + } + iDestruct "Hrt" as (Hall m' Hmeq) "Hrt". + iAssert (▷ socket_address_group_own {[m_sender m']})%I as "#>Hown'". + { iNext. iDestruct "Hrt" as "[$ Hrt]". } + iAssert (⌜m_sender m = m_sender m'⌝)%I as %Hsender. + { + destruct Hmeq as (Hm11 & Hm12 & _). + iDestruct (socket_address_group_own_agree with "Hin Hown'") + as %->; [set_solver.. |]. + iPureIntro. set_solver. } + assert (m = m') as <-. + { + destruct m. destruct m'. simpl in *. + destruct Hmeq as (Hm11 & Hm12 & Hm21 & Hm22 & Hprot). + repeat f_equiv; eauto. set_solver. } + iApply step_fupdN_intro; [done|]. + destruct Hstep' as [Hstep' _]. + iIntros "!>!>!>". + iMod "Hclose". iIntros "!>". + simpl. + iSplitL "Hσ Hauth Hm". + { iFrame. + iSplitL "Hσ". + - simpl. + simpl in *. + rewrite (last_eq_trace_ends_in _ _ Hex). simpl. + rewrite Hhist. iFrame. + - simpl. + iExists ex. + iSplit. + { iPureIntro. simpl. by eexists _. } + rewrite /aneris_state_interp_δ. rewrite Hex. iFrame. + iSplit; [|done]. + iPureIntro. + eapply (locale_step_atomic _ _ _ _ _ _ _ []); try done. + { by rewrite right_id_L. } + apply fill_step. + eapply head_prim_step. simpl. done. } + iSplit; [|done]. + iApply ("HΦ"). + iRight. + iExists m. + iSplit; [done|]. + iSplit; [done|]. + iFrame. + rewrite HR. iFrame. + simpl. + iSplit; [done|]. + iSplitL "Hown". + { iApply big_sepS_union; [set_solver|]. + iFrame. iApply big_sepS_singleton. eauto. } + iIntros "Hnin'". + iDestruct "Hrt" as "[??]". iFrame. + Qed. + + (* #[global] Instance aneris_lang_allows_stuttering : *) + (* AllowsStuttering (aneris_to_trace_model Mdl) Σ. *) + (* Proof. *) + (* refine ({| stuttering_label := () |}). *) + + (* iIntros (ex atr c δ ? ? Hval Hc Hδ) "(? & ? & ? & ? & Hauth)". *) + (* rewrite /state_interp /=. *) + (* rewrite (last_eq_trace_ends_in ex c) //=. *) + (* rewrite (last_eq_trace_ends_in atr δ) //=. *) + (* rewrite aneris_events_state_interp_same_tp; [| |done|done]; last first. *) + (* { eapply extend_valid_exec; eauto. } *) + (* iMod (steps_auth_update_S with "Hauth") as "Hauth". *) + (* iModIntro. *) + (* rewrite -message_history_evolution_id; iFrame. *) + (* iPureIntro; apply user_model_evolution_id. *) + (* Qed. *) + + (* #[global] Instance aneris_lang_allows_pure_step : *) + (* AllowsPureStep (aneris_to_trace_model Mdl) Σ. *) + (* Proof. *) + (* refine ({| pure_label := () |}). *) + + (* iIntros (ex atr tp tp' σ δ ? ? ? Hex Hδ) "(?&?&?&?&Hauth)". *) + (* rewrite /state_interp /=. *) + (* rewrite (last_eq_trace_ends_in ex (tp, σ)) //=. *) + (* rewrite (last_eq_trace_ends_in atr δ) //=. *) + (* rewrite aneris_events_state_interp_pure; [| |done|done]; last first. *) + (* { eapply extend_valid_exec; eauto. } *) + (* iMod (steps_auth_update_S with "Hauth") as "Hauth". *) + (* iModIntro. *) + (* rewrite -message_history_evolution_id; iFrame. *) + (* iPureIntro; apply user_model_evolution_id. *) + (* Qed. *) + +End primitive_laws. diff --git a/fairneris/aneris_lang/network.v b/fairneris/aneris_lang/network.v new file mode 100644 index 0000000..9ad0184 --- /dev/null +++ b/fairneris/aneris_lang/network.v @@ -0,0 +1,86 @@ +From iris.algebra Require Import auth agree gmap gset list. +From iris.base_logic Require Export gen_heap. +From iris.base_logic.lib Require Export own. +From stdpp Require Export decidable coPset gmultiset gmap mapset pmap sets. +From fairneris.prelude Require Import gmultiset. +From RecordUpdate Require Import RecordSet. +From fairneris.aneris_lang Require Import ast. + +Global Instance etaSocket : Settable _ := + settable! mkSocket . + +Definition socket_handle := positive. + +Global Instance socket_address_eq_dec : EqDecision socket_address. +Proof. solve_decision. Defined. + +Global Instance socket_eq_dec : EqDecision socket. +Proof. solve_decision. Qed. + +Global Program Instance socket_address_countable : Countable socket_address := + inj_countable (λ '(SocketAddressInet s p), (s, p)) + (λ '(s,p), Some (SocketAddressInet s p)) _. +Next Obligation. by intros []. Qed. + +Global Instance: Inhabited socket_address := populate (SocketAddressInet "" 1%positive). + +(** Ports in use on the client **) +Definition node_ports := gmap ip_address coPset. + +(** Messages *) +Definition message_body := string. + +Record message := mkMessage { + m_sender : socket_address; + m_destination : socket_address; + m_body : message_body; + }. + +Global Instance etaMessage : Settable _ := + settable! mkMessage . + +Global Instance message_decidable : EqDecision message. +Proof. solve_decision. Defined. + +Global Program Instance message_countable : Countable message := + inj_countable (λ '(mkMessage s d b), (s,d,b)) + (λ '(s, d, b), Some (mkMessage s d b)) _. +Next Obligation. by intros []. Qed. + +Lemma message_inv m1 m2 : + m_sender m1 = m_sender m2 → + m_destination m1 = m_destination m2 → + m_body m1 = m_body m2 → + m1 = m2. +Proof. + destruct m1 as [???], m2 as [???]. + move=> /= -> -> -> //. +Qed. + +Definition message_soup := gset message. + +Global Instance message_soup_decidable : EqDecision message_soup. +Proof. solve_decision. Defined. + +Global Instance message_soup_countable : Countable message_soup. +Proof. apply _. Qed. + +Definition messages_to_receive_at (sa : socket_address) (M : message_soup) := + filter (λ (m : message), m_destination m = sa) M. + +Definition messages_sent_from (sa : socket_address) (M : message_soup) := + filter (λ (m : message), m_sender m = sa) M. + +Definition message_multi_soup := gmultiset message. + +Global Instance message_multi_soup_decidable : EqDecision message_multi_soup. +Proof. solve_decision. Defined. + +Global Instance message_multi_soup_countable : Countable message_multi_soup. +Proof. apply _. Qed. + +Definition messages_to_receive_at_multi_soup (sa : socket_address) (M : message_multi_soup) := + filter (λ (m : message), m_destination m = sa) (gset_of_gmultiset M). + +Definition messages_sent_from_multi_soup (sa : socket_address) (M : message_multi_soup) := + filter (λ (m : message), m_sender m = sa) (gset_of_gmultiset M). diff --git a/fairneris/aneris_lang/network_model.v b/fairneris/aneris_lang/network_model.v new file mode 100644 index 0000000..f23a774 --- /dev/null +++ b/fairneris/aneris_lang/network_model.v @@ -0,0 +1,424 @@ +From trillium.prelude Require Export finitary quantifiers sigma classical_instances. +From fairneris Require Export trace_utils fairness env_model fuel ltl_lite env_model_project fair_resources. +From fairneris.aneris_lang Require Import ast network lang aneris_lang. + +Definition net_state : Set := + message_multi_soup * gmap socket_address (list message). + +Inductive net_trans : net_state → (action aneris_lang + config_label aneris_lang) → net_state → Prop := +| NetSend ms bs msg : + net_trans (ms, bs) (inl $ Send msg) (ms ⊎ {[+ msg +]}, bs) +| NetDuplicate ms bs msg : + msg ∈ ms → net_trans (ms, bs) (inr $ Duplicate msg) (ms ⊎ {[+ msg +]}, bs) +| NetDrop ms bs msg : + msg ∈ ms → + net_trans (ms, bs) (inr (Drop msg)) (ms ∖ {[+ msg +]}, bs) +| NetDeliver ms ms' bs msg : + msg ∈ ms → + bs !!! m_destination msg = ms' → + net_trans (ms, bs) (inr (Deliver msg)) (ms ∖ {[+ msg +]}, <[m_destination msg := msg::ms']>bs) +| NetRecvFail ms bs sa : + bs !!! sa = [] → + net_trans (ms, bs) (inl $ (Recv sa None)) (ms, bs) +| NetRecvSucc ms bs msg ms' sa : + bs !!! sa = ms'++[msg] → + net_trans (ms, bs) (inl $ Recv sa (Some msg)) (ms, <[sa := ms']>bs). + +Program Definition net_lts : Lts (action aneris_lang + config_label aneris_lang) := + {| + lts_state := net_state; + lts_trans := net_trans; + |}. + +Definition model_state_socket_coh + (skts : gmap ip_address sockets) + (bs : gmap socket_address (list message)) := + ∀ ip Sn sh skt sa ms, + skts !! ip = Some Sn → Sn !! sh = Some (skt,ms) → + saddress skt = Some sa → + bs !!! sa = ms. + +Definition config_net_match (c : cfg aneris_lang) (δ : net_state) := + state_ms c.2 = δ.1 ∧ model_state_socket_coh (state_sockets c.2) δ.2. + +Definition net_apply_trans (s: net_state) (l: action aneris_lang + config_label aneris_lang) : net_state := + let '(ms, bs) := s in + match l with + | inl (Send msg) => (ms ⊎ {[+ msg +]}, bs) + | inr (Duplicate msg) => (ms ⊎ {[+ msg +]}, bs) + | inr (Drop msg) => (ms ∖ {[+ msg +]}, bs) + | inr (Deliver msg) => + let ms' := bs !!! m_destination msg in + (ms ∖ {[+ msg +]}, <[m_destination msg := msg::ms']>bs) + | inl (Recv _ None) => (ms, bs) + | inl (Recv _ (Some msg)) => + let ms' := bs !!! m_destination msg in + (ms, <[m_destination msg := take (length ms' - 1) ms']>bs) + end. + +Program Definition net_model : EnvModel aneris_lang := + {| + env_lts := net_lts; + env_states_match := config_net_match; + env_apply_trans := net_apply_trans; + env_fairness _ := True; + |}. +Next Obligation. + (* Correctness of [net_apply_trans] *) +Admitted. +Next Obligation. + (* Correctness of [net_apply_trans] *) +Admitted. +Next Obligation. + (* Unlabeled steps don't change the network state *) +Admitted. + +Section fairness. + Context {M: UserModel aneris_lang}. + + Notation jmlabel := ((usr_role M * option (action aneris_lang)) + config_label aneris_lang)%type. + Notation jmtrace := (trace (joint_model M net_model) jmlabel). + + Definition send_filter msg : jmlabel → Prop := + λ l, ∃ ρ, l = inl $ (ρ, Some $ Send msg). + Instance send_filter_decision msg l : Decision (send_filter msg l). + Proof. apply make_decision. Qed. + + Definition deliver_filter msg : jmlabel → Prop := + λ l, l = inr $ Deliver msg. + Instance deliver_filter_decision msg l : Decision (deliver_filter msg l). + Proof. apply make_decision. Qed. + + Definition recv_filter msg : jmlabel → Prop := + λ l, ∃ ρ, l = inl $ (ρ, Some $ Recv (m_destination msg) (Some msg)). + Instance recv_filter_decision msg l : Decision (recv_filter msg l). + Proof. apply make_decision. Qed. + + Definition any_recv_filter sa : jmlabel → Prop := + λ l, ∃ ρ omsg, l = inl $ (ρ, Some $ Recv sa omsg). + Instance any_recv_filter_decision msg l : Decision (any_recv_filter msg l). + Proof. apply make_decision. Qed. + + Definition jm_network_fair_delivery_of msg : jmtrace → Prop := + □ (□◊ ℓ↓send_filter msg → ◊ ℓ↓ deliver_filter msg). + + Definition jm_network_fair_delivery (mtr : jmtrace) : Prop := + ∀ msg, jm_network_fair_delivery_of msg mtr. + + Definition jm_network_fair_send_receive_of msg : jmtrace → Prop := + □ (□◊ℓ↓send_filter msg → □◊ℓ↓ any_recv_filter (m_destination msg) → ◊ℓ↓ recv_filter msg). + + Definition jm_network_fair_send_receive (mtr : jmtrace) : Prop := + ∀ msg, jm_network_fair_send_receive_of msg mtr. + + + Definition usr_send_filter msg : lts_label M → Prop := + λ l, ∃ ρ, l = (ρ, Some $ Send msg). + Instance usr_send_filter_decision msg l : Decision (usr_send_filter msg l). + Proof. apply make_decision. Qed. + + Definition usr_recv_filter msg : lts_label M → Prop := + λ l, ∃ ρ, l = (ρ, Some $ Recv (m_destination msg) (Some msg)). + Instance usr_recv_filter_decision msg l : Decision (usr_recv_filter msg l). + Proof. apply make_decision. Qed. + + Definition usr_any_recv_filter sa : lts_label M → Prop := + λ l, ∃ ρ omsg, l = (ρ, Some $ Recv sa omsg). + Instance usr_any_recv_filter_decision msg l : Decision (usr_any_recv_filter msg l). + Proof. apply make_decision. Qed. + + Definition usr_network_fair_send_receive_of msg : lts_trace M → Prop := + □ (□◊ℓ↓ usr_send_filter msg → □◊ℓ↓ usr_any_recv_filter (m_destination msg) → ◊ℓ↓ usr_recv_filter msg). + + Definition usr_network_fair_send_receive (utr : lts_trace M) : Prop := + ∀ msg, usr_network_fair_send_receive_of msg utr. +End fairness. + +Instance aneris_good_lang : GoodLang aneris_lang. +Proof. Qed. + +Section fuel_fairness. + Context `{LM: LiveModel aneris_lang (joint_model M net_model)}. + Context `{!LiveModelEq LM}. + + Notation jmlabel := ((usr_role M * option (action aneris_lang)) + config_label aneris_lang)%type. + Notation jmtrace := (trace (joint_model M net_model) jmlabel). + + Notation fuel_trace := (trace LM LM.(lm_lbl)). + + Definition fuel_send_filter msg : LM.(lm_lbl) → Prop := + λ l, ∃ ρ ζ x, l = Take_step ρ (Some $ Send msg : fmaction (joint_model M _)) ζ x. + Instance fuel_send_filter_decision msg l : Decision (fuel_send_filter msg l). + Proof. apply make_decision. Qed. + + Definition fuel_deliver_filter msg : LM.(lm_lbl) → Prop := + λ l, ∃ x, l = Config_step (Deliver msg : fmconfig (joint_model M _)) x. + Instance fuel_deliver_filter_decision msg l : Decision (fuel_deliver_filter msg l). + Proof. apply make_decision. Qed. + + Definition fuel_network_fair_delivery_of msg : fuel_trace → Prop := + □ (□◊ ℓ↓fuel_send_filter msg → ◊ ℓ↓ fuel_deliver_filter msg). + + Definition fuel_network_fair_delivery (mtr : fuel_trace) : Prop := + ∀ msg, fuel_network_fair_delivery_of msg mtr. + + Lemma fuel_network_fairness_destutter : + fuel_se fuel_network_fair_delivery jm_network_fair_delivery. + Proof. + apply ltl_se_forall=> msg. + apply ltl_se_always, ltl_se_impl. + - apply ltl_se_always, ltl_se_eventually_now. + intros l. rewrite /fuel_send_filter /send_filter. split. + + intros (?&?&?). simplify_eq. naive_solver. + + intros (?&?&?&?). simplify_eq. destruct l=>//. simpl in *. simplify_eq. + eexists _, _, _. reflexivity. + - apply ltl_se_eventually_now. + intros l. rewrite /fuel_deliver_filter /deliver_filter. split; first naive_solver. + + intros (?&?&?). simplify_eq. destruct l=>//. simpl in *; simplify_eq. naive_solver. + Qed. +End fuel_fairness. + +Definition ex_send_filter msg : ex_label aneris_lang → Prop := + λ l, sum_map snd id l = inl $ Some $ Send msg. +Instance ex_send_filter_decision msg l : Decision (ex_send_filter msg l). +Proof. apply make_decision. Qed. + +Definition ex_deliver_filter msg : ex_label aneris_lang → Prop := + λ l, sum_map snd id l = inr $ Deliver msg. +Instance ex_deliver_filter_decision msg l : Decision (ex_deliver_filter msg l). +Proof. apply make_decision. Qed. +Definition ex_fair_network_of msg : extrace aneris_lang → Prop := + □ (□◊ ℓ↓ex_send_filter msg → ◊ ℓ↓ex_deliver_filter msg). + +Definition ex_fair_network (extr : extrace aneris_lang) : Prop := + ∀ msg, ex_fair_network_of msg extr. + +Section exec_fairness. + Context `{LM: LiveModel aneris_lang (joint_model M net_model)}. + Context `{!LiveModelEq LM}. + + Lemma exec_fuel_fairness: + exaux_tme (LM := LM) ex_fair_network fuel_network_fair_delivery. + Proof. + apply ltl_tme_forall=> msg. + apply ltl_tme_always, ltl_tme_impl. + - apply ltl_tme_always, ltl_tme_eventually, ltl_tme_now. + intros l1 l2 Hlm. split. + + destruct l1 as [[? [|]]|], l2 =>//=; try naive_solver. + rewrite /ex_send_filter /=. intros ?. simplify_eq. + destruct Hlm as (?&?&Hlm). apply actions_match_is_eq in Hlm. simplify_eq. + rewrite /fuel_send_filter. naive_solver. + + rewrite /fuel_send_filter /ex_send_filter. + destruct l1 as [[? ?]|], l2 =>//=; try naive_solver. + intros ?. simplify_eq. + destruct Hlm as (?&?&Hlm). apply actions_match_is_eq in Hlm. simplify_eq. + rewrite /fuel_send_filter. naive_solver. + - apply ltl_tme_eventually, ltl_tme_now. + intros l1 l2 Hlm. split. + + destruct l1 as [|[| |]], l2 =>//=; try naive_solver. + rewrite /ex_deliver_filter /=. intros ?. simplify_eq. + destruct Hlm as (?&Hcm). apply cfg_labels_match_is_eq in Hcm. simplify_eq. + rewrite /fuel_deliver_filter. naive_solver. + + rewrite /ex_deliver_filter /fuel_deliver_filter. intros (?&?). simplify_eq. + destruct l1 as [[?[|]]|] =>//=; try naive_solver. + destruct Hlm as [? Hlm]. + apply cfg_labels_match_is_eq in Hlm. simplify_eq. done. + Qed. +End exec_fairness. + +Section fairness. + Context {M: UserModel aneris_lang}. + + Notation jmlabel := ((usr_role M * option (action aneris_lang)) + config_label aneris_lang)%type. + Notation jmtrace := (trace (joint_model M net_model) jmlabel). + + Notation ltl_equiv P := (ltl_tme (S1 := joint_model M net_model) (L1 := jmlabel) + eq eq (λ _ _ _, True) (λ _ _ _, True) P P). + + Lemma trim_preserves_network_fairness (tr: jmtrace): + jm_network_fair_delivery tr → + jm_network_fair_delivery (trim_trace tr). + Proof. + rewrite /jm_network_fair_delivery /jm_network_fair_delivery_of. + intros Hf msg. specialize (Hf msg). + apply trace_alwaysI. intros tr' Hsuff. rewrite trace_impliesI. intros Hae. + have Hinf: infinite_trace tr'. + { by eapply trace_always_eventually_label_infinite. } + have Hinf': infinite_trace (trim_trace tr). + { eapply trace_suffix_of_infinite=>//. } + apply trim_trace_infinite in Hinf'. + rewrite trace_alwaysI in Hf. + eapply traces_match_suffix_of in Hsuff as (tr''&Hsuff'&?)=>//. + specialize (Hf _ Hsuff'). + rewrite trace_impliesI in Hf. + + have Hleq: ltl_equiv (□ ◊ ℓ↓ send_filter msg). + { apply ltl_tme_always, ltl_tme_eventually, ltl_tme_now. naive_solver. } + + ospecialize (Hf _); first by eapply Hleq=>//. + + have {}Hleq: ltl_equiv (◊ ℓ↓ deliver_filter msg). + { apply ltl_tme_eventually, ltl_tme_now. naive_solver. } + + eapply Hleq=>//. + Qed. +End fairness. + + +Section user_fairness. + Context {M: UserModel aneris_lang}. + + Notation jmlabel := ((usr_role M * option (action aneris_lang)) + config_label aneris_lang)%type. + Notation jmtrace := (trace (joint_model M net_model) jmlabel). + + Notation buffer_of sa ns := (ns.2.2 !!! sa). + + Local Lemma not_receive_buffer {msg rest s ℓ} {tr : jmtrace} : + let sa := m_destination msg in + (∃ pre : list message, buffer_of sa (trfirst (s -[ ℓ ]-> tr)) = pre ++ msg :: rest) → + jmtrace_valid (s -[ ℓ ]-> tr) → + trace_not (ℓ↓ any_recv_filter (m_destination msg)) (s -[ ℓ ]-> tr) → + ∃ pre : list message, buffer_of sa (trfirst tr) = pre ++ msg :: rest. + Proof. + intros sa Hbuf1 Hv Hnot. + apply trace_always_elim in Hv. simpl in Hv. + destruct (trfirst tr) eqn:Heq. rewrite Heq in Hv. + destruct Hbuf1 as (pre&Hbuf1). simpl in Hbuf1. + inversion Hv as [| AA BB CC DD Hnet FF|??????? Hnet]; simplify_eq. + - by exists pre. + - inversion Hnet; simplify_eq; try (by exists pre). + match goal with + | [_: ?msg0 ∈ _ |- _] => pose msg' := msg0 + end. + destruct (decide (m_destination msg' = sa)) as [Heq'|]. + + exists (msg'::pre). rewrite /= /msg' Heq' lookup_total_insert Hbuf1 //. + + exists pre. rewrite lookup_total_insert_ne //. + - inversion Hnet; simplify_eq; try (by exists pre). + match goal with + | [_: _ !!! ?sa0 = _ |- _] => pose sa' := sa0 + end. + destruct (decide (sa' = sa)) as [Heq'|]. + + exfalso. apply Hnot. rewrite /sa' in Heq'. rewrite /trace_label /pred_at /any_recv_filter Heq' /=. + naive_solver. + + exists pre. rewrite lookup_total_insert_ne //. + Qed. + + Proposition network_fairness_user (jmtr: jmtrace) : + jmtrace_valid jmtr → + jm_network_fair_delivery jmtr → + jm_network_fair_send_receive jmtr. + Proof. + intros Hv Hf msg. apply trace_alwaysI. intros tr' Hsuff. + apply trace_impliesI. intros Hae. + specialize (Hf msg). + rewrite /jm_network_fair_delivery_of trace_alwaysI in Hf. specialize (Hf _ Hsuff). + rewrite trace_impliesI in Hf. specialize (Hf Hae). clear Hae. + rewrite trace_impliesI. intros Hae. + apply trace_always_eventually_always_until in Hae. + + rewrite trace_eventuallyI in Hf. destruct Hf as (tr1&Hsuff1&Hdel). + destruct tr1 as [|s1 ℓ1 tr1]. + { rewrite /trace_label /pred_at //= in Hdel. } + pose sa := m_destination msg. + assert (∃ rest, (buffer_of sa (trfirst tr1) = msg::rest)) as [rest Hbuf1]. + { do 2 eapply trace_always_suffix_of in Hv=>//. + apply trace_always_elim in Hv. simpl in Hv. + destruct (trfirst tr1) eqn:Heq. rewrite Heq in Hv. + rewrite /trace_label /pred_at /deliver_filter /= in Hdel. + inversion Hv as [|???? Hnet|]; simplify_eq. + inversion Hnet; simplify_eq. + eexists. simpl. rewrite lookup_total_insert. done. } + + (* Execute unil the next message in the buffer is msg *) + assert (∃ tr2, trace_suffix_of tr2 tr1 ∧ ∃ pre, buffer_of sa (trfirst tr2) = pre ++ [msg]) + as [tr2 [Hsuff2 Hbuf2]]. + { have {Hv}: jmtrace_valid tr1. + { eapply trace_always_suffix_of =>//. eapply trace_suffix_of_trans; + [eapply trace_suffix_of_cons_l=>// | done]. } + have {Hbuf1}: ∃ pre, buffer_of sa (trfirst tr1) = pre ++ msg :: rest by exists nil. + have {Hae}: (□ trace_until (trace_not (ℓ↓ any_recv_filter (m_destination msg))) (ℓ↓ any_recv_filter (m_destination msg))) tr1. + { eapply trace_always_suffix_of =>//. eapply trace_suffix_of_cons_l=>//. } + clear Hdel Hsuff1. + revert tr1. induction rest as [|msg' rest IH] using rev_ind. + { intros tr1 Hae [pre Hbuf1] Hv. exists tr1; split; first apply trace_suffix_of_refl. exists pre=>//. } + intros tr1 Hae Hbuf Hv. + have Hrecvs := Hae. + apply trace_always_elim in Hrecvs. + induction Hrecvs as [tr Hnow|s ℓ tr Hnot Huntil IHuntil]. + - destruct tr as [s|s2 ℓ2 tr2] eqn:Htr. + { rewrite /trace_label /pred_at //= in Hnow. } + rewrite /trace_label /pred_at /= in Hnow. + destruct ℓ2 as [ℓ2|ℓ2]; last first. + { rewrite /any_recv_filter in Hnow. naive_solver. } + have Hv' := Hv. + rewrite /any_recv_filter in Hnow. destruct Hnow as (ρ&omsg&Heq). simplify_eq. + apply trace_always_elim in Hv. simpl in Hv. + destruct (trfirst tr2) eqn:Heq. rewrite Heq in Hv. + destruct Hbuf as (pre&Hbuf1). simpl in Hbuf1. + inversion Hv as [| | ??????? Hnet]; simplify_eq. + simpl in Hbuf1. + inversion Hnet; simplify_eq; + match goal with + | [H: _ !!! _ = _ |- _] => rewrite Hbuf1 in H + end. + + exfalso. destruct pre=>//. + + list_simplifier. + odestruct (IH tr2 _ _ _) as (tr3&Hsuff3&pre3&Heq3). + { eapply trace_always_suffix_of in Hae =>//. + apply trace_suffix_of_cons_r'. } + { exists pre. rewrite Heq /= lookup_total_insert //. } + { eapply trace_always_suffix_of=>//. apply trace_suffix_of_cons_r'. } + exists tr3. split=>//; last by exists pre3. + apply (trace_suffix_of_trans _ tr2)=>//. apply trace_suffix_of_cons_r, trace_suffix_of_refl. + - have Hbuf': ∃ pre : list message, buffer_of sa (trfirst tr) = pre ++ msg :: rest ++ [msg']. + { eapply not_receive_buffer=>//. } + odestruct (IHuntil _ Hbuf' _) as (tr2&Hsuff2&pre2&Hbuf2). + { eapply trace_always_suffix_of=>//. apply trace_suffix_of_cons_r'. } + { eapply trace_always_suffix_of=>//. apply trace_suffix_of_cons_r'. } + exists tr2. split=>//; last by exists pre2. apply (trace_suffix_of_trans _ tr)=>//. + apply trace_suffix_of_cons_r'. } + (* Now we need to execute until the next receive!. *) + rewrite trace_alwaysI in Hae. ospecialize (Hae tr2 _). + { apply (trace_suffix_of_trans _ tr1)=>//. by apply trace_suffix_of_cons_l in Hsuff1. } + have {Hv}: jmtrace_valid tr'. + { eapply trace_always_suffix_of; done. } + induction Hae as [tr2 Hnow |s ℓ tr2 Hnot Huntil IH]; intros Hv. + - have Hsuff3: trace_suffix_of tr2 tr'. + { eapply (trace_suffix_of_trans _ tr1)=>//. by eapply trace_suffix_of_cons_l. } + have {}Hv: jmtrace_valid tr2. + { eapply trace_always_suffix_of; done. } + apply trace_eventuallyI. exists tr2. split=>//. + destruct tr2 as [|s2 ℓ2 tr3] eqn:Heq; first done. + destruct Hnow as (ρ&omsg&Heq'). simplify_eq. + apply trace_always_elim in Hv. simpl in Hv. + destruct (trfirst tr3) eqn:Heq. rewrite Heq in Hv. + destruct Hbuf2 as (pre2&Hbuf2). simpl in Hbuf2. + inversion Hv as [| | ??????? Hnet]; simplify_eq. + inversion Hnet; simplify_eq. + + rewrite /sa /= in Hbuf2. rewrite -> Hbuf2 in *. destruct pre2=>//. + + rewrite /sa /= in Hbuf2. rewrite -> Hbuf2 in *. list_simplifier. + rewrite /trace_label /pred_at /recv_filter /=. naive_solver. + - opose proof (not_receive_buffer Hbuf2 _ Hnot). + { eapply trace_always_suffix_of; last done. + eapply (trace_suffix_of_trans _ tr1) =>//. + by eapply trace_suffix_of_cons_l. } + apply IH=>//. by eapply trace_suffix_of_cons_l. + Qed. + + Proposition network_fairness_project_usr (jmtr: jmtrace) (utr: lts_trace M) : + jmtrace_valid jmtr → + upto_stutter_env jmtr utr → + jm_network_fair_delivery jmtr → + usr_network_fair_send_receive utr. + Proof. + move=> Hval ? /network_fairness_user Hf // msg. specialize (Hf Hval msg). + have Hse //: ltl_se_env (M := M) (jm_network_fair_send_receive_of msg) (usr_network_fair_send_receive_of msg); + last by eapply Hse. + apply ltl_se_always, ltl_se_impl; last apply ltl_se_impl. + - apply ltl_se_always, ltl_se_eventually_now. rewrite /send_filter /usr_send_filter. + intros [?|?]; naive_solver. + - apply ltl_se_always, ltl_se_eventually_now. rewrite /any_recv_filter /usr_any_recv_filter. + intros [?|?]; naive_solver. + - apply ltl_se_eventually_now. rewrite /recv_filter /usr_recv_filter. intros [?|?]; naive_solver. + Qed. +End user_fairness. diff --git a/fairneris/aneris_lang/program_logic/aneris_weakestpre.v b/fairneris/aneris_lang/program_logic/aneris_weakestpre.v new file mode 100644 index 0000000..df132bc --- /dev/null +++ b/fairneris/aneris_lang/program_logic/aneris_weakestpre.v @@ -0,0 +1,691 @@ +From iris.proofmode Require Import base tactics classes. +From fairneris Require Export fairness env_model. +From trillium.program_logic Require Export weakestpre. +From fairneris Require Export retransmit_model. +From fairneris.lib Require Import singletons. +From fairneris.aneris_lang Require Export resources network base_lang. +From fairneris.aneris_lang.state_interp Require Import state_interp_def state_interp. +(* Maybe move the TC stuff out of lifting *) +From fairneris.aneris_lang Require Export lifting ast. + +Set Default Proof Using "Type". + +Definition aneris_wp_def `{LM: LiveModel aneris_lang (joint_model Mod Net)} `{!LiveModelEq LM} `{aG : !anerisG LM Σ} + (ip : ip_address) (E : coPset) + (e : ast.expr) (Φ : ast.val → iProp Σ) : iProp Σ := + (∀ tid, is_node ip -∗ + wp NotStuck E (ip, tid) (mkExpr ip e) (λ v, ∃ w, ⌜v = mkVal ip w⌝ ∗ Φ w))%I. + +Definition aneris_wp_aux `{LM: LiveModel aneris_lang (joint_model Mod Net)} `{!LiveModelEq LM} `{aG : !anerisG LM Σ} + : seal (@aneris_wp_def _ _ _ _ Σ _). +Proof. by eexists. Qed. +Definition aneris_wp `{LM: LiveModel aneris_lang (joint_model Mod Net)} `{!LiveModelEq LM} + `{aG : !anerisG LM Σ} := aneris_wp_aux.(unseal). +Definition aneris_wp_eq `{LM: LiveModel aneris_lang (joint_model Mod Net)} `{!LiveModelEq LM} +`{aG : !anerisG LM Σ} : aneris_wp = @aneris_wp_def _ _ _ _ Σ _ := + aneris_wp_aux.(seal_eq). + +Notation "'WP' e '@[' ip ] E {{ Φ } }" := (aneris_wp ip E e%E Φ) + (at level 20, e, Φ at level 200, + format "'WP' e '@[' ip ] E {{ Φ } }") : bi_scope. +Notation "'WP' e '@[' ip ] {{ Φ } }" := (aneris_wp ip ⊤ e%E Φ) + (at level 20, e, Φ at level 200, + format "'WP' e '@[' ip ] {{ Φ } }") : bi_scope. + +Notation "'WP' e '@[' ip ] E {{ v , Q } }" := (aneris_wp ip E e%E (λ v, Q)) + (at level 20, e, Q at level 200, + format "'WP' e '@[' ip ] E {{ v , Q } }") : bi_scope. +Notation "'WP' e '@[' ip ] {{ v , Q } }" := (aneris_wp ip ⊤ e%E (λ v, Q)) + (at level 20, e, Q at level 200, + format "'WP' e '@[' ip ] {{ v , Q } }") : bi_scope. + +(* Texan triples *) +Notation "'{{{' P } } } e '@[' ip ] E {{{ x .. y , 'RET' pat ; Q } } }" := + (□ ∀ Φ, + P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @[ip] E {{ Φ }})%I + (at level 20, x closed binder, y closed binder, + format "{{{ P } } } e '@[' ip ] E {{{ x .. y , RET pat ; Q } } }") : bi_scope. +Notation "'{{{' P } } } e '@[' ip ] {{{ x .. y , 'RET' pat ; Q } } }" := + (□ ∀ Φ, + P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @[ip] {{ Φ }})%I + (at level 20, x closed binder, y closed binder, + format "{{{ P } } } e '@[' ip ] {{{ x .. y , RET pat ; Q } } }") : bi_scope. +Notation "'{{{' P } } } e '@[' ip ] E {{{ 'RET' pat ; Q } } }" := + (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @[ip] E {{ Φ }})%I + (at level 20, + format "{{{ P } } } e '@[' ip ] E {{{ RET pat ; Q } } }") : bi_scope. +Notation "'{{{' P } } } e '@[' ip ] {{{ 'RET' pat ; Q } } }" := + (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @[ip] {{ Φ }})%I + (at level 20, + format "{{{ P } } } e '@[' ip ] {{{ RET pat ; Q } } }") : bi_scope. + +Notation "'{{{' P } } } e '@[' ip ] E {{{ x .. y , 'RET' pat ; Q } } }" := + (∀ Φ, + P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @[ip] E {{ Φ }}) + (at level 20, x closed binder, y closed binder, + format "{{{ P } } } e '@[' ip ] E {{{ x .. y , RET pat ; Q } } }") : stdpp_scope. +Notation "'{{{' P } } } e '@[' ip ] {{{ x .. y , 'RET' pat ; Q } } }" := + (∀ Φ, + P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @[ip] {{ Φ }}) + (at level 20, x closed binder, y closed binder, + format "{{{ P } } } e '@[' ip ] {{{ x .. y , RET pat ; Q } } }") : stdpp_scope. +Notation "'{{{' P } } } e '@[' ip ] E {{{ 'RET' pat ; Q } } }" := + (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @[ip] E {{ Φ }}) + (at level 20, + format "{{{ P } } } e '@[' ip ] E {{{ RET pat ; Q } } }") : stdpp_scope. +Notation "'{{{' P } } } e '@[' ip ] {{{ 'RET' pat ; Q } } }" := + (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @[ip] {{ Φ }}) + (at level 20, + format "{{{ P } } } e '@[' ip ] {{{ RET pat ; Q } } }") : stdpp_scope. + +Section aneris_wp. +Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. +Context `{!LiveModelEq LM}. +Context `{aG : !anerisG LM Σ}. +Implicit Types ip : ip_address. +Implicit Types P : iProp Σ. +Implicit Types Φ : val → iProp Σ. +Implicit Types v : val. +Implicit Types e : expr. + +(* This lifts a primitive wp into the aneris wp that hides the node *) +Lemma aneris_wp_lift tid ip e E Φ : + is_node ip -∗ aneris_wp ip E e Φ -∗ + wp NotStuck E (ip,tid) (mkExpr ip e) (λ w, ∃ v, ⌜w = mkVal ip v⌝ ∗ Φ v). +Proof. iIntros "Hnode Hwp". rewrite aneris_wp_eq. by iApply "Hwp". Qed. + +(* Weakest pre *) +Lemma aneris_wp_unfold ip E e Φ : + WP e @[ip] E {{ Φ }} ⊣⊢ aneris_wp_def ip E e Φ. +Proof. rewrite /wp aneris_wp_eq //. Qed. + +Global Instance aneris_wp_ne ip E e k : + Proper (pointwise_relation _ (dist k) ==> dist k) (aneris_wp ip E e). +Proof. + intros Φ1 Φ2 HΦ; rewrite aneris_wp_eq /aneris_wp_def; solve_proper. +Qed. +Global Instance aneris_wp_proper ip E e : + Proper (pointwise_relation _ (≡) ==> (≡)) (aneris_wp ip E e). +Proof. + intros Φ1 Φ2 HΦ; rewrite aneris_wp_eq /aneris_wp_def; solve_proper. +Qed. +Global Instance aneris_wp_contractive ip E e k : + TCEq (to_val e) None → + Proper (pointwise_relation _ (dist_later k) ==> dist k) (aneris_wp ip E e). +Proof. + intros Htv Φ1 Φ2 HΦ; rewrite aneris_wp_eq /aneris_wp_def. + do 3 f_equiv. + apply wp_contractive. + - rewrite /= /aneris_to_val Htv //. + - f_equiv. dist_later_intro. solve_proper. +Qed. + +Lemma aneris_wp_value' ip E Φ v : Φ v ⊢ WP of_val v @[ip] E {{ Φ }}. +Proof. + iIntros "HΦ". + rewrite aneris_wp_unfold /aneris_wp_def. + iIntros (tid) "Hin". + by iApply wp_value; eauto. + Qed. + +Lemma aneris_wp_is_node ip E Φ e : + (is_node ip -∗ WP e @[ip] E {{ Φ }}) ⊢ WP e @[ip] E {{ Φ }}. +Proof. + rewrite aneris_wp_unfold /aneris_wp_def. + iIntros "Hwp %tid #Hin". + iApply "Hwp"; done. + Qed. + +Lemma aneris_wp_strong_mono ip E1 E2 e Φ Ψ : + E1 ⊆ E2 → + WP e @[ip] E1 {{ Φ }} -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ WP e @[ip] E2 {{ Ψ }}. +Proof. + rewrite !aneris_wp_unfold /aneris_wp_def. + iIntros (HE) "Hwp HΦ %tid Hin". + iSpecialize ("Hwp" $! tid). + iApply (wp_strong_mono with "[Hin Hwp]"); [done|done|iApply "Hwp"; done|]. + iIntros (?); iDestruct 1 as (w) "[-> Hw]". + iMod ("HΦ" with "Hw"); eauto. +Qed. + +Lemma fupd_aneris_wp ip E e Φ : + (|={E}=> WP e @[ip] E {{ Φ }}) ⊢ WP e @[ip] E {{ Φ }}. +Proof. + rewrite !aneris_wp_unfold /aneris_wp_def. + iIntros "Hwp %tid Hin". + iApply fupd_wp; iMod "Hwp"; iModIntro. + iApply "Hwp"; done. +Qed. + +Lemma aneris_wp_fupd ip E e Φ : + WP e @[ip] E {{ v, |={E}=> Φ v }} ⊢ WP e @[ip] E {{ Φ }}. +Proof. iIntros "H". iApply (aneris_wp_strong_mono ip E with "H"); auto. Qed. + +Lemma aneris_wp_atomic ip E1 E2 e Φ `{!Atomic WeaklyAtomic (mkExpr ip e)} : + (|={E1,E2}=> WP e @[ip] E2 {{ v, |={E2,E1}=> Φ v }}) ⊢ WP e @[ip] E1 {{ Φ }}. +Proof. + rewrite !aneris_wp_unfold /aneris_wp_def. + iIntros "Hwp %tid Hin". + iApply wp_atomic. simpl. + iMod "Hwp"; iModIntro. + iApply wp_mono; last by iApply "Hwp". + iIntros (v); iDestruct 1 as (w) "[-> >Hw]"; eauto. +Qed. + +Lemma aneris_wp_atomic_take_step ip E1 E2 e Φ + `{!Atomic WeaklyAtomic (mkExpr ip e)} : + TCEq (to_val e) None → + (|={E1,E2}=> + ∀ (extr : execution_trace aneris_lang) (atr : auxiliary_trace (live_model_to_model LM)) c1, + ⌜trace_ends_in extr c1⌝ → + state_interp extr atr ={E2}=∗ + ∃ Q R, + state_interp extr atr ∗ + (∀ c2 δ2 ℓ oζ, + ∃ δ' ℓ', + state_interp + (trace_extend extr oζ c2) + (trace_extend atr ℓ δ2) ∗ Q ={E2}=∗ + state_interp + (trace_extend extr oζ c2) + (trace_extend atr ℓ' δ') ∗ R) ∗ + (state_interp extr atr ={E2}=∗ state_interp extr atr ∗ Q) ∗ + WP e @[ip] E2 {{ v, R ={E2,E1}=∗ Φ v }}) ⊢ WP e @[ip] E1 {{ Φ }}. +Proof. + rewrite !aneris_wp_unfold /aneris_wp_def. + iIntros (He) "Hwp %tid Hisnode". + iApply (wp_atomic_take_step _ _ E2). + { rewrite /= /aneris_to_val He //. } + iMod "Hwp". iModIntro. + iIntros (ex atr c1 δ1 ζ' Hδ1 Hatr <-) "Hsi". + iDestruct ("Hwp" with "[] Hsi") as "> Hwp"; first done. + iDestruct "Hwp" as (Q R) "(Hsi & H1 & H2 & Hwp)". + iModIntro. + iExists Q, R; iFrame. + iSplitL "H1". + { iIntros (α c2 δ2 ℓ). iSpecialize ("H1" $! c2 δ2 ℓ (inl (ip,tid,α))). + iFrame. } + rewrite !aneris_wp_unfold /aneris_wp_def. + iDestruct ("Hwp" with "Hisnode") as "Hwp". + iApply wp_wand_r; iFrame. + iIntros (v) "H". iDestruct "H" as (w) "[-> HQimp]". + iIntros "HR". + iMod ("HQimp" with "HR"). + iModIntro; iExists _; iFrame; done. +Qed. + +(* Lemma aneris_wp_stuttering_atomic ip E1 E2 e Φ *) +(* `{!StutteringAtomic WeaklyAtomic (mkExpr ip e)} : *) +(* (|={E1,E2}=> WP e @[ip] E2 {{ v, |={E2,E1}=> Φ v }}) ⊢ WP e @[ip] E1 {{ Φ }}. *) +(* Proof. *) +(* rewrite !aneris_wp_unfold /aneris_wp_def. *) +(* iIntros "He %tid Hn". *) +(* iApply wp_stuttering_atomic. *) +(* iMod "He". iModIntro. *) +(* iApply wp_wand_r; iSplitL. *) +(* { iApply ("He" with "Hn"). } *) +(* iIntros (?). iDestruct 1 as (?) "[% HΦ]". *) +(* iMod "HΦ". iModIntro. eauto. *) +(* Qed. *) + +(* Lemma aneris_wp_stuttering_atomic_take_step ip E1 E2 e Φ *) +(* `{!StutteringAtomic WeaklyAtomic (mkExpr ip e)} : *) +(* TCEq (to_val e) None → *) +(* (|={E1,E2}=> *) +(* ∀ (extr : execution_trace aneris_lang) (atr : auxiliary_trace (aneris_to_trace_model Mdl)) c1, *) +(* ⌜trace_ends_in extr c1⌝ → *) +(* state_interp extr atr ={E2}=∗ *) +(* ∃ Q R, *) +(* state_interp extr atr ∗ *) +(* (∀ c2 δ2 ℓ oζ, *) +(* ∃ δ', *) +(* state_interp *) +(* (trace_extend extr oζ c2) *) +(* (trace_extend atr ℓ δ2) ∗ Q ={E2}=∗ *) +(* state_interp *) +(* (trace_extend extr oζ c2) *) +(* (trace_extend atr stuttering_label δ') ∗ R) ∗ *) +(* (state_interp extr atr ={E2}=∗ state_interp extr atr ∗ Q) ∗ *) +(* WP e @[ip] E2 {{ v, R ={E2,E1}=∗ Φ v }}) ⊢ WP e @[ip] E1 {{ Φ }}. *) +(* Proof. *) +(* rewrite !aneris_wp_unfold /aneris_wp_def. *) +(* iIntros (He) "Hwp %tid Hisnode". *) +(* iApply (wp_stutteringatomic_take_step _ _ E2). *) +(* { rewrite /= /aneris_to_val He //. } *) +(* iMod "Hwp". iModIntro. *) +(* iIntros (ex atr c1 δ1 ? Hδ1 Hatr <-) "Hsi". *) +(* iDestruct ("Hwp" with "[] Hsi") as "> Hwp"; first done. *) +(* iDestruct "Hwp" as (Q R) "(Hsi & H1 & H2 & Hwp)". *) +(* iModIntro. *) +(* iExists _, _; iFrame. *) +(* iSplitL "H1". *) +(* { iIntros (c2 δ2 ℓ). iSpecialize ("H1" $! c2 δ2 ℓ (inl (ip, tid))). *) +(* iFrame. } *) +(* rewrite !aneris_wp_unfold /aneris_wp_def. *) +(* iDestruct ("Hwp" with "Hisnode") as "Hwp". *) +(* iApply wp_wand_r; iFrame. *) +(* iIntros (v) "H". iDestruct "H" as (w) "[-> HQimp]". *) +(* iIntros "HR". *) +(* iMod ("HQimp" with "HR"). *) +(* iModIntro; iExists _; iFrame; done. *) +(* Qed. *) + +Lemma aneris_wp_lb_get ip E e Φ : + TCEq (to_val e) None → + (steps_lb 0 -∗ WP e @[ip] E {{ v, Φ v }}) -∗ + WP e @[ip] E {{ Φ }}. +Proof. + rewrite !aneris_wp_unfold /aneris_wp_def. + iIntros (He) "Hwp". + iIntros (tid) "Hip". + rewrite !wp_unfold /wp_pre /= /aneris_to_val /= He. + iIntros (extr atr K tp1 tp2 σ1 Hexvalid Hloc Hexe) "[[Hsi Hauth] Hm]". + iDestruct (steps_lb_get with "Hauth") as "#Hlb". + iDestruct (steps_lb_le _ 0 with "Hlb") as "Hlb'"; [lia|]. + iMod (fupd_mask_subseteq E) as "Hclose"; first done. + iDestruct ("Hwp" with "Hlb' Hip") as "Hwp". + rewrite !wp_unfold /wp_pre /= /aneris_to_val /= He. + iMod ("Hwp" with "[//] [//] [//] [$]") as "[% H]". + iModIntro. + iSplit; [done|]. + iIntros (α e2 σ2 efs Hstep). simpl. + iMod ("H" with "[//]") as "H". iIntros "!> !>". + iMod "H" as "H". iIntros "!>". + iApply (step_fupdN_wand with "[H]"); first by iApply "H". + iIntros "H". iMod "H" as (δ2 ℓ) "([[Hsi Hauth] Hm] & H & Hefs)". + iMod "Hclose" as "_". iModIntro. + iExists δ2, ℓ. + iFrame. +Qed. + +Lemma aneris_wp_lb_update ip n E e Φ : + TCEq (to_val e) None → + steps_lb n -∗ + WP e @[ip] E {{ v, steps_lb (S n) -∗ Φ v }} -∗ + WP e @[ip] E {{ Φ }}. +Proof. + rewrite !aneris_wp_unfold /aneris_wp_def. + iIntros (He) "Hlb Hwp". + iIntros (tid) "Hip". + iDestruct ("Hwp" with "Hip") as "Hwp". + rewrite !wp_unfold /wp_pre /=. + rewrite /aneris_to_val. simpl. rewrite He. simpl. + iIntros (extr atr K tp1 tp2 σ1 Hexvalid Hloc Hexe) "[[Hsi Hauth] Hm]". + iMod (fupd_mask_subseteq E) as "Hclose"; first done. + iDestruct (steps_lb_valid with "Hauth Hlb") as %Hle. + iMod ("Hwp" with "[//] [//] [//] [$]") as "[% H]". + iModIntro. + iSplit; [done|]. + iIntros (α e2 σ2 efs Hstep). simpl. + iMod ("H" with "[//]") as "H". iIntros "!> !>". + iMod "H" as "H". iIntros "!>". + iApply (step_fupdN_wand with "[H]"); first by iApply "H". + iIntros "H". iMod "H" as (δ2 ℓ) "([[Hsi Hauth] Hm] & H & Hefs)". + iDestruct (steps_lb_get with "Hauth") as "#Hlb'". + iDestruct (steps_lb_le _ (S n) with "Hlb'") as "#Hlb''"; [simpl; lia|]. + iMod "Hclose" as "_". iModIntro. + iExists δ2, ℓ. + iFrame. + iApply (wp_wand with "H"). + iIntros (v) "H". + iDestruct "H" as (w Heq) "H". + iExists _. iSplit; [done|]. by iApply "H". +Qed. + +Lemma aneris_wp_step_fupdN ip n E1 E2 e P Φ : + TCEq (to_val e) None → E2 ⊆ E1 → + (∀ extr atr, state_interp extr atr + ={E1,∅}=∗ ⌜n ≤ S (trace_length extr)⌝%nat) ∧ + ((|={E1∖E2,∅}=> |={∅}▷=>^n |={∅,E1∖E2}=> P) ∗ + WP e @[ip] E2 {{ v, P ={E1}=∗ Φ v }}) -∗ + WP e @[ip] E1 {{ Φ }}. +Proof. + rewrite !aneris_wp_unfold /aneris_wp_def. + iIntros (He HE) "H %tid Hin". + iApply (wp_step_fupdN with "[H Hin]"); [|done|]. + { rewrite /= /aneris_to_val He //. } + iSplit; [by iDestruct "H" as "[H _]"|]. + iDestruct "H" as "[_ [$ Hwp]]". + iApply wp_mono; last by iApply "Hwp". + iIntros (v); iDestruct 1 as (w) "[-> Hw]". + iIntros "HP"; iMod ("Hw" with "HP"); eauto. +Qed. + +Lemma aneris_wp_lb_step ip n E1 E2 e P Φ : + TCEq (to_val e) None → E2 ⊆ E1 → + steps_lb n -∗ + (|={E1∖E2,∅}=> |={∅}▷=>^(S n) |={∅,E1∖E2}=> P) -∗ + WP e @[ip] E2 {{ v, P ={E1}=∗ Φ v }} -∗ + WP e @[ip] E1 {{ Φ }}. +Proof. + iIntros (He HE) "Hlb HP Hwp". + iApply aneris_wp_step_fupdN; [done|]. + iSplit; [|by iFrame]. + iIntros (extr atr) "[[Hsi Hauth] Hm]". + iDestruct (steps_lb_valid with "Hauth Hlb") as %Hle. + iApply fupd_mask_intro; [set_solver|]. + iIntros "_". iPureIntro. lia. +Qed. + +Lemma aneris_wp_step_fupd ip E1 E2 e P Φ : + TCEq (to_val e) None → E2 ⊆ E1 → + (|={E1}[E2]▷=> P) -∗ WP e @[ip] E2 {{ v, P ={E1}=∗ Φ v }} -∗ + WP e @[ip] E1 {{ Φ }}. +Proof. + rewrite !aneris_wp_unfold /aneris_wp_def. + iIntros (He HE) "HP Hwp %tid Hin". + iApply (wp_step_fupd with "[$HP]"); [|done|]. + { rewrite /= /aneris_to_val He //. } + iApply wp_mono; last by iApply "Hwp". + iIntros (v); iDestruct 1 as (w) "[-> Hw]". + iIntros "HP"; iMod ("Hw" with "HP"); eauto. +Qed. + +Lemma aneris_wp_socket_interp_alloc_group_singleton Ψ ip E e Φ sag : + TCEq (to_val e) None → + unallocated_groups {[sag]} -∗ + (sag ⤇* Ψ -∗ WP e @[ip] E {{ Φ }}) -∗ + WP e @[ip] E {{ Φ }}. +Proof. + rewrite !aneris_wp_unfold /aneris_wp_def. + iIntros (He) "Hsag Hwp %tid Hin". + rewrite !wp_unfold /wp_def /wp_pre. simpl. rewrite /aneris_to_val. + rewrite He. simpl. + iIntros (extr atr K tp1 tp2 σ1 Hextr Hlocale Htr). + iIntros "[[Hσ Hauth] Hm]". + iMod (aneris_state_interp_socket_interp_allocate_singleton with "Hσ Hsag") + as "[Hσ HΨ]". + iDestruct ("Hwp" with "HΨ Hin") as "Hwp". + rewrite !wp_unfold /wp_def /wp_pre. simpl. rewrite /aneris_to_val He. + by iApply ("Hwp" with "[//] [//] [//] [$]"). +Qed. + +Lemma aneris_wp_socket_interp_alloc_group_fun f ip E e Φ sags : + TCEq (to_val e) None → + unallocated_groups sags -∗ + (([∗ set] sag ∈ sags, sag ⤇* f sag) -∗ WP e @[ip] E {{ Φ }}) -∗ + WP e @[ip] E {{ Φ }}. +Proof. + rewrite !aneris_wp_unfold /aneris_wp_def. + iIntros (He) "Hsag Hwp %tid Hin". + rewrite !wp_unfold /wp_def /wp_pre. simpl. rewrite /aneris_to_val. + rewrite He. simpl. + iIntros (extr atr K tp1 tp2 σ1 Hextr Hlocale Htr). + iIntros "[[Hσ Hauth] Hm]". + iMod (aneris_state_interp_socket_interp_allocate_fun with "Hσ Hsag") as "[Hσ HΨ]". + iDestruct ("Hwp" with "HΨ Hin") as "Hwp". + rewrite !wp_unfold /wp_def /wp_pre. simpl. rewrite /aneris_to_val He. + by iApply ("Hwp" with "[//] [//] [//] [$]"). +Qed. + +Lemma aneris_wp_socket_interp_alloc_group Ψ ip E e Φ sags : + TCEq (to_val e) None → + unallocated_groups sags -∗ + (([∗ set] sag ∈ sags, sag ⤇* Ψ) -∗ WP e @[ip] E {{ Φ }}) -∗ + WP e @[ip] E {{ Φ }}. +Proof. + rewrite !aneris_wp_unfold /aneris_wp_def. + iIntros (He) "Hsag Hwp %tid Hin". + rewrite !wp_unfold /wp_def /wp_pre. simpl. rewrite /aneris_to_val. + rewrite He. simpl. + iIntros (extr atr K tp1 tp2 σ1 Hextr Hlocale Htr). + iIntros "[[Hσ Hauth] Hm]". + iMod (aneris_state_interp_socket_interp_allocate with "Hσ Hsag") as "[Hσ HΨ]". + iDestruct ("Hwp" with "HΨ Hin") as "Hwp". + rewrite !wp_unfold /wp_def /wp_pre. simpl. rewrite /aneris_to_val He. + by iApply ("Hwp" with "[//] [//] [//] [$]"). +Qed. + +Lemma aneris_wp_socket_interp_alloc_singleton Ψ ip E e Φ sa : + TCEq (to_val e) None → + unallocated {[sa]} -∗ + (sa ⤇ Ψ -∗ WP e @[ip] E {{ Φ }}) -∗ + WP e @[ip] E {{ Φ }}. +Proof. + iIntros (He) "Hsag Hwp". + iApply (aneris_wp_socket_interp_alloc_group_singleton _ _ _ _ _ {[sa]} + with "[Hsag]"); + [|done]. + by rewrite /unallocated /to_singletons gset_map.gset_map_singleton. +Qed. + +Lemma aneris_wp_socket_interp_alloc_fun f ip E e Φ sas : + TCEq (to_val e) None → + unallocated sas -∗ + (([∗ set] sa ∈ sas, sa ⤇ f sa) -∗ WP e @[ip] E {{ Φ }}) -∗ + WP e @[ip] E {{ Φ }}. +Proof. + iIntros (He) "Hsag Hwp". + iApply (aneris_wp_socket_interp_alloc_group_fun (λ x, from_singleton $ f (hd inhabitant (elements x))) _ _ _ _ (to_singletons sas) + with "Hsag"). + iIntros "Hsags". iApply ("Hwp" with "[Hsags]"). + iInduction sas as [|sag sags Hnin] "IHsags" using set_ind_L; [done|]. + rewrite to_singletons_union. rewrite big_sepS_union; [|set_solver]. + rewrite big_sepS_union; [| by rewrite to_singletons_inv; set_solver]. + iDestruct "Hsags" as "[Hsag Hsags]". + iDestruct ("IHsags" with "Hsags") as "H". + rewrite to_singletons_inv !big_sepS_singleton (elements_singleton _). + by iFrame. +Qed. + +Lemma aneris_wp_socket_interp_alloc Ψ ip E e Φ sas : + TCEq (to_val e) None → + unallocated sas -∗ + (([∗ set] sa ∈ sas, sa ⤇ Ψ) -∗ WP e @[ip] E {{ Φ }}) -∗ + WP e @[ip] E {{ Φ }}. +Proof. + iIntros (He) "Hsag Hwp". + iApply (aneris_wp_socket_interp_alloc_group _ _ _ _ _ (to_singletons sas) + with "Hsag"). + iIntros "Hsags". iApply ("Hwp" with "[Hsags]"). + iInduction sas as [|sag sags Hnin] "IHsags" using set_ind_L; [done|]. + rewrite to_singletons_union. rewrite big_sepS_union; [|set_solver]. + rewrite big_sepS_union; [| by rewrite to_singletons_inv; set_solver]. + iDestruct "Hsags" as "[Hsag Hsags]". + iDestruct ("IHsags" with "Hsags") as "$". + by rewrite to_singletons_inv !big_sepS_singleton. +Qed. + +Lemma aneris_wp_bind K ip E e Φ : + WP e @[ip] E {{ v, WP fill K (of_val v) @[ip] E {{ Φ }} }} ⊢ + WP fill K e @[ip] E {{ Φ }}. +Proof. + rewrite !aneris_wp_unfold /aneris_wp_def. + iIntros "Hwp %tid #Hin". + rewrite aneris_base_fill. + iApply wp_bind; simpl. + iApply wp_wand_r; iSplitL; first by iApply "Hwp". + iIntros (v); iDestruct 1 as (w) "[-> Hw]". + rewrite !aneris_wp_unfold /aneris_wp_def. + rewrite -aneris_base_fill /=. + iApply "Hw"; done. +Qed. + +Local Lemma wp_preserves_node E ip e Ψ ζ: + WP (mkExpr ip e) @ ζ; E {{ Ψ }} ⊢ + WP (mkExpr ip e) @ ζ; E {{ λ u, ∃ w, ⌜u = mkVal ip w⌝ ∗ Ψ u }}. +Proof. + iIntros "Hwp". + iLöb as "IH" forall (E ip e Ψ). + rewrite !wp_unfold /wp_pre /= /aneris_to_val /=. + destruct (base_lang.to_val e); simpl. + { iMod "Hwp". iModIntro. eauto. } + iIntros (ex atr K tp1 tp2 σ1 Hexvalid Hex Hlocale) "[[Hsi Hauth] Hm]". + iMod ("Hwp" with "[//] [//] [//] [$]") as "[% Hstp]". + iModIntro. + iSplit; first done. + iIntros (α e2 σ2 efs Hpstp). + assert (∃ e2', e2 = mkExpr ip e2') as [e2' ->]. + { inversion Hpstp as [? e1' ? He1' ? Hhstp]; simplify_eq/=. + destruct e1'. + rewrite -aneris_base_fill in He1'; simplify_eq/=. + inversion Hhstp; simplify_eq; rewrite -aneris_base_fill; eauto. } + iMod ("Hstp" $! α (mkExpr ip e2') σ2 efs with "[//]") as "Hstp". + iModIntro; iNext. iMod "Hstp". iModIntro. + iApply (step_fupdN_wand with "Hstp"). iIntros "Hstp". + iMod "Hstp" as (δ' ℓ) "(Hsi & Hwp & Hefs)". + iModIntro; iFrame. + iExists _, _. iFrame. + iApply "IH"; done. +Qed. + +(** * Derived rules *) +Lemma aneris_wp_mono ip E e Φ Ψ : + (∀ v, Φ v ⊢ Ψ v) → WP e @[ip] E {{ Φ }} ⊢ WP e @[ip] E {{ Ψ }}. +Proof. + iIntros (HΦ) "H"; iApply (aneris_wp_strong_mono with "H"); auto. + iIntros (v) "?". by iApply HΦ. +Qed. +Lemma aneris_wp_weaken ip E e Φ : + WP e @[ip] E {{ Φ }} ⊢ WP e @[ip] E {{ Φ }}. +Proof. apply aneris_wp_mono; done. Qed. +Lemma aneris_wp_mask_mono ip E1 E2 e Φ : + E1 ⊆ E2 → WP e @[ip] E1 {{ Φ }} ⊢ WP e @[ip] E2 {{ Φ }}. +Proof. iIntros (?) "H"; iApply (aneris_wp_strong_mono with "H"); auto. Qed. +Global Instance aneris_wp_mono' ip E e : + Proper (pointwise_relation _ (⊢) ==> (⊢)) (aneris_wp ip E e). +Proof. by intros Φ Φ' ?; apply aneris_wp_mono. Qed. +Global Instance aneris_wp_flip_mono' ip E e : + Proper (pointwise_relation _ (flip (⊢)) ==> (flip (⊢))) (aneris_wp ip E e). +Proof. by intros Φ Φ' ?; apply aneris_wp_mono. Qed. + +Lemma aneris_wp_value ip E Φ e v : IntoVal e v → Φ v ⊢ WP e @[ip] E {{ Φ }}. +Proof. intros <-. by apply aneris_wp_value'. Qed. +Lemma aneris_wp_value_fupd ip E Φ v : + (|={E}=> Φ v) ⊢ WP of_val v @[ip] E {{ Φ }}. +Proof. intros. by rewrite -aneris_wp_fupd -aneris_wp_value'. Qed. +Lemma aneris_wp_value_fupd' ip E Φ e v `{!IntoVal e v} : + (|={E}=> Φ v) ⊢ WP e @[ip] E {{ Φ }}. +Proof. intros. rewrite -aneris_wp_fupd -aneris_wp_value //. Qed. + +Lemma aneris_wp_frame_l ip E e Φ R : + R ∗ WP e @[ip] E {{ Φ }} ⊢ WP e @[ip] E {{ v, R ∗ Φ v }}. +Proof. + iIntros "[? H]". iApply (aneris_wp_strong_mono with "H"); auto with iFrame. +Qed. +Lemma aneris_wp_frame_r ip E e Φ R : + WP e @[ip] E {{ Φ }} ∗ R ⊢ WP e @[ip] E {{ v, Φ v ∗ R }}. +Proof. + iIntros "[H ?]". iApply (aneris_wp_strong_mono with "H"); auto with iFrame. +Qed. + +Lemma aneris_wp_frame_step_l ip E1 E2 e Φ R : + TCEq (to_val e) None → E2 ⊆ E1 → + (|={E1}[E2]▷=> R) ∗ WP e @[ip] E2 {{ Φ }} ⊢ WP e @[ip] E1 {{ v, R ∗ Φ v }}. +Proof. + iIntros (??) "[Hu Hwp]". iApply (aneris_wp_step_fupd with "Hu"); try done. + iApply (aneris_wp_mono with "Hwp"). by iIntros (?) "$$". +Qed. +Lemma aneris_wp_frame_step_r ip E1 E2 e Φ R : + TCEq (to_val e) None → E2 ⊆ E1 → + WP e @[ip] E2 {{ Φ }} ∗ (|={E1}[E2]▷=> R) ⊢ WP e @[ip] E1 {{ v, Φ v ∗ R }}. +Proof. + rewrite [(WP _ @[_] _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R). + apply aneris_wp_frame_step_l. +Qed. +Lemma aneris_wp_frame_step_l' ip E e Φ R : + TCEq (to_val e) None → + ▷ R ∗ WP e @[ip] E {{ Φ }} ⊢ WP e @[ip] E {{ v, R ∗ Φ v }}. +Proof. + iIntros (?) "[??]". iApply (aneris_wp_frame_step_l ip E E); try iFrame; eauto. +Qed. +Lemma aneris_wp_frame_step_r' ip E e Φ R : + TCEq (to_val e) None → + WP e @[ip] E {{ Φ }} ∗ ▷ R ⊢ WP e @[ip] E {{ v, Φ v ∗ R }}. +Proof. + iIntros (?) "[??]". iApply (aneris_wp_frame_step_r ip E E); try iFrame; eauto. + Qed. + +Lemma aneris_wp_wand ip E e Φ Ψ : + WP e @[ip] E {{ Φ }} -∗ (∀ v, Φ v -∗ Ψ v) -∗ WP e @[ip] E {{ Ψ }}. +Proof. + iIntros "Hwp H". iApply (aneris_wp_strong_mono with "Hwp"); auto. + iIntros (?) "?". by iApply "H". +Qed. +Lemma aneris_wp_wand_l ip E e Φ Ψ : + (∀ v, Φ v -∗ Ψ v) ∗ WP e @[ip] E {{ Φ }} ⊢ WP e @[ip] E {{ Ψ }}. +Proof. iIntros "[H Hwp]". iApply (aneris_wp_wand with "Hwp H"). Qed. +Lemma aneris_wp_wand_r ip E e Φ Ψ : + WP e @[ip] E {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ WP e @[ip] E {{ Ψ }}. +Proof. iIntros "[Hwp H]". iApply (aneris_wp_wand with "Hwp H"). Qed. +Lemma aneris_wp_frame_wand_l ip E e Q Φ : + Q ∗ WP e @[ip] E {{ v, Q -∗ Φ v }} -∗ WP e @[ip] E {{ Φ }}. +Proof. + iIntros "[HQ HWP]". iApply (aneris_wp_wand with "HWP"). + iIntros (v) "HΦ". by iApply "HΦ". +Qed. + +End aneris_wp. + +(** Proofmode class instances *) +Section proofmode_classes. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + Implicit Types P Q : iProp Σ. + Implicit Types Φ : val → iProp Σ. + + Global Instance frame_wp p ip E e R Φ Ψ : + (∀ v, Frame p R (Φ v) (Ψ v)) → + Frame p R (WP e @[ip] E {{ Φ }}) (WP e @[ip] E {{ Ψ }}). + Proof. + rewrite /Frame=> HR. rewrite aneris_wp_frame_l. apply aneris_wp_mono, HR. + Qed. + + Global Instance is_except_0_wp ip E e Φ : IsExcept0 (WP e @[ip] E {{ Φ }}). + Proof. + rewrite /IsExcept0 -{2}fupd_aneris_wp -except_0_fupd -fupd_intro; done. + Qed. + + Global Instance elim_modal_bupd_wp p ip E e P Φ : + ElimModal True p false (|==> P) P (WP e @[ip] E {{ Φ }}) (WP e @[ip] E {{ Φ }}). + Proof. + by rewrite /ElimModal bi.intuitionistically_if_elim + (bupd_fupd E) fupd_frame_r bi.wand_elim_r fupd_aneris_wp. + Qed. + + Global Instance elim_modal_fupd_wp p ip E e P Φ : + ElimModal True p false (|={E}=> P) P + (WP e @[ip] E {{ Φ }}) (WP e @[ip] E {{ Φ }}). + Proof. + by rewrite /ElimModal bi.intuitionistically_if_elim + fupd_frame_r bi.wand_elim_r fupd_aneris_wp. + Qed. + + (* Global Instance elim_modal_fupd_wp_stutteringatomic p ip E1 E2 e P Φ : *) + (* StutteringAtomic WeaklyAtomic (mkExpr ip e) → *) + (* ElimModal True p false (|={E1,E2}=> P) P *) + (* (WP e @[ip] E1 {{ Φ }}) (WP e @[ip] E2 {{ v, |={E2,E1}=> Φ v }})%I. *) + (* Proof. *) + (* intros. by rewrite /ElimModal bi.intuitionistically_if_elim *) + (* fupd_frame_r bi.wand_elim_r aneris_wp_stuttering_atomic. *) + (* Qed. *) + + Global Instance add_modal_fupd_wp ip E e P Φ : + AddModal (|={E}=> P) P (WP e @[ip] E {{ Φ }}). + Proof. by rewrite /AddModal fupd_frame_r bi.wand_elim_r fupd_aneris_wp. Qed. + + (* Global Instance elim_acc_wp_stuttering {X} E1 E2 α β γ e ip Φ : *) + (* StutteringAtomic WeaklyAtomic (mkExpr ip e) → *) + (* ElimAcc (X:=X) True (fupd E1 E2) (fupd E2 E1) *) + (* α β γ (WP e @[ip] E1 {{ Φ }}) *) + (* (λ x, WP e @[ip] E2 {{ v, |={E2}=> β x ∗ (γ x -∗? Φ v) }})%I. *) + (* Proof. *) + (* intros ? _. *) + (* iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]". *) + (* iApply (aneris_wp_wand with "(Hinner Hα)"). *) + (* iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose". *) + (* Qed. *) + + Global Instance elim_acc_wp_nonatomic {X} E α β γ e ip Φ : + ElimAcc (X:=X) True (fupd E E) (fupd E E) + α β γ (WP e @[ip] E {{ Φ }}) + (λ x, WP e @[ip] E {{ v, |={E}=> β x ∗ (γ x -∗? Φ v) }})%I. + Proof. + iIntros (_) "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]". + iApply aneris_wp_fupd. + iApply (aneris_wp_wand with "(Hinner Hα)"). + iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose". + Qed. +End proofmode_classes. diff --git a/fairneris/aneris_lang/resources.v b/fairneris/aneris_lang/resources.v new file mode 100644 index 0000000..6e77962 --- /dev/null +++ b/fairneris/aneris_lang/resources.v @@ -0,0 +1,1716 @@ +From stdpp Require Import fin_maps gmap. +From iris.algebra Require Import auth gmap frac agree coPset + gset frac_auth ofe excl. +From iris.bi.lib Require Import fractional. +From iris.base_logic.lib Require Import saved_prop invariants mono_nat. +From iris.proofmode Require Import tactics. +From fairneris.lib Require Import gen_heap_light. +From fairneris.aneris_lang Require Export aneris_lang network network_model. +From fairneris.algebra Require Import disj_gsets. +From trillium.events Require Import event. +From fairneris.aneris_lang Require Import events. +From fairneris.prelude Require Import gset_map. +From fairneris.lib Require Export singletons. +From fairneris Require Import fairness fuel fair_resources env_model. + +Set Default Proof Using "Type". + +Import uPred. +Import ast. + +(* Record Model := *) +(* model { *) +(* model_state :> Type; *) +(* model_rel :> model_state → model_state → Prop; *) +(* model_state_initial : model_state; *) +(* }. *) + +(* Definition aneris_to_trace_model (M: Model): traces.Model := {| *) +(* mstate := model_state M; *) +(* mlabel := unit; *) +(* mtrans x ℓ y := model_rel M ℓ y; *) +(* |}. *) + +Record node_gnames := Node_gname { + heap_name : gname; + sockets_name : gname; +}. + +Definition socket_address_group := gset socket_address. +Definition socket_address_groupO := gsetO socket_address. + +Definition node_gnamesO := + leibnizO node_gnames. +Definition node_gnames_mapUR : ucmra := + gmapUR ip_address (agreeR node_gnamesO). +Definition local_heapUR : ucmra := + gen_heapUR loc val. +Definition local_socketsUR : ucmra := gen_heapUR socket_handle socket. +Definition free_ipsUR : ucmra := + (gset_disjUR ip_address). +Definition free_portsUR : ucmra := + gmapUR ip_address (gset_disjUR port). +Definition socket_interpUR : ucmra := + gmapUR socket_address_group (agreeR (leibnizO gname)). +Definition socket_address_groupUR : ucmra := + (disj_gsetsUR socket_address). +Definition unallocated_socket_address_groupsUR : ucmra := + authUR (gset_disjUR socket_address_group). +Definition tracked_socket_address_groupsUR : cmra := + agreeR (gsetUR socket_address_group). +Definition messagesUR : ucmra := + gen_heapUR socket_address_group (message_soup * message_soup). + +#[global] Instance system_state_mapUR_unit : Unit (gmap ip_address (agree node_gnames)) + := (∅ : gmap ip_address (agree node_gnames)). +#[global] Instance system_state_core_id (x : node_gnames_mapUR) : CoreId x. +Proof. apply _. Qed. + +Definition socket_interp Σ := message -d> iPropO Σ. + +Canonical Structure ModelO (Mdl : Model) := leibnizO Mdl. + +Canonical Structure socket_addressO := leibnizO socket_address. + +Definition aneris_events := event_obs aneris_lang. + +Canonical Structure aneris_eventsO := leibnizO aneris_events. + +Definition aneris_localeO := leibnizO aneris_locale. +(* Definition simple_roleO := leibnizO simple_role. *) + +(* Definition live_roleUR := authUR (gmapUR aneris_localeO *) +(* (exclR (optionO simple_roleO))). *) +Definition live_roleUR (FM : FairModel) := + authUR (gset_disjUR $ FM.(fmrole)). + +(* Instance aneris_inh: Inhabited (action aneris_lang). *) + +(** The system CMRA *) +Class anerisG `(LM : LiveModel aneris_lang (joint_model M Net)) `{!LiveModelEq LM} Σ := + AnerisG { + aneris_invG :> invGS_gen HasNoLc Σ; + aneris_fairnessG :> fairnessGS LM Σ; + (** global tracking of the ghost names of node-local heaps *) + aneris_node_gnames_mapG :> inG Σ (authR node_gnames_mapUR); + aneris_node_gnames_name : gname; + (** local heap *) + aneris_heapG :> inG Σ (authR local_heapUR); + (** local sockets *) + aneris_socketG :> inG Σ (authR local_socketsUR); + (** free ips *) + aneris_freeipsG :> inG Σ (authUR free_ipsUR); + aneris_freeips_name : gname; + (** free ports *) + aneris_freeportsG :> inG Σ (authUR free_portsUR); + aneris_freeports_name : gname; + (** groups *) + aneris_socket_address_groupG :> inG Σ (authR socket_address_groupUR); + aneris_socket_address_group_name : gname; + (** socket interpretations *) + aneris_siG :> inG Σ (authR socket_interpUR); + aneris_savedPredG :> savedPredG Σ message; + aneris_si_name : gname; + (** socket address groups with unallocated socket interpretations *) + aneris_unallocated_socket_address_groupsG :> + inG Σ (unallocated_socket_address_groupsUR); + aneris_unallocated_socket_address_groups_name : gname; + (** socket address groups for which we track events *) + aneris_tracked_socket_address_groupsG :> + inG Σ (tracked_socket_address_groupsUR); + (** message history *) + aneris_messagesG :> inG Σ (authR messagesUR); + aneris_messages_name : gname; + (** steps *) + aneris_steps_name : gname; + anerisG_steps :> mono_natG Σ; + (** events *) + anerisG_allocEVS :> inG Σ (authUR (gmapUR string (exclR aneris_eventsO))); + anerisG_sendreceiveEVS :> + inG Σ (authUR (gmapUR socket_address_group (exclR aneris_eventsO))); + aneris_allocEVS_name : gname; + aneris_sendonEVS_name : gname; + aneris_receiveonEVS_name : gname; + aneris_observed_send_name : gname; + aneris_observed_recv_name : gname; + }. + +Class anerisPreG `(LM : LiveModel aneris_lang (joint_model M Net)) `{!LiveModelEq LM} Σ := + AnerisPreG { + anerisPre_invGS :> invGpreS Σ; + anerisPre_fairnessGS :> fairnessGpreS LM Σ; + anerisPre_node_gnames_mapG :> inG Σ (authR node_gnames_mapUR); + anerisPre_heapG :> inG Σ (authR local_heapUR); + anerisPre_socketG :> inG Σ (authR local_socketsUR); + anerisPre_freeipsG :> inG Σ (authUR free_ipsUR); + anerisPre_freeportsG :> inG Σ (authUR free_portsUR); + anerisPre_socket_address_groupG :> inG Σ (authR socket_address_groupUR); + anerisPre_siG :> inG Σ (authR socket_interpUR); + anerisPre_savedPredG :> savedPredG Σ message; + anerisPre_unallocated_socket_address_groupsG :> + inG Σ (unallocated_socket_address_groupsUR); + anerisPre_tracked_socket_address_groupsG :> + inG Σ (tracked_socket_address_groupsUR); + anerisPre_messagesG :> inG Σ (authR messagesUR); + anerisPre_steps :> mono_natG Σ; + anerisPre_allocEVSG :> + inG Σ (authUR (gmapUR string (exclR aneris_eventsO))); + anerisPre_sendreceiveEVSG :> + inG Σ (authUR (gmapUR socket_address_group (exclR aneris_eventsO))); + }. + +Definition anerisΣ `(LM : LiveModel aneris_lang (joint_model M Net)) : gFunctors := + #[invΣ; + fairnessΣ aneris_lang M; + GFunctor (authR node_gnames_mapUR); + GFunctor (authR local_heapUR); + GFunctor (authR local_socketsUR); + GFunctor (authUR free_ipsUR); + GFunctor (authUR free_portsUR); + GFunctor (authUR socket_address_groupUR); + GFunctor (authR socket_interpUR); + savedPredΣ message; + GFunctor (unallocated_socket_address_groupsUR); + GFunctor (tracked_socket_address_groupsUR); + GFunctor (authR messagesUR); + mono_natΣ; + GFunctor (authUR (gmapUR string (exclR aneris_eventsO))); + GFunctor (authUR (gmapUR socket_address_group (exclR aneris_eventsO))) + ]. + +#[global] Instance subG_anerisPreG {Σ: gFunctors} `(LM : LiveModel aneris_lang (joint_model M Net)) `{!LiveModelEq LM} : + subG (anerisΣ LM) Σ → anerisPreG LM Σ. +Proof. solve_inG. Qed. + +Section definitions. + Context `{LM: LiveModel aneris_lang (joint_model M Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + (** Authoritative view of the system ghost names *) + Definition node_gnames_auth (m : gmap ip_address node_gnames) := + own (A := authR node_gnames_mapUR) + aneris_node_gnames_name (● (to_agree <$> m)). + + (** Fragmental view of the system ghost names. *) + Definition mapsto_node_def (ip : ip_address) (γn : node_gnames) := + own (aneris_node_gnames_name) (◯ {[ ip := to_agree γn ]}). + Definition mapsto_node_aux : seal (@mapsto_node_def). by eexists. Qed. + Definition mapsto_node := unseal mapsto_node_aux. + Definition mapsto_node_eq : @mapsto_node = @mapsto_node_def := + seal_eq mapsto_node_aux. + + Definition is_node (ip : ip_address) : iProp Σ := ∃ γn, mapsto_node ip γn. + + (** Local heap *) + Definition heap_ctx (γn : node_gnames) (h : gmap loc val) : iProp Σ := + gen_heap_light_ctx (heap_name γn) h. + + Definition mapsto_heap (ip : ip_address) + (l : loc) (q : Qp) (v : val) : iProp Σ := + (∃ γn, mapsto_node ip γn ∗ lmapsto (heap_name γn) l q v)%I. + + (** Local sockets *) + Definition sockets_ctx (γn : node_gnames) + (s : gmap socket_handle socket) : iProp Σ := + gen_heap_light_ctx (sockets_name γn) s. + + Definition mapsto_socket (ip : ip_address) (z : socket_handle) + (q : Qp) (s: socket) : iProp Σ := + (∃ γn, mapsto_node ip γn ∗ lmapsto (sockets_name γn) z q s)%I. + + (** Free ip addresses *) + Definition free_ips_auth (A : gset ip_address) : iProp Σ := + own aneris_freeips_name (● GSet A). + + Definition free_ip (ip : ip_address) : iProp Σ := + own aneris_freeips_name (◯ GSet {[ ip ]}). + + (** Free ports *) + Definition free_ports_auth (P : gmap ip_address (gset_disjUR port)) : iProp Σ := + own aneris_freeports_name (● P). + + Definition free_ports (ip : ip_address) (ports : gset port) : iProp Σ := + own aneris_freeports_name (◯ ({[ ip := (GSet ports)]})). + + Definition socket_address_groups_own (sags : gset socket_address_group) + : iProp Σ := + own (A:=authUR socket_address_groupUR) aneris_socket_address_group_name + (◯ (DGSets sags)). + + Definition socket_address_group_ctx + (sags : gset socket_address_group) : iProp Σ := + ⌜set_Forall is_ne sags⌝ ∗ + own (A:=authUR socket_address_groupUR) aneris_socket_address_group_name + (● (DGSets sags)) ∗ + own (A:=authUR socket_address_groupUR) aneris_socket_address_group_name + (◯ (DGSets sags)). + + Definition socket_address_group_own (sag : socket_address_group) : iProp Σ := + own (A:=authUR socket_address_groupUR) aneris_socket_address_group_name + (◯ (DGSets {[sag]})). + + (** Ghost names of saved socket interpretations *) + Definition saved_si_auth + (sis : gmap socket_address_group gname) : iProp Σ := + own (A:=(authR socket_interpUR)) aneris_si_name (● (to_agree <$> sis)). + + Definition saved_si (sag : socket_address_group) (γ : gname) : iProp Σ := + own aneris_si_name (◯ {[ sag := to_agree γ ]}). + + (** Socket interpretation [Φ] of group [sag] *) + Definition si_pred (sag : socket_address_group) + (Φ : socket_interp Σ) : iProp Σ := + ∃ γ, socket_address_group_own sag ∗ saved_si sag γ ∗ + saved_pred_own γ (DfracDiscarded) Φ. + + (** The set [A] of addresses with unallocated socket interpretations *) + Definition unallocated_groups_auth (A : gset socket_address_group) : iProp Σ := + own aneris_unallocated_socket_address_groups_name + (auth_auth (DfracOwn 1) (GSet A)). + + Definition unallocated_groups (A : gset socket_address_group) : iProp Σ := + own aneris_unallocated_socket_address_groups_name + (auth_frag (GSet A)). + + Definition unallocated (A : gset socket_address) : iProp Σ := + unallocated_groups (to_singletons A). + + (** The set [A] of addresses for which we track send events. *) + Definition observed_send_groups (A : gset socket_address_group) : iProp Σ := + own aneris_observed_send_name (to_agree A). + + (** The set [A] of addresses for which we track receive events. *) + Definition observed_receive_groups (A : gset socket_address_group) : iProp Σ := + own aneris_observed_recv_name (to_agree A). + + (** The set [A] of addresses for which we track send events. *) + Definition observed_send (A : gset socket_address) : iProp Σ := + observed_send_groups (to_singletons A). + + (** The set [A] of addresses for which we track receive events. *) + Definition observed_receive (A : gset socket_address) : iProp Σ := + observed_receive_groups (to_singletons A). + + Definition alloc_evs_ctx (M : gmap string aneris_events) : iProp Σ := + own (A := authUR (gmapUR string (exclR aneris_eventsO))) + aneris_allocEVS_name (● (Excl <$> M)). + + Definition alloc_evs (lbl : string) (evs : aneris_events) : iProp Σ := + own (A := authUR (gmapUR string (exclR aneris_eventsO))) + aneris_allocEVS_name (◯ {[ lbl := Excl evs]}). + + Definition sendon_evs_ctx + (M : gmap socket_address_group aneris_events) : iProp Σ := + own (A := authUR (gmapUR socket_address_group (exclR aneris_eventsO))) + aneris_sendonEVS_name (● (Excl <$> M)). + + Definition sendon_evs_groups (sag : socket_address_group) + (evs : aneris_events) : iProp Σ := + socket_address_group_own sag ∗ + own (A := authUR (gmapUR socket_address_group (exclR aneris_eventsO))) + aneris_sendonEVS_name (◯ {[ sag := Excl evs]}). + + Definition sendon_evs (sa : socket_address) (evs : aneris_events) : iProp Σ := + sendon_evs_groups {[sa]} evs. + + Definition receiveon_evs_ctx + (M : gmap socket_address_group aneris_events) : iProp Σ := + own (A := authUR (gmapUR socket_address_group (exclR aneris_eventsO))) + aneris_receiveonEVS_name (● (Excl <$> M)). + + Definition receiveon_evs_groups (sag : socket_address_group) + (evs : aneris_events) : iProp Σ := + socket_address_group_own sag ∗ + own (A := authUR (gmapUR socket_address_group (exclR aneris_eventsO))) + aneris_receiveonEVS_name (◯ {[ sag := Excl evs]}). + + Definition receiveon_evs (sa : socket_address) + (evs : aneris_events) : iProp Σ := + receiveon_evs_groups {[sa]} evs. + + (** Messages *) + Definition messages_ctx + (mh : gmap socket_address_group (message_soup * message_soup)) := + gen_heap_light_ctx (aneris_messages_name) mh. + + Definition message_group_equiv (sagT sagR : socket_address_group) + (m1 m2 : message) := + m_sender m1 ∈ sagT ∧ m_sender m2 ∈ sagT ∧ + m_destination m1 ∈ sagR ∧ m_destination m2 ∈ sagR ∧ + m_body m1 = m_body m2. + + Notation "m1 ≡g{ sagT , sagR } m2" := + (message_group_equiv sagT sagR m1 m2) (at level 10). + + #[global] Instance message_group_equiv_dec sagT sagR m1 m2 : + Decision (m1 ≡g{sagT, sagR} m2). + Proof. + rewrite /Decision. + rewrite /message_group_equiv. + destruct (decide (m_body m1 = m_body m2)); [| right; naive_solver ]. + destruct (decide (m_sender m1 ∈ sagT)); [| right; naive_solver ]. + destruct (decide (m_sender m2 ∈ sagT)); [| right; naive_solver ]. + destruct (decide (m_destination m1 ∈ sagR)); [| right; naive_solver ]. + destruct (decide (m_destination m2 ∈ sagR)); [by left | right; naive_solver ]. + Qed. + + Lemma set_Forall_Exists_message_group_equiv_dec sagT sagR m1 + (R : gset message) : + { set_Forall (λ m2, ¬ (m1 ≡g{sagT,sagR} m2)) R} + + { set_Exists (λ m2, m1 ≡g{sagT,sagR} m2) R}. + Proof. + apply set_Forall_Exists_dec. + intros m. + apply Sumbool.sumbool_not. + apply message_group_equiv_dec. + Qed. + + Lemma message_group_equiv_refl sagT sagR m : + m_sender m ∈ sagT → m_destination m ∈ sagR → m ≡g{sagT, sagR} m. + Proof. intros Hsend Hdest. done. Qed. + + Lemma message_group_equiv_symmetry sagT sagR m1 m2 : + m_sender m1 ∈ sagT → m_destination m1 ∈ sagR →m1 ≡g{sagT, sagR} m2 → + m2 ≡g{sagT, sagR} m1. + Proof. + rewrite /message_group_equiv. + intros Hsend Hdest (HT1 & HT2 & HR1 & HR2 & <-). + done. + Qed. + + Lemma message_group_equiv_trans X sagT1 sagT2 sagR1 sagR2 m1 m2 m3 : + all_disjoint X → sagT1 ∈ X → sagT2 ∈ X → sagR1 ∈ X → sagR2 ∈ X → + m1 ≡g{sagT1,sagR1} m2 → m2 ≡g{sagT2,sagR2} m3 → + sagT1 = sagT2 ∧ sagR1 = sagR2 ∧ m1 ≡g{sagT1,sagR1} m3. + Proof. + rewrite /message_group_equiv. + intros Hdisj HsagT1 HsagT2 HsagR1 HsagR2. + intros (HinT11 & HinT12 & HinR11 & HinR12 & <-). + intros (HinT21 & HinT22 & HinR21 & HinR22 & <-). + pose proof (elem_of_all_disjoint_eq sagT1 sagT2 _ X Hdisj HsagT1 HsagT2 HinT12 HinT21) as ->. + pose proof (elem_of_all_disjoint_eq sagR1 sagR2 _ X Hdisj HsagR1 HsagR2 HinR12 HinR21) as ->. + done. + Qed. + + Lemma message_group_equiv_dest_eq X sagT1 sagT2 sagR1 sagR2 m1 m2 : + all_disjoint X → sagT1 ∈ X → sagT2 ∈ X → sagR1 ∈ X → sagR2 ∈ X → + m_sender m1 ∈ sagT1 → + m_destination m1 ∈ sagR1 → + m1 ≡g{sagT2, sagR2} m2 → + sagT1 = sagT2 ∧ sagR1 = sagR2. + Proof. + intros Hdisj HsagT1 HsagT2 HsagR1 HsagR2 Hsend Hdest. + intros (HinT1 & HinT2 & HinR1 & HinR2 & _). + split; eapply elem_of_all_disjoint_eq; eauto. + Qed. + + Lemma message_group_equiv_dest sagT sagR m1 m2 : + m1 ≡g{sagT, sagR} m2 → + m_sender m1 ∈ sagT ∧ m_sender m2 ∈ sagT ∧ + m_destination m1 ∈ sagR ∧ m_destination m2 ∈ sagR. + Proof. by intros (Hsend1 & Hsend2 & Hdest1 & Hdest2 & _). Qed. + + Definition elem_of_group sa sag : iProp Σ := + ⌜sa ∈ sag⌝ ∗ socket_address_group_own sag. + Definition not_elem_of_group sa sag : iProp Σ := + ⌜sa ∉ sag⌝ ∗ socket_address_group_own sag. + + Notation "sa ∈g sag" := (elem_of_group sa sag) (at level 10). + Notation "sa ∉g sag" := (not_elem_of_group sa sag) (at level 10). + + Definition mapsto_messages (sag : socket_address_group) q + (send_obs receive_obs : bool) + (mh : message_soup * message_soup) : iProp Σ := + ∃ As Ar, observed_send_groups As ∗ observed_receive_groups Ar ∗ + (⌜(sag ∈ As ↔ (send_obs = true)) ∧ (sag ∈ Ar ↔ (receive_obs = true))⌝) ∗ + socket_address_group_own sag ∗ + lmapsto aneris_messages_name sag q mh. + + (** Steps *) + Definition steps_auth n := mono_nat_auth_own aneris_steps_name 1 n. + Definition steps_lb n := mono_nat_lb_own aneris_steps_name n. +End definitions. + +(** Heap points-to (LaTeX: [\mapsto]) *) +Notation "l ↦[ ip ]{ q } v" := + (mapsto_heap ip l q v) + (at level 20, q at level 50, format "l ↦[ ip ]{ q } v") : bi_scope. +Notation "l ↦[ ip ] v" := + (l ↦[ip]{1} v)%I (at level 20, format "l ↦[ ip ] v") : bi_scope. +Notation "l ↦[ ip ]{ q } -" := + (∃ v, l ↦[ip]{q} v)%I + (at level 20, q at level 50, format "l ↦[ ip ]{ q } -") : bi_scope. + +Notation "l ↦[ ip ] -" := + (l ↦[ip]{1} -)%I + (at level 20, format "l ↦[ ip ] -") : bi_scope. + +(** Socket points-to (LaTeX: [\hookrightarrow]) *) +Notation "z ↪[ ip ]{ q } s" := + (mapsto_socket ip z q s) + (at level 20, q at level 50, format "z ↪[ ip ]{ q } s") : bi_scope. +Notation "z ↪[ ip ] s" := (z ↪[ ip ]{1} s)%I (at level 20) : bi_scope. + +(** Messages points-to for groups *) +Notation "sag ⤳*{ q } s" := + (mapsto_messages sag q false false s) + (at level 20, q at level 50, format "sag ⤳*{ q } s") : bi_scope. +Notation "sag ⤳* s" := (sag ⤳*{ 1 } s)%I (at level 20) : bi_scope. +Notation "sag ⤳*[ bs , br ]{ q } s" := + (mapsto_messages sag q bs br s) + (at level 20, q at level 50, format "sag ⤳*[ bs , br ]{ q } s") : bi_scope. +Notation "sag ⤳*[ bs , br ] s" := + (sag ⤳*[bs,br]{ 1 } s)%I (at level 20) : bi_scope. + +Notation "sag ⤇* Φ" := (si_pred sag Φ) (at level 20). + +(** Singleton messages points-to *) +Notation "sa ⤳1{ q } s" := + ({[sa]} ⤳*{ q } s)%I + (at level 20, q at level 50, format "sa ⤳1{ q } s") : bi_scope. +Notation "sa ⤳1 s" := (sa ⤳1{ 1 } s)%I (at level 20) : bi_scope. +Notation "sa ⤳1[ bs , br ]{ q } s" := + ({[sa]} ⤳*[ bs , br ]{ q } s)%I + (at level 20, q at level 50, format "sa ⤳1[ bs , br ]{ q } s") : bi_scope. +Notation "sa ⤳1[ bs , br ] s" := (sa ⤳1[bs,br]{ 1 } s)%I (at level 20) : bi_scope. +Notation "sa ⤇1 Φ" := ({[sa]} ⤇* Φ) (at level 20). + +Section singleton_to_singleton_connectives. + Context `{LM: LiveModel aneris_lang (joint_model M Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + Definition message_history_singleton (sag : socket_address_group) q + (send_obs receive_obs : bool) rt : iProp Σ := + sag ⤳*[send_obs, receive_obs]{q} (rt.1,rt.2) ∗ + ([∗ set] m ∈ rt.1, socket_address_group_own {[m_sender m]}). + + Definition from_singleton (φ : message → iProp Σ) : message → iProp Σ := + (λ m, socket_address_group_own {[m_sender m]} ∗ φ m)%I. + + Definition socket_interp_singleton (sag : socket_address_group) φ : iProp Σ := + sag ⤇* (from_singleton φ). + +End singleton_to_singleton_connectives. + +(* Singleton to singleton messages points-to *) +Notation "sa ⤳{ q } s" := + (message_history_singleton {[sa]} q false false s)%I + (at level 20, q at level 50, format "sa ⤳{ q } s") : bi_scope. +Notation "sa ⤳ s" := (sa ⤳{ 1 } s)%I (at level 20) : bi_scope. +Notation "sa ⤳[ bs , br ]{ q } s" := + (message_history_singleton {[sa]} q bs br s)%I + (at level 20, q at level 50, format "sa ⤳[ bs , br ]{ q } s") : bi_scope. +Notation "sa ⤳[ bs , br ] s" := (sa ⤳[bs,br]{ 1 } s)%I (at level 20) : bi_scope. +Notation "sa ⤇ Φ" := (socket_interp_singleton {[sa]} Φ) (at level 20). + +(* Message group equivalence *) +Notation "m1 ≡g{ sagT , sagR } m2" := (message_group_equiv sagT sagR m1 m2) (at level 10). + +(* Valid group membership *) +Notation "sa ∈g sag" := (elem_of_group sa sag) (at level 10). +Notation "sa ∉g sag" := (not_elem_of_group sa sag) (at level 10). + +Lemma node_gnames_auth_init `{anerisPreG Mdl Σ} : + ⊢ |==> ∃ γ, own (A:=authR node_gnames_mapUR) γ (● (to_agree <$> ∅)). +Proof. apply own_alloc. by apply auth_auth_valid. Qed. + +Lemma saved_si_init `{anerisPreG Mdl Σ} : + ⊢ |==> ∃ γ, own (A := authR socket_interpUR) γ (● (to_agree <$> ∅) ⋅ + ◯ (to_agree <$> ∅)). +Proof. apply own_alloc. by apply auth_both_valid_discrete. Qed. + +Lemma saved_si_update `{anerisG Mdl Σ} (A : gset socket_address_group) γsi f : + ⊢ own (A := authR socket_interpUR) γsi (● (to_agree <$> ∅)) ∗ + own (A := authR socket_interpUR) γsi (◯ (to_agree <$> ∅)) ==∗ + ∃ M : gmap socket_address_group gname, + ⌜elements (dom M) ≡ₚ elements A⌝ ∗ + own (A:=authR socket_interpUR) γsi (● (to_agree <$> M)) ∗ + [∗ map] a ↦ γ ∈ M, own (A:=authR socket_interpUR) + γsi (◯ {[ a := (to_agree γ) ]}) ∗ + saved_pred_own (A:=message) γ (DfracDiscarded) (f a). + iIntros "[Hsi Hsi']". + pose proof (NoDup_elements A) as Hnd. + iInduction (elements A) as [|a l] "IHl" forall "Hsi Hsi'". + - iModIntro. iExists ∅. + rewrite big_sepM_empty fmap_empty; iFrame. + iPureIntro. by rewrite dom_empty_L. + - inversion Hnd as [|? ? ? Hrd']; subst. + iMod ("IHl" $! Hrd' with "Hsi Hsi'") as (M HMl) "[HM HML]"; iFrame. + iMod (saved_pred_alloc (f a) (DfracDiscarded)) as (γ) "Hγ"; [done|]. + assert (a ∉ dom M) as Hnm. + { by rewrite -elem_of_elements HMl. } + iMod (own_update (A:=authR socket_interpUR) _ _ + (● (<[a := to_agree γ]>(to_agree <$> M)) ⋅ + (◯ ({[a := to_agree γ]}))) with "HM") as "[HM Hγ']". + { apply auth_update_alloc. rewrite -insert_empty. + rewrite /ε /=. apply alloc_local_update; [|done]. + apply (not_elem_of_dom (D:=gset socket_address_group)). + rewrite dom_fmap. apply Hnm. } + iModIntro. + iExists (<[a:= γ]> M). + rewrite !fmap_insert; iFrame. + rewrite big_sepM_insert; + [|by apply (not_elem_of_dom (D:=gset socket_address_group))]. + iFrame. iPureIntro. + rewrite dom_insert_L elements_union_singleton //. auto. +Qed. + +Lemma allocated_address_groups_init `{anerisPreG Mdl Σ} A : + ⊢ |==> ∃ γ, own (A := agreeR (gsetUR socket_address_group)) γ (to_agree A). +Proof. by apply own_alloc. Qed. + +(** Free ports lemmas *) +Lemma free_ports_auth_init `{anerisPreG Σ Mdl} Ps : + ⊢ |==> ∃ γ, own (A:=authUR (gmapUR ip_address (gset_disjUR port))) γ (● (GSet <$> Ps)). +Proof. + apply own_alloc. apply auth_auth_valid. + induction Ps using map_ind; [done|]. + rewrite fmap_insert. by apply insert_valid. +Qed. + +Lemma free_ports_alloc_pre `{anerisPreG Σ Mdl} γ P ip ports : + P !! ip = None → + own (A:=authUR (gmapUR ip_address (gset_disjUR port))) γ (● P) ==∗ + own (A:=authUR (gmapUR ip_address (gset_disjUR port))) γ (● <[ip := GSet ports]>P) ∗ + own (A:=authUR (gmapUR ip_address (gset_disjUR port))) γ (◯ ({[ ip := GSet ports]})). +Proof. + iIntros (?) "HP"; rewrite /free_ports_auth /free_ports. + iMod (own_update _ _ (● _ ⋅ ◯ {[ ip := (GSet ports)]}) with "HP") + as "[HP Hip]"; last by iFrame. + by apply auth_update_alloc, alloc_singleton_local_update. +Qed. + +Lemma free_ports_auth_init_multiple `{anerisPreG Σ Mdl} P : + ⊢ |==> ∃ γ, own (A:=authUR (gmapUR ip_address (gset_disjUR port))) γ + (● (GSet <$> P)) ∗ + [∗ map] ip ↦ ports ∈ P, + own (A:=authUR (gmapUR ip_address (gset_disjUR port))) γ + (◯ ({[ ip := GSet ports]})). +Proof. + iInduction P as [|ip ps P Hnin] "IHP" using map_ind. + { iMod (free_ports_auth_init ∅) as (γ) "Hγ". iModIntro. iExists _. + rewrite fmap_empty. iFrame. + rewrite big_sepM_empty. done. } + iMod "IHP" as (γ) "[HP Hps]". + iMod (free_ports_alloc_pre γ (GSet <$> P) ip ps with "HP") as "[HP Hp]". + { rewrite lookup_fmap. rewrite Hnin. done. } + iModIntro. iExists γ. rewrite fmap_insert. + iFrame. rewrite big_sepM_insert; [|done]. iFrame. +Qed. + +Lemma free_ips_init `{anerisPreG Mdl Σ} (ips : gset ip_address) : + ⊢ |==> ∃ γ, own γ (● GSet ips) ∗ [∗ set] ip ∈ ips, own γ (◯ GSet {[ ip ]}). +Proof. + iMod (own_alloc (● GSet (∅:gset ip_address))) as (γ) "HM"; [by apply auth_auth_valid|]. + iAssert (|==> + ∃ M : gset ip_address, + (⌜elements M ≡ₚ elements ips⌝) ∗ + own γ (● GSet M) ∗ + [∗ set] ip ∈ M, own γ (◯ GSet {[ ip ]}))%I + with "[HM]" as "HF". + { pose proof (NoDup_elements ips) as Hnd. + iInduction (elements ips) as [|a l] "IHl". + - iModIntro. iExists ∅. + rewrite big_sepS_empty. iFrame. + by iPureIntro. + - inversion Hnd as [|? ? ? Hrd']; subst. + iMod ("IHl" $! Hrd' with "HM") as (M HMl) "[HM HML]"; iFrame. + assert (a ∉ M) as Hnm. + { by rewrite -elem_of_elements HMl. } + iMod (own_update _ _ (● GSet ({[a]} ∪ M) ⋅ ◯ GSet {[a]}) with "HM") + as "[HM Ha]". + { apply auth_update_alloc, gset_disj_alloc_empty_local_update. + set_solver. } + iModIntro. + iExists ({[a]} ∪ M); iFrame. + iSplit; first by iPureIntro; + rewrite elements_union_singleton // HMl. + rewrite big_sepS_insert //. iFrame. } + iMod "HF" as (M HMF) "[? ?]". + replace M with ips; first by iModIntro; iExists _; iFrame. + apply set_eq => x. + rewrite -!elem_of_elements HMF //. +Qed. + +Lemma socket_address_group_ctx_init `{anerisPreG Mdl Σ} + (sags : gset socket_address_group) : + all_disjoint sags → + ⊢ |==> ∃ γ, + own (A:=(authR socket_address_groupUR)) γ + (● (DGSets sags)). +Proof. + intros Hdisj. + iMod (own_alloc (● (DGSets sags))) as (γ) "Hsags". + { apply auth_auth_valid. done. } + iModIntro. iExists _. iFrame. +Qed. + +Lemma socket_address_group_own_alloc_subseteq_pre `{anerisPreG Mdl Σ} + γ (sags sags' : gset socket_address_group) : + sags' ⊆ sags → + own (A:=(authR socket_address_groupUR)) γ + (● (DGSets sags)) ==∗ + own (A:=(authR socket_address_groupUR)) γ + (● (DGSets sags)) ∗ + own (A:=(authR socket_address_groupUR)) γ + (◯ (DGSets sags')). +Proof. + iIntros (Hle) "Hsags". + iDestruct (own_valid with "Hsags") as %Hvalid. + setoid_rewrite auth_auth_valid in Hvalid. + setoid_rewrite disj_gsets_valid in Hvalid. + iMod (own_update with "Hsags") as "[Hsags Hsags']". + { apply auth_update_alloc. + eapply (disj_gset_alloc_empty_local_update sags sags'). + { by eapply all_disjoint_subseteq. } + by eapply have_disj_elems_subseteq. } + iFrame. + by rewrite subseteq_union_1_L. +Qed. + +Lemma socket_address_group_init `{anerisPreG Mdl Σ} + (sags : gset socket_address_group) : + all_disjoint sags → + ⊢ |==> ∃ γ, own (A:=(authR socket_address_groupUR)) γ + (● (DGSets sags)) ∗ + own (A:=(authR socket_address_groupUR)) γ + (◯ (DGSets sags)). +Proof. + intros Hdisj. + iMod socket_address_group_ctx_init as (γ) "Hauth"; [done|]. + iMod (socket_address_group_own_alloc_subseteq_pre with "Hauth") + as "[Hauth Hown]"; [done|]. + iModIntro. iExists γ. by iFrame. +Qed. + +Lemma socket_address_group_own_big_sepS `{anerisPreG Mdl Σ} + γ + (sags : gset socket_address_group) : + ⊢ own (A:=(authR socket_address_groupUR)) γ + (◯ (DGSets sags)) -∗ + [∗ set] sag ∈ sags, own (A:=(authR socket_address_groupUR)) γ + (◯ (DGSets {[sag]})). +Proof. + iInduction (sags) as [|sag sags Hsag] "IH" using (set_ind_L); [by eauto|]. + iIntros "H". + setoid_rewrite <-disj_gsets_op_union. + rewrite auth_frag_op. + iDestruct "H" as "[H1 H2]". + rewrite big_sepS_union; last by set_solver. + rewrite big_sepS_singleton. + iFrame. by iApply "IH". +Qed. + +Lemma socket_address_group_own_subseteq_pre `{anerisPreG Mdl Σ} + γ (sags sags' : gset socket_address_group) : + sags' ⊆ sags → + own (A:=(authR socket_address_groupUR)) γ + (◯ (DGSets sags)) -∗ + own (A:=(authR socket_address_groupUR)) γ + (◯ (DGSets sags')). +Proof. + iIntros (Hle) "Hsags". + apply subseteq_disjoint_union_L in Hle. + destruct Hle as [Z [-> Hdisj]]. + setoid_rewrite <-disj_gsets_op_union. + iDestruct "Hsags" as "[H1 H2]". + iFrame. +Qed. + +Lemma messages_ctx_init `{anerisPreG Mdl Σ} + (gs : gset socket_address_group) + (γo γs γr : gname) + (As Ar: gset socket_address_group) : + ([∗ set] sag ∈ gs, own γo (◯ (DGSets {[sag]}))) -∗ + own γs (to_agree As) -∗ own γr (to_agree Ar) ==∗ + ∃ γ, + gen_heap_light_ctx + γ (gset_to_gmap ((∅, ∅) : message_soup * message_soup) gs) ∗ + [∗ set] sag ∈ gs, + ∃ As' Ar', own γs (to_agree As') ∗ own γr (to_agree Ar') ∗ + (⌜(sag ∈ As' ↔ ((bool_decide (sag ∈ As)) = true)) ∧ + (sag ∈ Ar' ↔ ((bool_decide (sag ∈ Ar)) = true))⌝) ∗ + own γo (◯ (DGSets {[ sag ]})) ∗ + lmapsto γ sag 1 (∅, ∅). +Proof. + iIntros "#Hgs #HAs #HAr". + iMod (gen_heap_light_init + (∅ : gmap socket_address_group (message_soup * message_soup))) as (γ) "Hctx". + + set σ' := (gset_to_gmap ((∅, ∅) : message_soup * message_soup) gs). + iMod (gen_heap_light_alloc_gen _ σ' with "Hctx") as "[Hctx HB]". + { apply map_disjoint_empty_r. } + rewrite map_union_empty. + iModIntro. iExists _. iFrame. + subst σ'. + iAssert ([∗ map] l↦v ∈ gset_to_gmap ((∅, ∅) : message_soup * message_soup) gs, lmapsto γ l 1 (∅, ∅))%I + with "[HB]" as "HB". + { iApply big_sepM_mono; simpl; last done. + intros ??; rewrite lookup_gset_to_gmap_Some; intros [? <-]; done. } + rewrite big_sepM_dom. + rewrite dom_gset_to_gmap. + iDestruct (big_sepS_sep with "[HB]") as "Hgs'". + { iFrame "HB". iFrame "Hgs". } + iApply (big_sepS_impl with "Hgs'"). + iIntros "!#" (x Hin) "[Hsag Hx]". + iExists _, _; iFrame "#". iFrame. + rewrite !bool_decide_eq_true; eauto. +Qed. + +Lemma steps_init `{anerisPreG FM Σ} n : + ⊢ |==> ∃ γ, mono_nat_auth_own γ 1 n ∗ mono_nat_lb_own γ n. +Proof. iApply mono_nat_own_alloc. Qed. + +(* Local Lemma roles_auth_extend_pre `{anerisPreG Σ} γ A roles : *) +(* roles ## A → *) +(* own (A := live_roleUR ()) γ (● GSet A) ==∗ *) +(* own (A := live_roleUR _) γ (● GSet (roles ∪ A)) ∗ *) +(* own (A := live_roleUR _) γ (◯ GSet roles). *) +(* Proof. *) +(* iIntros (Hnin) "Hauth". *) +(* iMod (own_update with "Hauth") as "[$ $]"; [|done]. *) +(* apply auth_update_alloc. *) +(* apply gset_disj_alloc_empty_local_update. *) +(* set_solver. *) +(* Qed. *) + +Lemma unallocated_init `{anerisPreG FM Σ} (A : gset socket_address_group) : + ⊢ |==> ∃ γ, own γ (● (GSet A)) ∗ own γ (◯ (GSet A)). +Proof. + iMod (own_alloc (● (GSet (∅:gset socket_address_group)) ⋅ ◯ (GSet ∅))) as (γ) "[Ha Hf]". + { by apply auth_both_valid. } + iExists γ. + iInduction A as [|a A Hnin] "IH" using set_ind_L. + - iModIntro. iFrame. + - iMod ("IH" with "Ha Hf") as "[Ha Hf]". + iMod (own_update with "Ha") as "[Ha Hf']". + { apply (auth_update_alloc _ (GSet ({[a]} ∪ A))). + apply gset_disj_alloc_empty_local_update. + set_solver. } + iModIntro. iFrame. + rewrite -gset_op -gset_disj_union; [|set_solver]. + rewrite auth_frag_op. + iApply own_op. + iFrame. +Qed. + +Lemma alloc_evs_init `{anerisPreG Mdl Σ} (lbls : gset string) : + ⊢ |==> ∃ γ, + own (A := authUR (gmapUR string (exclR aneris_eventsO))) + γ (● (Excl <$> (gset_to_gmap [] lbls))) ∗ + [∗ set] lbl ∈ lbls, + own (A := authUR (gmapUR string (exclR aneris_eventsO))) + γ (◯ {[ lbl := Excl [] ]}). +Proof. + iMod (own_alloc (A := authUR (gmapUR string (exclR aneris_eventsO))) (● ∅)) + as (γ) "HM"; [by apply auth_auth_valid|]. + iAssert (|==> + ∃ M : gset string, + ⌜elements M ≡ₚ elements lbls⌝ ∗ + own (A := authUR (gmapUR string (exclR aneris_eventsO))) + γ (● (Excl <$> (gset_to_gmap [] M))) ∗ + [∗ set] lbl ∈ M, + own (A := authUR (gmapUR string (exclR aneris_eventsO))) + γ (◯ {[ lbl := Excl [] ]}))%I + with "[HM]" as "HF". + { pose proof (NoDup_elements lbls) as Hnd. + iInduction (elements lbls) as [|lbl lbls'] "IHl". + - iModIntro. iExists ∅. + rewrite gset_to_gmap_empty fmap_empty big_sepS_empty. iFrame. + by iPureIntro. + - inversion Hnd as [|? ? ? Hrd']; subst. + iMod ("IHl" $! Hrd' with "HM") as (M HMl) "[HM HML]"; iFrame. + assert (lbl ∉ M) as Hnm. + { by rewrite -elem_of_elements HMl. } + iMod (own_update (A := authUR (gmapUR string (exclR aneris_eventsO))) + _ _ (● (Excl <$> gset_to_gmap [] ({[lbl]} ∪ M)) ⋅ + ◯ {[ lbl := Excl [] ]}) with "HM") + as "[HM Ha]". + { rewrite gset_to_gmap_union_singleton fmap_insert. + apply auth_update_alloc. apply: alloc_singleton_local_update; last done. + rewrite lookup_fmap. by eapply lookup_gset_to_gmap_None in Hnm as ->. } + iModIntro. + iExists ({[lbl]} ∪ M); iFrame. + iSplit; first by iPureIntro; rewrite elements_union_singleton // HMl. + rewrite big_sepS_insert //. iFrame. } + iMod "HF" as (M HMF) "[? ?]". + replace M with lbls; first by iModIntro; iExists _; iFrame. + apply set_eq => x. + rewrite -!elem_of_elements HMF //. +Qed. + +Lemma sendreceive_evs_init `{anerisPreG Mdl Σ} (sags : gset socket_address_group) : + ⊢ |==> ∃ γ, own + (A := authUR (gmapUR socket_address_group (exclR aneris_eventsO))) + γ (● (Excl <$> (gset_to_gmap [] sags))) ∗ + [∗ set] sag ∈ sags, + own (A := authUR (gmapUR socket_address_group (exclR aneris_eventsO))) + γ (◯ {[ sag := Excl [] ]}). +Proof. + iMod (own_alloc + (A := authUR (gmapUR socket_address_group (exclR aneris_eventsO))) (● ∅)) + as (γ) "HM"; [by apply auth_auth_valid|]. + iAssert (|==> + ∃ M : gset socket_address_group, + ⌜elements M ≡ₚ elements sags⌝ ∗ + own (A := authUR (gmapUR socket_address_group (exclR aneris_eventsO))) + γ (● (Excl <$> (gset_to_gmap [] M))) ∗ + [∗ set] sa ∈ M, + own (A := authUR (gmapUR socket_address_group (exclR aneris_eventsO))) + γ (◯ {[ sa := Excl [] ]}))%I + with "[HM]" as "HF". + { pose proof (NoDup_elements sags) as Hnd. + iInduction (elements sags) as [|sag sags'] "IHl". + - iModIntro. iExists ∅. + rewrite gset_to_gmap_empty fmap_empty big_sepS_empty. iFrame. + by iPureIntro. + - inversion Hnd as [|? ? ? Hrd']; subst. + iMod ("IHl" $! Hrd' with "HM") as (M HMl) "[HM HML]"; iFrame. + assert (sag ∉ M) as Hnm. + { by rewrite -elem_of_elements HMl. } + iMod (own_update (A := authUR (gmapUR socket_address_group (exclR aneris_eventsO))) + _ _ (● (Excl <$> gset_to_gmap [] ({[sag]} ∪ M)) ⋅ + ◯ {[ sag := Excl [] ]}) with "HM") + as "[HM Ha]". + { rewrite gset_to_gmap_union_singleton fmap_insert. + apply auth_update_alloc. apply: alloc_singleton_local_update; last done. + rewrite lookup_fmap. by eapply lookup_gset_to_gmap_None in Hnm as ->. } + iModIntro. + iExists ({[sag]} ∪ M); iFrame. + iSplit; first by iPureIntro; rewrite elements_union_singleton // HMl. + rewrite big_sepS_insert //. iFrame. } + iMod "HF" as (M HMF) "[? ?]". + replace M with sags; first by iModIntro; iExists _; iFrame. + apply set_eq => x. + rewrite -!elem_of_elements HMF //. +Qed. + +Section resource_lemmas. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + #[global] Instance mapsto_node_persistent ip γn : Persistent (mapsto_node ip γn). + Proof. rewrite mapsto_node_eq /mapsto_node_def. apply _. Qed. + #[global] Instance mapsto_node_timeless ip γn : Timeless (mapsto_node ip γn). + Proof. rewrite mapsto_node_eq /mapsto_node_def. apply _. Qed. + + #[global] Instance is_node_persistent ip : Persistent (is_node ip). + Proof. apply _. Qed. + + Lemma mapsto_node_agree ip γn γn' : + mapsto_node ip γn -∗ mapsto_node ip γn' -∗ ⌜γn = γn'⌝. + Proof. + iIntros "H1 H2". + rewrite /node_gnames_auth mapsto_node_eq. + iDestruct (own_valid_2 with "H1 H2") as %Hvalid. + iPureIntro. + rewrite -auth_frag_op singleton_op in Hvalid. + rewrite auth_frag_valid singleton_valid in Hvalid. + by apply (to_agree_op_inv_L (A := node_gnamesO)). + Qed. + + Lemma node_gnames_valid ip γn m : + node_gnames_auth m -∗ mapsto_node ip γn -∗ ⌜m !! ip = Some γn⌝. + Proof. + iIntros "H1 H2". + iCombine "H2" "H1" as "H". + rewrite /node_gnames_auth mapsto_node_eq -own_op own_valid. + iDestruct "H" as %HvalidR. iPureIntro. + revert HvalidR. + rewrite comm auth_both_valid_discrete. + rewrite singleton_included_l. + intros [[y [Hlookup Hless]] Hvalid]. + assert (Hvalidy := lookup_valid_Some _ ip y Hvalid Hlookup). + revert Hlookup. + rewrite lookup_fmap fmap_Some_equiv. + intros [v' [Hl Heq]]. revert Hless Heq. + rewrite Some_included_total. + destruct (to_agree_uninj y Hvalidy) as [y' <-]. + rewrite to_agree_included. + intros Heq%leibniz_equiv Heq'%(to_agree_inj y' v')%leibniz_equiv. + by simplify_eq. + Qed. + + Lemma node_gnames_alloc γn m ip : + m !! ip = None → + node_gnames_auth m ==∗ node_gnames_auth (<[ip:=γn]> m) ∗ mapsto_node ip γn. + Proof. + iIntros (?) "Hm". rewrite mapsto_node_eq /mapsto_node_def. + iMod (own_update _ _ + (● (to_agree <$> (<[ip:=γn]> m)) ⋅ (◯ {[ ip := to_agree γn ]}) + : authR node_gnames_mapUR) with "Hm") as "[Hm Hn]". + { rewrite fmap_insert. eapply auth_update_alloc. + apply (alloc_singleton_local_update + (A := (agreeR node_gnamesO))); last done. + rewrite -not_elem_of_dom dom_fmap_L not_elem_of_dom //. } + iModIntro. iFrame. + Qed. + + Lemma node_gnames_alloc_strong γs ip σ s : + γs !! ip = None → + node_gnames_auth γs ==∗ ∃ (γn : node_gnames), + node_gnames_auth (<[ip:=γn]>γs) ∗ + mapsto_node ip γn ∗ + heap_ctx γn σ ∗ + ([∗ map] l ↦ v ∈ σ, l ↦[ip] v) ∗ + sockets_ctx γn s ∗ + ([∗ map] sh ↦ sb ∈ s, sh ↪[ip] sb). + Proof. + iIntros (HNone) "Hγs". + iMod (gen_heap_light_init_strong σ) as (γσ) "[Hσ Hσs]". + iMod (gen_heap_light_init_strong s) as (γss) "[Hs Hss]". + set (γn := Node_gname γσ γss). + iMod (node_gnames_alloc γn with "Hγs") as "[Hγs #Hγ]"; [done|]. + iModIntro. iExists γn. iFrame "#∗". + iSplitL "Hσs". + - iApply (big_sepM_impl with "Hσs"). + iIntros "!>" (k x HSome) "Hmapsto". iExists γn. iFrame "#∗". + - iApply (big_sepM_impl with "Hss"). + iIntros "!>" (k x HSome) "Hmapsto". iExists γn. iFrame "#∗". + Qed. + + Lemma node_gnames_alloc_strong_multiple σ γs' : + dom $ state_heaps σ = dom $ state_sockets σ → + dom γs' ## dom $ state_heaps σ → + node_gnames_auth γs' ==∗ + ∃ γs, ⌜dom γs = dom $ state_heaps σ⌝ ∗ ⌜dom γs = dom $ state_sockets σ⌝ ∗ + node_gnames_auth (γs' ∪ γs) ∗ + ([∗ set] ip ∈ dom $ state_heaps σ, is_node ip) ∗ + ([∗ map] ip↦γ ∈ γs, mapsto_node ip γ ∗ + heap_ctx γ (state_heaps σ !!! ip) ∗ + sockets_ctx γ (fst <$> (state_sockets σ !!! ip))) ∗ + ([∗ set] ip ∈ dom $ state_heaps σ, ([∗ map] l ↦ v ∈ state_heaps σ !!! ip, l ↦[ip] v) ∗ + ([∗ map] sh ↦ sb ∈ state_sockets σ !!! ip, sh ↪[ip] sb.1)). + Proof. + assert (∃ ips, ips = dom $ state_heaps σ) as [ips Hips]; [by eexists|]. + revert Hips. + iInduction ips as [|ip ips Hnin] "IHips" using set_ind_L forall (γs' σ); + iIntros (Hdom1 Hdom2 Hdom3) "Hγs". + { iModIntro. iExists ∅. + rewrite right_id_L. + iSplit; [iPureIntro; set_solver|]. + iSplit; [iPureIntro; set_solver|]. + iFrame. rewrite -!Hdom1. + rewrite !big_sepS_empty. + rewrite !big_sepM_empty. done. } + assert (γs' !! ip = None). + { simpl in *. + apply not_elem_of_dom. rewrite -Hdom1 in Hdom3. set_solver. } + iMod (node_gnames_alloc_strong _ ip with "Hγs") + as (γn) "(Hγs & #Hip & Hσ & Hσs & Hs & Hss)"; [done|]. + iMod ("IHips" $! _ + (mkState (delete ip $ state_heaps σ) + (delete ip $ state_sockets σ) + (state_ms σ)) with "[] [] [] Hγs") as "Hγs". + { iPureIntro. set_solver. } + { iPureIntro. set_solver. } + { iPureIntro. set_solver. } + iDestruct "Hγs" as (γs Hdom1' Hdom2') "(Hγs & #Hip' & Hσ' & Hσs')". + simpl. + iModIntro. iExists (<[ip:=γn]> γs). + iSplit. + { iPureIntro. rewrite -Hdom1. set_solver. } + iSplit. + { iPureIntro. rewrite -Hdom2 -Hdom1. set_solver. } + iSplitL "Hγs". + { rewrite !insert_union_singleton_l. + replace ({[ip := γn]} ∪ γs' ∪ γs) with (γs' ∪ ({[ip := γn]} ∪ γs)). + iFrame. + rewrite assoc. f_equiv. + rewrite map_union_comm; [done|]. + apply map_disjoint_alt. intros. + destruct (decide (ip = i)). + - set_solver. + - right. by rewrite lookup_insert_ne. } + rewrite !dom_delete_L. rewrite -!Hdom1. + replace (({[ip]} ∪ ips) ∖ {[ip]}) with ips by set_solver. + rewrite !big_sepS_union; [|set_solver|set_solver]. + rewrite !big_sepS_singleton. + assert (γs !! ip = None). + { simpl in *. rewrite dom_delete_L in Hdom1'. + apply not_elem_of_dom. rewrite Hdom1'. set_solver. } + rewrite big_sepM_insert; [|done]. + iFrame "#∗". + iSplit; [iExists _; iFrame "#"|]. + iSplitL "Hσ'". + { iApply (big_sepM_impl with "Hσ'"). + iIntros "!>" (k x HSome) "[Hnode [Hheap Hsocket]]". + simpl in *. assert (k ≠ ip) by set_solver. + rewrite lookup_total_delete_ne; [|done]. + rewrite lookup_total_delete_ne; [|done]. iFrame. } + iSplitL "Hss". + { rewrite big_sepM_fmap. iFrame. } + iApply (big_sepS_impl with "Hσs'"). + iIntros "!>" (x Hin) "[Hσ Hs]". + assert (x ≠ ip) by set_solver. + rewrite lookup_total_delete_ne; [|done]. + rewrite lookup_total_delete_ne; [|done]. + iFrame. + Qed. + + Lemma node_ctx_init σ s : + ⊢ |==> ∃ (γn : node_gnames), heap_ctx γn σ ∗ sockets_ctx γn s. + Proof. + iMod (gen_heap_light_init σ) as (γh) "Hh". + iMod (gen_heap_light_init s) as (γs) "Hs". + iExists {| heap_name := γh; sockets_name := γs |}. + iModIntro. iFrame. + Qed. + + Lemma is_node_alloc σ ip : + σ !! ip = None → + node_gnames_auth σ ==∗ + ∃ γn, node_gnames_auth (<[ip := γn]>σ) ∗ is_node ip. + Proof. + iIntros (Hnone) "Hauth". + iMod (node_ctx_init ∅ ∅) as (γn) "[Hh Hs]". + iMod (node_gnames_alloc γn _ ip with "[$]") as "[Hmp Hγn]"; [done|]. + iExists _. iFrame. iExists _. by iFrame. + Qed. + + Lemma is_node_alloc_multiple σ : + dom (state_heaps σ) = dom (state_sockets σ) → + node_gnames_auth ∅ ==∗ + ∃ γs, ⌜dom γs = dom $ state_heaps σ⌝ ∗ ⌜dom γs = dom $ state_sockets σ⌝ ∗ + node_gnames_auth γs ∗ + ([∗ set] ip ∈ (dom $ state_heaps σ), is_node ip) ∗ + ([∗ map] ip↦γ ∈ γs, mapsto_node ip γ ∗ + heap_ctx γ (state_heaps σ !!! ip) ∗ + sockets_ctx γ (fst <$> (state_sockets σ !!! ip))) ∗ + ([∗ set] ip ∈ (dom $ state_heaps σ), ([∗ map] l ↦ v ∈ state_heaps σ !!! ip, l ↦[ip] v) ∗ + ([∗ map] sh ↦ sb ∈ state_sockets σ !!! ip, sh ↪[ip] sb.1)). + Proof. + iIntros (Hdom) "Hγs". + iMod (node_gnames_alloc_strong_multiple σ ∅ with "Hγs") as (γs) "H"; + [done|set_solver|]. + rewrite left_id_L. + iModIntro. iExists γs. done. + Qed. + + #[global] Instance mapsto_heap_timeless l ip q v : + Timeless (l ↦[ip]{q} v). + Proof. apply _. Qed. + #[global] Instance mapsto_heap_fractional l ip v : + Fractional (λ q, l ↦[ip]{q} v)%I. + Proof. + rewrite /mapsto_heap /Fractional=> p q. iSplit. + - iDestruct 1 as (?) "[#? [H1 H2]]". + iSplitL "H1"; iExists _; eauto. + - iDestruct 1 as "[H1 H2]". + iDestruct "H1" as (?) "[Hn1 Hp]". + iDestruct "H2" as (?) "[Hn2 Hq]". + iDestruct (mapsto_node_agree with "Hn1 Hn2") as %->. + iExists _. iFrame. + Qed. + #[global] Instance mapsto_heap_as_fractional l ip q v : + AsFractional (l ↦[ip]{q} v) (λ q, l ↦[ip]{q} v)%I q. + Proof. split; [done|]. apply _. Qed. + + #[global] Instance mapsto_socket_timeless z ip q s : + Timeless (z ↪[ ip ]{ q } s). + Proof. apply _. Qed. + + #[global] Instance mapsto_socket_fractional z ip s : + Fractional (λ q, z ↪[ip]{q} s)%I. + Proof. + rewrite /Fractional=> p q. iSplit. + - iDestruct 1 as (?) "[#? [H1 H2]]". + iSplitL "H1"; iExists _; eauto. + - iDestruct 1 as "[H1 H2]". + iDestruct "H1" as (?) "[Hn1 Hp]". + iDestruct "H2" as (?) "[Hn2 Hq]". + iDestruct (mapsto_node_agree with "Hn1 Hn2") as %->. + iExists _. iFrame. + Qed. + + #[global] Instance mapsto_socket_as_fractional z ip q s : + AsFractional (z ↪[ip]{q} s) (λ q, z ↪[ip]{q} s)%I q. + Proof. split; [done|]. apply _. Qed. + + Lemma observed_send_agree A A' : + observed_send_groups A -∗ observed_send_groups A' -∗ ⌜A = A'⌝. + Proof. + iIntros "H1 H2". + iDestruct (own_valid_2 with "H1 H2") as %?%to_agree_op_valid%leibniz_equiv. + done. + Qed. + + Lemma observed_receive_agree A A' : + observed_receive_groups A -∗ observed_receive_groups A' -∗ ⌜A = A'⌝. + Proof. + iIntros "H1 H2". + iDestruct (own_valid_2 with "H1 H2") as %?%to_agree_op_valid%leibniz_equiv. + done. + Qed. + + #[global] Instance mapsto_messages_timeless a q bs br s : + Timeless (a ⤳*[bs, br]{ q } s). + Proof. apply _. Qed. + + Lemma socket_address_group_ctx_valid sags : + socket_address_group_ctx sags -∗ + ⌜all_disjoint sags⌝ ∗ ⌜set_Forall is_ne sags⌝. + Proof. + iIntros "[%Hne [Hsags _]]". + iDestruct (own_valid with "Hsags") as %Hvalid. + pose proof (auth_auth_valid {| dgsets_of := sags |}) as [H _]. + apply H in Hvalid. + pose proof (disj_gsets_valid sags) as [H' _]. + apply H' in Hvalid. + done. + Qed. + + Lemma socket_address_groups_ctx_own sags : + socket_address_group_ctx sags -∗ + socket_address_groups_own sags. + Proof. by iIntros "[_ [_ Hsags]]". Qed. + + #[global] Instance socket_address_group_own_timeless sag : + Timeless (socket_address_group_own sag). + Proof. apply _. Qed. + + #[global] Instance socket_address_group_own_persistent sag : + Persistent (socket_address_group_own sag). + Proof. apply _. Qed. + + #[global] Instance socket_address_groups_own_timeless sags : + Timeless (socket_address_groups_own sags). + Proof. apply _. Qed. + + #[global] Instance socket_address_groups_own_persistent sags : + Persistent (socket_address_groups_own sags). + Proof. apply _. Qed. + + Lemma socket_address_group_ctx_update sags sags' : + all_disjoint sags' → have_disj_elems sags' sags → + set_Forall is_ne sags' → + socket_address_group_ctx sags ==∗ + socket_address_group_ctx (sags' ∪ sags) ∗ + socket_address_groups_own sags'. + Proof. + iIntros (Hdisj Helems Hne) "[%Hne' [Hctx #Hsag]]". + iMod (own_update with "Hctx") as "[Hsags #Hsag']". + { apply auth_update_alloc. + by eapply disj_gset_alloc_empty_local_update. } + iModIntro. iFrame "#∗". + iSplit; [by iPureIntro; apply set_Forall_union|]. + rewrite -disj_gsets_op_union auth_frag_op. + iApply own_op. by iFrame "#". + Qed. + + Lemma socket_address_group_own_agree sa sag1 sag2 : + sa ∈ sag1 → sa ∈ sag2 → + socket_address_group_own sag1 -∗ + socket_address_group_own sag2 -∗ + ⌜sag1 = sag2⌝. + Proof. + iIntros (Hin1 Hin2) "Hsag1 Hsag2". + iDestruct (own_valid_2 with "Hsag1 Hsag2") as %Hvalid. + rewrite -auth_frag_op in Hvalid. + pose proof (auth_frag_valid (A:=socket_address_groupUR) + (DGSets {[sag1]} ⋅ DGSets {[sag2]})) + as [Hv _]. + apply Hv in Hvalid. + apply disj_gsets_valid_op in Hvalid. + destruct Hvalid as (Hgdisj & Hgdisj' & Hdisjgg'). + destruct (Hdisjgg' sag1 sag2) as [-> | H2]; + [ set_solver | set_solver | done | set_solver ]. + Qed. + + Lemma socket_address_groups_own_union sags1 sags2 : + ⊢ socket_address_groups_own sags1 ∗ + socket_address_groups_own sags2 + ∗-∗ + socket_address_groups_own (sags1 ∪ sags2). + Proof. + rewrite /socket_address_groups_own. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + rewrite own_op. + eauto. + Qed. + + Lemma socket_address_group_own_subseteq sags1 sags2 : + sags2 ⊆ sags1 → + socket_address_groups_own sags1 -∗ + socket_address_groups_own sags2. + Proof. + iIntros (Hle) "Hsags". + rewrite /socket_address_groups_own. + apply subseteq_disjoint_union_L in Hle. + destruct Hle as [Z [-> Hdisj]]. + setoid_rewrite <-disj_gsets_op_union. + iDestruct "Hsags" as "[H1 H2]". + iFrame. + Qed. + + #[global] Instance mapsto_messages_fractional sag bs br s : + Fractional (λ q, sag ⤳*[bs,br]{q} s)%I. + Proof. + intros p q. + iSplit. + - iDestruct 1 as (? ?) "(#?&#?&#?&(#Hsag & [H1 H2]))". + iFrame. iSplit; iExists _, _; iFrame "#". + - iIntros "[Hp Hq]". + iDestruct "Hp" as (? ?) "(#HAs1&#HAr1&#?&#Hsag&Hp)". + iDestruct "Hq" as (? ?) "(#HAs2&#HAr2&#?&_&Hq)". + iExists _,_; iFrame "#∗". + Qed. + + #[global] Instance mapsto_messages_as_fractional sag q bs br s : + AsFractional (sag ⤳*[bs,br]{q} s) (λ q, sag ⤳*[bs,br]{q} s)%I q. + Proof. split; [ done | by apply mapsto_messages_fractional ]. Qed. + + Lemma messages_mapsto_observed sag q bs br s : + sag ⤳*[bs, br]{ q } s -∗ + sag ⤳*[bs, br]{ q } s ∗ + ∃ As Ar, observed_send_groups As ∗ observed_receive_groups Ar ∗ + socket_address_group_own sag ∗ + ⌜(sag ∈ As ↔ (bs = true)) ∧ (sag ∈ Ar ↔ (br = true))⌝. + Proof. + iDestruct 1 as (? ?) "(#?&#?&%H&#Hown&?)". + destruct H as [HAs HAr]. + iSplitL; first by iExists _,_; eauto. + iExists _, _; eauto. + Qed. + + Lemma heap_mapsto_agree l ip q1 q2 v1 v2 : + l ↦[ip]{q1} v1 -∗ l ↦[ip]{q2} v2 -∗ ⌜v1 = v2⌝. + Proof. + iIntros "(% & Hn1 & Hv1) (% & Hn2 & Hv2)". + iDestruct (mapsto_node_agree with "Hn1 Hn2") as %->. + iApply (lmapsto_agree with "Hv1 Hv2"). + Qed. + + Lemma socket_mapsto_agree z ip q1 q2 s1 s2 : + z ↪[ip]{q1} s1 -∗ z ↪[ip]{q2} s2 -∗ ⌜s1 = s2⌝. + Proof. + iIntros "(% & Hn1 & Hv1) (% & Hn2 & Hv2)". + iDestruct (mapsto_node_agree with "Hn1 Hn2") as %->. + iApply (lmapsto_agree with "Hv1 Hv2"). + Qed. + + Lemma messages_mapsto_valid sag bs br R T: + sag ⤳*[bs, br] (R, T) -∗ + socket_address_group_own sag. + Proof. by iDestruct 1 as (??) "(?&?&?&$&?&$)". Qed. + + Lemma messages_mapsto_update sag bs br R T R' T' mhm : + sag ⤳*[bs, br] (R, T) ∗ messages_ctx mhm ==∗ + sag ⤳*[bs, br] (R', T') ∗ messages_ctx (<[sag := (R',T')]>mhm). + Proof. + iIntros "(Hl & Ha)". + iDestruct "Hl" as (??) "(?&?&?&#Hsag&Hl)". + iMod (gen_heap_light_update _ mhm sag (R,T) (R', T') + with "Ha Hl") as "[Ha Hf]". + iModIntro. + iFrame "#∗". iExists As, Ar. iFrame "#∗". + Qed. + + Lemma messages_mapsto_ctx_valid sag bs br R T mh : + sag ⤳*[bs, br] (R, T) -∗ messages_ctx mh -∗ ⌜mh !! sag = Some (R,T)⌝. + Proof. + iIntros "Hf Ha". + iDestruct "Hf" as (??) "(?&?&?&?&Hf&Hown)". + by iApply (gen_heap_light_valid with "Ha Hf"). + Qed. + + Lemma messages_mapsto_agree sa sag1 sag2 bs br bs' br' R T R' T' q1 q2 : + sa ∈ sag1 → sa ∈ sag2 → + sag1 ⤳*[bs, br]{q1} (R, T) -∗ sag2 ⤳*[bs', br']{q2} (R', T') -∗ + ⌜sag1 = sag2 ∧ bs = bs' ∧ br = br' ∧ R = R' ∧ T = T'⌝. + Proof. + iIntros (Hin1 Hin2) "Ha1 Ha2". + iDestruct "Ha1" as (??) "(HAs1&HAr1&[%Heq1 %Heq2]&(#Hsag1 & Ha1 & Hown1))". + iDestruct "Ha2" as (??) "(HAs2&HAr2&[%Heq3 %Heq4]&(#Hsag2 & Ha2 & Hown2))". + iDestruct (observed_send_agree with "HAs1 HAs2") as %->. + iDestruct (observed_receive_agree with "HAr1 HAr2") as %->. + iDestruct (socket_address_group_own_agree with "Hsag1 Hsag2") + as %<-; [ done | done | ]. + revert Heq3; rewrite Heq1; intros Heq3. + revert Heq4; rewrite Heq2; intros Heq4. + assert (bs = bs' ∧ br = br') as [-> ->]. + { destruct bs; destruct bs'; destruct br; destruct br'; intuition done. } + iDestruct (lmapsto_agree with "Ha1 Ha2") as %?. + by simplify_eq. + Qed. + + Lemma unallocated_groups_split A1 A2 : + A1 ## A2 → + ⊢ unallocated_groups (A1 ∪ A2) ∗-∗ + unallocated_groups A1 ∗ unallocated_groups A2. + Proof. + intros Hdisj. + rewrite -gset_op {1}/unallocated_groups -gset_disj_union; [|done]. + iSplit. + - iIntros "H". iDestruct "H" as "[H1 H2]". by iFrame. + - iIntros "[H1 H2]". rewrite auth_frag_op. iApply own_op. iFrame. + Qed. + + Lemma unallocated_split A1 A2 : + A1 ## A2 → + ⊢ unallocated (A1 ∪ A2) ∗-∗ + unallocated A1 ∗ unallocated A2. + Proof. + rewrite /unallocated. rewrite to_singletons_union. + intros Hdisj. + iApply unallocated_groups_split. + set_solver. + Qed. + + Lemma unallocated_update_alloc A B : + A ## B → + ⊢ unallocated_groups_auth A ==∗ + unallocated_groups_auth (A ∪ B) ∗ unallocated_groups B. + Proof. + iIntros (Hdisj) "HA". + iMod (own_update with "HA") as "[HA HB]". + { by apply auth_update_alloc, gset_disj_alloc_empty_local_update. } + iModIntro. replace (B ∪ A) with (A ∪ B) by set_solver. by iFrame. + Qed. + + Lemma unallocated_update_dealloc A B : + ⊢ unallocated_groups_auth A ∗ unallocated_groups B ==∗ + unallocated_groups_auth (A ∖ B). + Proof. + iIntros "[HA HB]". + rewrite /unallocated_groups_auth /unallocated_groups. + iDestruct (own_valid_2 with "HA HB") as %Hvalid. + rewrite auth_both_valid_discrete in Hvalid. + destruct Hvalid as [Hincluded Hvalid]. + rewrite gset_disj_included in Hincluded. + apply subseteq_disjoint_union_L in Hincluded. + destruct Hincluded as [C [-> Hdisj]]. + rewrite -gset_disj_union; [|done]. + replace ((B ∪ C) ∖ B) with C; [|set_solver]. + iMod (own_update_2 with "HA HB") as "HA"; [|done]. + apply auth_update_dealloc. + apply gset_disj_dealloc_empty_local_update. + Qed. + + Lemma unallocated_update_dealloc_union A B : + A ## B → + ⊢ unallocated_groups_auth (A ∪ B) ∗ unallocated_groups B ==∗ + unallocated_groups_auth A. + Proof. + iIntros (Hdisj) "[HA HB]". + replace (A ∪ B) with (B ∪ A) by set_solver. + rewrite /unallocated_groups_auth -gset_op -gset_disj_union; [|done]. + iMod (own_update_2 with "HA HB") as "HA"; [|done]. + apply auth_update_dealloc. + by apply gset_disj_dealloc_empty_local_update. + Qed. + + #[global] Instance saved_pred_proper `{savedPredG Σ A} n γ dq : + Proper ((dist n) ==> (dist n)) + (@saved_pred_own Σ A _ γ dq : (A -d> iPropO Σ) -d> iPropO Σ). + Proof. + intros Φ Ψ Hps. + f_equiv. + destruct n; [apply dist_later_0| ]. + apply dist_later_S. eapply dist_lt; eauto. + Qed. + + #[global] Instance saved_pred_proper' `{savedPredG Σ A} γ dq : + Proper ((≡) ==> (≡)) (@saved_pred_own Σ A _ γ dq + : (A -d> iPropO Σ) -d> iPropO Σ). + Proof. solve_proper. Qed. + #[global] Instance si_pred_prop `{anerisG _ _ LM Σ} a : + Proper ((≡) ==> (≡)) (si_pred a). + Proof. solve_proper. Qed. + + Lemma free_ip_included A ip : + free_ips_auth A -∗ free_ip ip -∗ ⌜ip ∈ A⌝. + Proof. + iIntros "HF Hip". iDestruct (own_valid_2 with "HF Hip") as %[_ Hi]. + iPureIntro. + move: (Hi 0%nat). rewrite /= left_id. + move => [? [/to_agree_injN /discrete + /leibniz_equiv_iff <- [/gset_disj_included ? _]]]. + by apply elem_of_subseteq_singleton. + Qed. + + Lemma free_ip_dealloc A ip : + free_ips_auth A -∗ free_ip ip ==∗ free_ips_auth (A ∖ {[ ip ]}). + Proof. + iIntros "HF Hip". + iDestruct (free_ip_included with "HF Hip") as %Hip. + replace A with ({[ ip ]} ∪ (A ∖ {[ ip ]})) at 1; last first. + { rewrite (comm_L _ {[ _ ]}) difference_union_L + -(comm_L _ {[ _ ]}) subseteq_union_1_L //. + by apply elem_of_subseteq_singleton. } + iCombine "HF" "Hip" as "H". + iMod (own_update with "H") as "H"; last by iFrame "H". + apply auth_update_dealloc. + rewrite -gset_disj_union; last by set_solver. + by apply gset_disj_dealloc_empty_local_update. + Qed. + + Lemma free_ports_included P ip ports : + free_ports_auth P -∗ + free_ports ip ports -∗ + ∃ ports', ⌜P !! ip = Some (GSet ports') ∧ ports ⊆ ports'⌝. + Proof. + iIntros "HP Hip"; rewrite /free_ports_auth /free_ports. + iDestruct (own_valid_2 with "HP Hip") as + %[[y [Hy1%leibniz_equiv Hy2]]%singleton_included_l Hv] + %auth_both_valid_discrete. + iPureIntro. + revert Hy2; rewrite Some_included_total. + destruct y as [ports'|]. + - eexists; split; first by rewrite Hy1. + by apply gset_disj_included. + - by specialize (Hv ip); rewrite Hy1 in Hv. + Qed. + + Lemma free_ports_split ip ports ports' : + ports ## ports' → + free_ports ip (ports ∪ ports') ⊣⊢ + free_ports ip ports ∗ free_ports ip ports'. + Proof. + intros ?. + by rewrite /free_ports -gset_disj_union // + -own_op -auth_frag_op singleton_op. + Qed. + + Lemma free_ports_alloc P ip ports : + ip ∉ (dom P) → + free_ports_auth P ==∗ + free_ports_auth (<[ ip := GSet ports ]>P) ∗ free_ports ip ports. + Proof. + iIntros (?) "HP"; rewrite /free_ports_auth /free_ports. + iMod (own_update _ _ (● _ ⋅ ◯ {[ ip := (GSet ports)]}) with "HP") + as "[HP Hip]"; last by iFrame. + apply auth_update_alloc, alloc_singleton_local_update; last done. + by eapply (not_elem_of_dom (D := gset ip_address)). + Qed. + + Lemma free_ports_dealloc P ip ports : + free_ports_auth P -∗ + free_ports ip ports ==∗ + ∃ ports', ⌜P !! ip = Some (GSet ports') ∧ + ports ⊆ ports'⌝ ∗ + free_ports_auth (<[ip := GSet (ports' ∖ ports)]> P). + Proof. + iIntros "HP Hip". + iDestruct (free_ports_included with "HP Hip") as (ports') "[% %]". + iMod (own_update_2 _ _ _ + (● <[ip := GSet (ports' ∖ ports)]>P ⋅ + ◯ <[ ip := GSet ∅ ]>{[ ip := (GSet ports)]}) + with "HP Hip") + as "[? ?]". + { apply auth_update. + eapply insert_local_update; + [done|eapply (lookup_singleton (M := gmap _))|]. + apply gset_disj_dealloc_local_update. } + by iExists _; iFrame. + Qed. + + Lemma socket_interp_alloc sag φ sis : + sis !! sag = None → + socket_address_group_own sag -∗ + saved_si_auth sis ==∗ + ∃ γsi, saved_si_auth (<[sag:=γsi]>sis) ∗ sag ⤇* φ. + Proof. + iIntros (Hnone) "Hsag Hsi". + iMod (saved_pred_alloc φ DfracDiscarded) as (γsi) "Hsipred"; [done|]. + iMod (own_update _ _ + (● (to_agree <$> (<[sag:=γsi]> sis)) ⋅ + ◯ {[ sag := to_agree γsi ]} + : authR socket_interpUR) with "Hsi") as "[Hsi #sip]". + { rewrite fmap_insert. + apply auth_update_alloc, alloc_singleton_local_update; [|done]. + rewrite lookup_fmap Hnone //. } + iModIntro. iExists _. iFrame. iExists _. iFrame "#∗". + Qed. + + Lemma socket_interp_agree (sag1 sag2 : gset socket_address) + ϕ ψ (sa : socket_address) x : + sa ∈ sag1 → sa ∈ sag2 → + sag1 ⤇* ϕ -∗ sag2 ⤇* ψ -∗ ⌜sag1 = sag2⌝ ∗ ▷ (ϕ x ≡ ψ x). + Proof. + iIntros (Hin1 Hin2) "Hsag1 Hsag2". + iDestruct ("Hsag1") as (γ1) "[Hsag1 [Hγ1 Hϕ1]]". + iDestruct ("Hsag2") as (γ2) "[Hsag2 [Hγ2 Hϕ2]]". + iDestruct (socket_address_group_own_agree with "Hsag1 Hsag2") as %<- ; + [ done | done | ]. + iSplit; [ done | ]. + iDestruct (own_valid_2 with "Hγ1 Hγ2") as %Hvalid. + rewrite -auth_frag_op singleton_op in Hvalid. + apply auth_frag_valid_1, singleton_valid in Hvalid. + apply (to_agree_op_inv_L γ1 γ2) in Hvalid. + rewrite Hvalid. + iDestruct (saved_pred_agree _ _ _ _ _ x with "Hϕ1 Hϕ2") as "H". + iExact "H". + Qed. + + Lemma socket_interp_pred_equiv sa sag1 sag2 Φ Ψ : + sa ∈ sag1 → sa ∈ sag2 → + sag1 ⤇* Φ -∗ sag2 ⤇* Ψ -∗ ▷ (Φ ≡ Ψ). + Proof. + iIntros (Hin1 Hin2) "#H1 #H2". + rewrite discrete_fun_equivI; iIntros (?). + iDestruct (socket_interp_agree with "H1 H2") as "[_ $]"; done. + Qed. + + Lemma socket_interp_own sag Φ : + sag ⤇* Φ -∗ socket_address_group_own sag. + Proof. by iDestruct 1 as (γ) "[Hown H]". Qed. + + Lemma alloc_evs_lookup M lbl evs : + alloc_evs_ctx M -∗ alloc_evs lbl evs -∗ ⌜M !! lbl = Some evs⌝. + Proof. + iIntros "H1 H2". + iDestruct (own_valid_2 with "H1 H2") as %[Hvl ?]%auth_both_valid_discrete. + iPureIntro. + apply singleton_included_exclusive_l in Hvl; [|apply _|done]. + apply leibniz_equiv in Hvl. + rewrite lookup_fmap in Hvl. + revert Hvl; case: (M !! lbl); intros; simplify_eq/=; done. + Qed. + + Lemma alloc_evs_update M lbl evs evs' : + alloc_evs_ctx M -∗ + alloc_evs lbl evs ==∗ + alloc_evs_ctx (<[lbl := evs']>M) ∗ alloc_evs lbl evs'. + Proof. + iIntros "H1 H2". + iDestruct (alloc_evs_lookup with "H1 H2") as %Hlu. + iMod (own_update_2 (A := authUR (gmapUR string (exclR aneris_eventsO))) + _ _ _ (● (Excl <$> <[lbl := evs']>M) ⋅ + ◯ {[lbl := Excl evs']}) with "H1 H2") as "[$ $]"; + last done. + apply auth_update. + rewrite fmap_insert. + apply: singleton_local_update; last by apply exclusive_local_update. + rewrite lookup_fmap Hlu; done. + Qed. + + Lemma sendon_evs_lookup M sag evs : + sendon_evs_ctx M -∗ sendon_evs_groups sag evs -∗ ⌜M !! sag = Some evs⌝. + Proof. + iIntros "H1 H2". + iDestruct "H2" as "[Hsag H2]". + iDestruct (own_valid_2 with "H1 H2") as %[Hvl ?]%auth_both_valid_discrete. + iPureIntro. + apply singleton_included_exclusive_l in Hvl; [|apply _|done]. + apply leibniz_equiv in Hvl. + rewrite lookup_fmap in Hvl. + revert Hvl; case: (M !! sag); intros; simplify_eq/=; done. + Qed. + + Lemma sendon_evs_update M sag evs evs' : + sendon_evs_ctx M -∗ + sendon_evs_groups sag evs ==∗ + sendon_evs_ctx (<[sag := evs']>M) ∗ sendon_evs_groups sag evs'. + Proof. + iIntros "H1 H2". + iDestruct (sendon_evs_lookup with "H1 H2") as %Hlu. + iDestruct "H2" as "[#Hsag H2]". + iMod (own_update_2 (A := authUR (gmapUR socket_address_group (exclR aneris_eventsO))) + _ _ _ (● (Excl <$> <[sag := evs']>M) ⋅ + ◯ {[sag := Excl evs']}) with "H1 H2") as "[H1 H2]". + { + apply auth_update. + rewrite fmap_insert. + apply: singleton_local_update; last by apply exclusive_local_update. + rewrite lookup_fmap Hlu; done. + } + iModIntro. iFrame "#∗". + Qed. + + Lemma receiveon_evs_lookup M sag evs : + receiveon_evs_ctx M -∗ receiveon_evs_groups sag evs -∗ ⌜M !! sag = Some evs⌝. + Proof. + iIntros "H1 H2". + iDestruct "H2" as "[Hsag H2]". + iDestruct (own_valid_2 with "H1 H2") as %[Hvl ?]%auth_both_valid_discrete. + iPureIntro. + apply singleton_included_exclusive_l in Hvl; [|apply _|done]. + apply leibniz_equiv in Hvl. + rewrite lookup_fmap in Hvl. + revert Hvl; case: (M !! sag); intros; simplify_eq/=; done. + Qed. + + Lemma receiveon_evs_update M sag evs evs' : + receiveon_evs_ctx M -∗ + receiveon_evs_groups sag evs ==∗ + receiveon_evs_ctx (<[sag := evs']>M) ∗ receiveon_evs_groups sag evs'. + Proof. + iIntros "H1 H2". + iDestruct (receiveon_evs_lookup with "H1 H2") as %Hlu. + iDestruct "H2" as "[#Hsag H2]". + iMod (own_update_2 (A := authUR (gmapUR socket_address_group (exclR aneris_eventsO))) + _ _ _ (● (Excl <$> <[sag := evs']>M) ⋅ + ◯ {[sag := Excl evs']}) with "H1 H2") as "[H1 H2]". + { + apply auth_update. + rewrite fmap_insert. + apply: singleton_local_update; last by apply exclusive_local_update. + rewrite lookup_fmap Hlu; done. + } + iModIntro. iFrame "#∗". + Qed. + + Lemma elem_of_group_unfold sa sag : + sa ∈g sag -∗ ⌜sa ∈ sag⌝ ∗ socket_address_group_own sag. + Proof. eauto. Qed. + + #[global] Instance elem_of_group_persistent sa sag : Persistent (sa ∈g sag). + Proof. apply _. Qed. + + Lemma elem_of_group_eq sa sag1 sag2 : + sa ∈g sag1 -∗ sa ∈g sag2 -∗ ⌜sag1 = sag2⌝. + Proof. + iIntros "[%Hsag1 H1] [%Hsag2 H2]". + by iApply (socket_address_group_own_agree with "H1 H2"). + Qed. + + Lemma elem_of_group_neq sa1 sa2 sag1 sag2 : + sag1 ≠ sag2 → sa1 ∈g sag1 -∗ sa2 ∈g sag2 -∗ ⌜sa1 ≠ sa2⌝. + Proof. + iIntros (Hneq) "[%Hsag1 H1] [%Hsag2 H2]". + iDestruct (own_valid_2 with "H1 H2") as %Hvalid. + rewrite -auth_frag_op in Hvalid. + pose proof (auth_frag_valid (A:=socket_address_groupUR) + (DGSets {[sag1]} ⋅ DGSets {[sag2]})) + as [Hv _]. + apply Hv in Hvalid. + apply disj_gsets_valid_op in Hvalid. + destruct Hvalid as [_ [_ Hvalid]]. + iPureIntro. + destruct (Hvalid sag1 sag2); [set_solver|set_solver| | ]. + - done. + - set_solver. + Qed. + + Lemma steps_lb_valid n m : + steps_auth n -∗ steps_lb m -∗ ⌜m ≤ n⌝. + Proof. + iIntros "Hauth Hlb". + iDestruct (mono_nat_lb_own_valid with "Hauth Hlb") as %[_ H]. + iPureIntro. lia. + Qed. + + Lemma steps_lb_get n : + steps_auth n -∗ steps_lb n. + Proof. iApply mono_nat_lb_own_get. Qed. + + Lemma steps_lb_le (n n' : nat) : + (n' ≤ n)%nat → steps_lb n -∗ steps_lb n'. + Proof. intros Hle. by iApply mono_nat_lb_own_le. Qed. + + Lemma steps_auth_update (n n' : nat) : + (n ≤ n')%nat → steps_auth n ==∗ steps_auth n' ∗ steps_lb n'. + Proof. intros Hle. by iApply mono_nat_own_update. Qed. + + Lemma steps_auth_update_S n : + steps_auth n ==∗ steps_auth (S n). + Proof. + iIntros "Hauth". + iMod (mono_nat_own_update with "Hauth") as "[$ _]"; [lia|done]. + Qed. +End resource_lemmas. diff --git a/fairneris/aneris_lang/state_interp/messages_history.v b/fairneris/aneris_lang/state_interp/messages_history.v new file mode 100644 index 0000000..8336d0e --- /dev/null +++ b/fairneris/aneris_lang/state_interp/messages_history.v @@ -0,0 +1,219 @@ +From stdpp Require Import fin_maps gmap. +From iris.bi.lib Require Import fractional. +From iris.proofmode Require Import tactics. +From iris.base_logic.lib Require Import saved_prop gen_heap. +From fairneris.prelude Require Import collect. +From fairneris.lib Require Import gen_heap_light. +From fairneris.aneris_lang Require Export aneris_lang network resources. +From fairneris.algebra Require Import disj_gsets. + +From RecordUpdate Require Import RecordSet. +Set Default Proof Using "Type". + +Import uPred. +Import RecordSetNotations. + +Definition messages_history := prod message_soup message_soup. + +Definition messages_history_map := gmap socket_address_group messages_history. + +Implicit Types mhm : messages_history_map. +Implicit Types rt : messages_history. + +(* The set of all received messages *) +Definition messages_received mhm := collect (λ _ rt, rt.1) mhm. + +Lemma elem_of_messages_received mhm : + ∀ m, m ∈ messages_received mhm ↔ + ∃ sa rt, mhm !! sa = Some rt ∧ m ∈ rt.1. +Proof. by apply elem_of_collect; eauto. Qed. + +(* The set of all transmitted messages *) +Definition messages_sent mhm := collect (λ _ rt, rt.2) mhm. + +Lemma elem_of_messages_sent mhm : + ∀ m, m ∈ messages_sent mhm ↔ + ∃ sa rt, mhm !! sa = Some rt ∧ m ∈ rt.2. +Proof. by apply elem_of_collect; eauto. Qed. + +(** Definitions for the message history *) +Definition messages_received_sent mhm : messages_history := + (messages_received mhm, messages_sent mhm). + +(* [m] has been received *) +Definition message_received m mhm := m ∈ (messages_received mhm). + +Lemma gset_to_gmap_singleton (v: message_soup * message_soup) + (a : socket_address) : gset_to_gmap v {[ a ]} = {[a := v]}. +Proof. + assert ({[a]} = {[a]} ∪ (∅: gset socket_address)) as -> by by set_solver. + by rewrite (gset_to_gmap_union_singleton v a ∅) gset_to_gmap_empty. +Qed. + +Lemma messages_received_init B : + messages_received (gset_to_gmap (∅, ∅) B) = ∅. +Proof. + rewrite /messages_received. + apply collect_empty_f. + intros ? []. + rewrite lookup_gset_to_gmap_Some. + by intros [? [=]]. +Qed. + +Lemma messages_sent_init B : + messages_sent (gset_to_gmap (∅, ∅) B) = ∅. +Proof. + rewrite /messages_sent. + apply collect_empty_f. + intros ? []. + rewrite lookup_gset_to_gmap_Some. + by intros [? [=]]. +Qed. + +Lemma messages_received_sent_init B : + messages_received_sent (gset_to_gmap (∅, ∅) B) = (∅, ∅). +Proof. + rewrite /messages_received_sent. f_equal. + - apply messages_received_init. + - apply messages_sent_init. +Qed. + +Lemma messages_sent_insert a R T mhm : + messages_sent (<[a:=(R, T)]> mhm) = T ∪ messages_sent (delete a mhm). +Proof. + rewrite /messages_sent. + apply collect_insert. +Qed. + +Lemma message_received_insert a msg R T mhm : + message_received msg (<[a:=(R, T)]> mhm) ↔ + msg ∈ R ∨ message_received msg (delete a mhm). +Proof. + rewrite /message_received /messages_received. + rewrite collect_insert //= elem_of_union //. +Qed. + +Lemma messages_received_insert a R T mhm : + messages_received (<[a:=(R, T)]> mhm) = R ∪ messages_received (delete a mhm). +Proof. + rewrite /messages_received. + apply collect_insert. +Qed. + +Lemma messages_sent_split a R T mhm : + mhm !! a = Some (R, T) → + messages_sent mhm = + T ∪ messages_sent (delete a mhm). +Proof. + intros. + assert (mhm = <[a := (R,T)]>mhm) as Heq by by rewrite insert_id. + rewrite {1} Heq. + apply collect_insert. +Qed. + +(* The messages in the logical map mhm, that tracks received and transmitted + messages, have coherent addresses. *) +Definition messages_addresses_coh mhm := + all_disjoint (dom mhm) ∧ + set_Forall (λ x, x ≠ ∅) (dom mhm) ∧ + ∀ sag R T, mhm !! sag = Some (R, T) → + (∀ m, m ∈ R → m_destination m ∈ sag) ∧ + (∀ m, m ∈ T → m_sender m ∈ sag). + +Definition messages_received_from_sent_coh mhm := + messages_received mhm ⊆ messages_sent mhm. + +Definition messages_received_from_sent_coh_aux mhm : Prop := + ∀ rt sag m, + m_destination m ∈ sag → + mhm !! sag = Some rt → + m ∈ rt.1 → + ∃ rt' sag', m_sender m ∈ sag' -> + mhm !! sag' = Some rt' ∧ m ∈ rt'.2. + +Lemma messages_received_from_sent_corrolary_coh mhm : + messages_addresses_coh mhm → + messages_received_from_sent_coh mhm → + messages_received_from_sent_coh_aux mhm. +Proof. + intros (Hdisj & Hne & Hacoh) Hrcoh. + intros rt sag m Hsag Hrt Hm. + assert (m ∈ (messages_received mhm)) as Hmr. + { by apply elem_of_collect; eauto. } + apply Hrcoh, elem_of_collect in Hmr as (sa & rt' & Hrt' & Hmt). + assert (mhm !! sa = Some (rt'.1, rt'.2)) as Hgas by by destruct rt'. + specialize (Hacoh sa rt'.1 rt'.2 Hgas) as (Hc1 & Hc2). + specialize (Hc2 m Hmt). set_solver. +Qed. + +Lemma messages_sent_dijsoint sag R T mhm : + mhm !! sag = Some (R, T) → + messages_addresses_coh mhm → + T ## messages_sent (delete sag mhm). +Proof. + intros Hsag (Hdisj & Hne & Hmcoh). + apply elem_of_disjoint. + intros m HmT Hms. + apply elem_of_collect in Hms as (sag' & (R',T') & Hsag' & Ht). + simplify_map_eq. + destruct (Hmcoh sag R T Hsag) as (HR & HT). + specialize (HT m HmT). + assert (sag ≠ sag') as Hineq. + { destruct (decide (sag = sag')); [ | done ]. + subst. by rewrite lookup_delete in Hsag'. } + rewrite lookup_delete_ne in Hsag'; last by set_solver. + assert (sag ## sag') as Hdisj'. + { assert (sag ∈ (dom mhm)) as Hin. + { apply elem_of_dom. eexists _. apply Hsag. } + assert (sag' ∈ (dom mhm)) as Hin'. + { apply elem_of_dom. eexists _. apply Hsag'. } + destruct (Hdisj sag sag' Hin Hin') as [H | H]; done. } + destruct (Hmcoh sag' R' T' Hsag') as (_ & HT'). + specialize (HT' m Ht). + set_solver. +Qed. + +Lemma messages_received_in mh sag m R T : + messages_addresses_coh mh → + mh !! sag = Some (R,T) → + m_destination m ∈ sag → + message_received m mh → + m ∈ R. +Proof. + intros [Hdisj [Hne Hmhcoh]] Hmh Hin Hrecv. + pose proof (Hmhcoh sag R T Hmh) as [Hdest Hsrc]. + apply elem_of_messages_received in Hrecv. + destruct Hrecv as (sa & rt & Hlookup & Hin'). + destruct rt as [R' T']. + pose proof (Hmhcoh sa R' T' Hlookup) as [Hdest' _]. + specialize (Hdest' m Hin'). + assert (sa = sag) as ->. + { eapply elem_of_all_disjoint_eq; eauto. + apply elem_of_dom. eexists _. set_solver. + apply elem_of_dom. eexists _. set_solver. } + simpl in *. + rewrite Hlookup in Hmh. + set_solver. +Qed. + +Lemma message_received_delete m mh sag1 sag2 : + messages_addresses_coh mh → + m_destination m ∈ sag1 → + sag1 ∈ dom mh → + sag2 ∈ dom mh → + sag1 ≠ sag2 → + message_received m mh → + message_received m (delete sag2 mh). +Proof. + rewrite /message_received. + rewrite !elem_of_messages_received. + intros (Hdisj & Hne & Hcoh) Hdest Hsag1 Hsag2 Hrecv + [sag [[R T] [Hlookup Hin]]]. + assert (sag = sag1) as ->. + { eapply elem_of_all_disjoint_eq; eauto. + apply elem_of_dom. eexists _. set_solver. + eapply Hcoh. eauto. eauto. } + eexists sag1, (R,T). + rewrite lookup_delete_ne; last done. + auto. +Qed. diff --git a/fairneris/aneris_lang/state_interp/state_interp.v b/fairneris/aneris_lang/state_interp/state_interp.v new file mode 100644 index 0000000..5fb619f --- /dev/null +++ b/fairneris/aneris_lang/state_interp/state_interp.v @@ -0,0 +1,1063 @@ +From stdpp Require Import fin_maps gmap. +From iris.bi.lib Require Import fractional. +From iris.proofmode Require Import tactics. +From iris.base_logic.lib Require Import saved_prop gen_heap. +From iris.algebra Require Import auth excl. +From fairneris.prelude Require Import collect gset_map gmultiset. +From trillium.program_logic Require Export weakestpre. +From fairneris Require Export fairness fuel env_model. +From fairneris Require Import retransmit_model. +From fairneris.lib Require Import gen_heap_light. +From fairneris.algebra Require Import disj_gsets. +From fairneris.aneris_lang Require Export + aneris_lang network resources events. +From fairneris.aneris_lang.state_interp Require Export + state_interp_def + state_interp_local_coh + state_interp_gnames_coh + state_interp_free_ips_coh + state_interp_network_sockets_coh + state_interp_socket_interp_coh + state_interp_messages_resource_coh + state_interp_messages_history_coh + state_interp_config_wp + state_interp_messages_history. + +From RecordUpdate Require Import RecordSet. +Set Default Proof Using "Type". + +Import uPred. +Import RecordSetNotations. + +Section aneris_state_interpretation. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + (** aneris_state_interp *) + Lemma mapsto_node_heap_valid n γs σ mh : + aneris_state_interp σ mh -∗ + mapsto_node n γs -∗ + ∃ h, ⌜state_heaps σ !! n = Some h⌝. + Proof. + iDestruct 1 as (Mγ ?????) "(Hnauth & Hscoh & Hlcoh & Hfip & Hmrcoh)". + iIntros "Hn". + iDestruct (node_gnames_valid with "Hnauth Hn") as %Hninm. + iDestruct (local_state_coh_heaps with "Hlcoh") as (h) "%"; [done|]. + eauto. + Qed. + + Lemma is_node_heap_valid n σ mh: + aneris_state_interp σ mh -∗ + is_node n -∗ + ∃ h, ⌜state_heaps σ !! n = Some h⌝. + Proof. + iIntros "Hσ". iDestruct 1 as (γs) "Hn". + iApply (mapsto_node_heap_valid with "[$] [$]"). + Qed. + + Lemma mapsto_node_valid_sockets n γs σ mh: + aneris_state_interp σ mh -∗ + mapsto_node n γs -∗ + ∃ Sn, ⌜state_sockets σ !! n = Some Sn⌝. + Proof. + iDestruct 1 as (Mγ ?????) "(Hnauth & Hscoh & Hlcoh & Hfip & Hmrcoh)". + iIntros "Hn". + iDestruct (node_gnames_valid with "Hnauth Hn") as %Hninm. + iDestruct (local_state_coh_sockets with "Hlcoh") as (h) "%"; [done|]. + eauto. + Qed. + + Lemma is_node_valid_sockets n σ mh: + aneris_state_interp σ mh -∗ + is_node n -∗ + ∃ Sn, ⌜state_sockets σ !! n = Some Sn⌝. + Proof. + iIntros "Hσ". iDestruct 1 as (γs) "Hn". + iApply (mapsto_node_valid_sockets with "[$] [$]"). + Qed. + + (* aneris_state_interp *) + Lemma aneris_state_interp_init_strong fips A Ps σ γs : + fips ## dom γs → + fips ## dom Ps → + (∀ ip : ip_address, ip ∈ fips → ip_is_free ip σ) → + (* Port coherence *) + ((∀ ip ps, (GSet <$> Ps) !! ip = Some (GSet ps) → + ∀ Sn, (state_sockets σ) !! ip = Some Sn → + ∀ p, p ∈ ps → port_not_in_use p Sn)) → + dom (state_heaps σ) = dom γs → + dom (state_sockets σ) = dom γs → + map_Forall (λ ip s, map_Forall (λ sh sb, sb.2 = []) s) (state_sockets σ) → + map_Forall (λ ip s, socket_handlers_coh s) (state_sockets σ) → + map_Forall (λ ip s, socket_addresses_coh s ip) (state_sockets σ) → + state_ms σ = ∅ → + node_gnames_auth γs -∗ + ([∗ map] ip↦γ ∈ γs, mapsto_node ip γ ∗ + heap_ctx γ (state_heaps σ !!! ip) ∗ + sockets_ctx γ (fst <$> (state_sockets σ !!! ip))) -∗ + messages_ctx (gset_to_gmap (∅, ∅) A) -∗ + socket_address_group_ctx A -∗ + unallocated_groups_auth A -∗ + saved_si_auth ∅ -∗ + free_ips_auth fips -∗ + free_ports_auth (GSet <$> Ps) -∗ + aneris_state_interp σ (∅, ∅). + Proof. + iIntros (Hfips Hfips' Hfips'' Hports Hheap Hskt Hskts Hskts_coh1 Hskts_coh2 Hms) + "Hγs_auth Hγs Hm Hsags Hunallocated Hsif HipsCtx HPiu_auth". + iDestruct (socket_address_group_ctx_valid with "Hsags") as %[Hdisj Hne]. + iExists _, _; iFrame. + iSplit. + (* messages_received_sent *) + { iPureIntro. apply messages_received_sent_init. } + iSplit. + (* gnames_coh *) + { iPureIntro. + (* TODO: Dont break abstraction here. *) + by rewrite /gnames_coh Hheap Hskt. } + iSplitR. + (* network_sockets_coh *) + { iPureIntro. + (* TODO: Dont break abstraction here. *) + rewrite /network_sockets_coh. + intros ip Sn HSome. + split. + { by apply Hskts_coh1 in HSome. } (* TODO: Dont take as input *) + split. + { apply Hskts in HSome. + rewrite /socket_messages_coh. + intros sh skt r sa HSn. apply HSome in HSn. simpl in *. + simplify_eq. set_solver. } + split. + { by apply Hskts_coh2 in HSome. } (* TODO: Dont take as input *) + apply Hskts in HSome. + rewrite /socket_unbound_empty_buf_coh. + intros sh skt r HSn. apply HSome in HSn. simpl in *. + simplify_eq. done. } + iSplitR. + (* messages_history_coh *) + { iPureIntro. + (* TODO: Dont break abstraction here. *) + rewrite /messages_history_coh. rewrite Hms. + split. + { rewrite /message_soup_coh. set_solver. } + split. + { rewrite /receive_buffers_coh. + intros ip Sn sh skt r m HSome. apply Hskts in HSome. + intro HSn. apply HSome in HSn. + set_solver. } + split. + { rewrite /messages_addresses_coh. + rewrite dom_gset_to_gmap. + split; [done|]. + split; [set_solver|]. + intros sag R T HSome. rewrite lookup_gset_to_gmap_Some in HSome. + destruct HSome. set_solver. } + rewrite /messages_received_from_sent_coh. + rewrite messages_received_init messages_sent_init. set_solver. } + (* socket_interp_coh *) + iDestruct (socket_address_groups_ctx_own with "Hsags") as "#Hsags'". + iSplitL "Hsags Hunallocated Hsif". + { by iApply (socket_interp_coh_init with "Hsags Hunallocated Hsif"). } + iSplitL "Hγs". + (* local_state_coh *) + { iApply (big_sepM_impl with "Hγs"). + iIntros "!>" (k x HSome) "(Hnode & Hheap & Hskt)". + assert (is_Some ((state_heaps σ) !! k)) as [y HSomey]. + { apply elem_of_dom. rewrite Hheap. apply elem_of_dom. by exists x. } + assert (is_Some ((state_sockets σ) !! k)) as [z HSomez]. + { apply elem_of_dom. rewrite Hskt. apply elem_of_dom. by exists x. } + iExists _, _. + iSplit; [done|]. + iSplit; [done|]. + apply lookup_total_correct in HSomey. + apply lookup_total_correct in HSomez. + simplify_eq. + iFrame. } + iSplitL "HipsCtx HPiu_auth". + (* free_ips_coh *) + { iApply (free_ips_coh_init_strong with "[$]"); [set_solver|done..]. } + (* messages_resource_coh *) + unfold socket_address_groups_own. + Set Printing All. + iPoseProof (messages_resource_coh_init with "Hsags'") as "S". + iFrame "#". + Qed. + + (* aneris_state_interp *) + Lemma aneris_state_interp_init ips A σ γs ip : + state_heaps σ = {[ip:=∅]} → + state_sockets σ = {[ip:=∅]} → + state_ms σ = ∅ → + ip ∉ ips → + node_gnames_auth {[ip:=γs]} -∗ + mapsto_node ip γs -∗ + heap_ctx γs ∅ -∗ + sockets_ctx γs ∅ -∗ + messages_ctx (gset_to_gmap (∅, ∅) A) -∗ + socket_address_group_ctx A -∗ + unallocated_groups_auth A -∗ + saved_si_auth ∅ -∗ + free_ips_auth ips -∗ + free_ports_auth ∅ -∗ + aneris_state_interp σ (∅, ∅). + Proof. + iIntros (Hste Hsce Hmse Hip) + "Hmp #Hn Hh Hs Hm Hsags Hunallocated Hsif HipsCtx HPiu". + iDestruct (socket_address_group_ctx_valid with "Hsags") as %[Hdisj Hne]. + iExists _, _; iFrame. + rewrite !Hste !Hsce !Hmse. + iSplit. + (* messages_received_sent *) + { iPureIntro. apply messages_received_sent_init. } + iSplit. + (* gnames_coh *) + { iPureIntro. apply gnames_coh_singleton. } + iSplitR. + (* network_sockets_coh *) + { iPureIntro. apply network_sockets_coh_init. } + iSplitR. + (* messages_history_coh *) + { iPureIntro. + apply messages_history_coh_init. + { by eapply all_disjoint_subseteq. } + intros x Hx. apply Hne. set_solver. } + (* socket_interp_coh *) + iDestruct (socket_address_groups_ctx_own with "Hsags") as "#Hsags'". + iSplitL "Hsags Hunallocated Hsif". + { by iApply (socket_interp_coh_init with "Hsags Hunallocated Hsif"). } + iSplitL "Hh Hs". + (* local_state_coh *) + { rewrite big_sepM_singleton /local_state_coh Hste Hsce !lookup_singleton. + iExists ∅, ∅. + rewrite fmap_empty. iFrame; iFrame "#"; eauto. } + iSplitL "HipsCtx HPiu". + (* free_ips_coh *) + { iApply (free_ips_coh_init with "[$]"). + rewrite /ip_is_free. intros. assert (ip ≠ ip0) by set_solver. + rewrite Hste Hsce. rewrite !lookup_insert_ne; set_solver. } + (* messages_resource_coh *) + iApply messages_resource_coh_init. + iFrame "#". + Qed. + + Lemma aneris_events_state_interp_init c As Ar lbls : + observed_send_groups As -∗ + observed_receive_groups Ar -∗ + own (A:=authUR socket_address_groupUR) aneris_socket_address_group_name + (◯ (DGSets (As ∪ Ar))) -∗ + sendon_evs_ctx (gset_to_gmap [] As) -∗ + receiveon_evs_ctx (gset_to_gmap [] Ar) -∗ + alloc_evs_ctx (gset_to_gmap [] lbls) -∗ + aneris_events_state_interp {tr[c]} . + Proof. + iIntros "#HAs #HAr #Hown Hs Hr Ha". + iExists _, _, lbls; iFrame "#". + erewrite (const_fn_to_gmap _ (λ sag, events_of_trace (sendonEV_groups sag) {tr[ c ]})); + first iFrame "Hs"; last by auto using events_of_singleton_trace. + erewrite (const_fn_to_gmap _ (λ sag, events_of_trace (receiveonEV_groups sag) {tr[ c ]})); + first iFrame "Hr"; last by auto using events_of_singleton_trace. + erewrite (const_fn_to_gmap _ (λ sa, events_of_trace (allocEV sa) {tr[ c ]})); + first iFrame "Ha"; last by auto using events_of_singleton_trace. + Qed. + + Lemma aneris_state_interp_free_ip_valid σ ip mh: + aneris_state_interp σ mh -∗ + free_ip ip -∗ + ⌜state_heaps σ !! ip = None ∧ + state_sockets σ !! ip = None⌝. + Proof. + iDestruct 1 as (mγ mn) "(?&?&%&?&?& Hsi & Hlcoh & Hfreeips & ?)". + iIntros "Hfip". + iDestruct "Hfreeips" + as (Fip Piu (Hdsj & HFip)) "[HfCtx HpCtx]". + iDestruct (free_ip_included with "HfCtx Hfip") as %Hin. + iPureIntro. by apply HFip. + Qed. + + Lemma aneris_state_interp_free_ports_valid σ a mh Sn: + state_sockets σ !! ip_of_address a = Some Sn → + aneris_state_interp σ mh -∗ + free_ports (ip_of_address a) {[port_of_address a]} -∗ + ⌜port_not_in_use (port_of_address a) Sn⌝. + Proof. + iDestruct 1 as (mγ mn) "(?&?&?&%&?&?& Hsi & Hlcoh & Hfreeips & ?)". + by iApply free_ips_coh_free_ports_valid. + Qed. + + Lemma aneris_state_interp_alloc_node σ ip ports mh : + aneris_state_interp σ mh ∗ free_ip ip ==∗ + ⌜network_sockets_coh (state_sockets σ)⌝ ∗ + is_node ip ∗ free_ports ip ports ∗ + aneris_state_interp + (σ <| state_heaps := <[ip:=∅]> (state_heaps σ)|> + <| state_sockets := <[ip:=∅]> (state_sockets σ) |>) + mh. + Proof. + iIntros "[Hσ Hfip]". + iDestruct (aneris_state_interp_free_ip_valid with "Hσ Hfip") + as "(% & %)". + iDestruct "Hσ" + as (mγ mh') + "(%Hhst & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & HFip & Hmctx & Hmres)". + iMod (free_ips_coh_alloc_node _ _ ports with "HFip Hfip") + as "[HFip Hports]". + iMod (node_ctx_init ∅ ∅) as (γn) "(Hh & Hs)". + assert (mγ !! ip = None) as Hnone by eapply gnames_coh_valid=>//. + iMod (node_gnames_alloc γn with "Hnauth") as "[Hnauth #Hγn]"; [done|]. + set σ' := (σ <| state_heaps := <[ip:=∅]> (state_heaps σ)|> + <| state_sockets := <[ip:=∅]> (state_sockets σ) |>). + iModIntro. iSplit; first done. + iSplitR. + { iExists _; eauto. } + iFrame "Hports". + iExists _, _. iFrame. + iSplit; [done|]. + iSplitR. + { iPureIntro. by apply gnames_coh_alloc_node. } + iSplitR. + { iPureIntro. by apply network_sockets_coh_alloc_node. } + iSplitR. + { iPureIntro. by apply messages_history_coh_alloc_node. } + iApply (big_sepM_local_state_coh_insert ip γn + with "[Hh Hs] [Hlcoh]"). + - rewrite lookup_insert //. + - iExists ∅, ∅. + iFrame. iFrame "#". simpl in *. by rewrite !lookup_insert. + - rewrite delete_insert //. + by iApply big_sepM_local_state_coh_alloc_node. + Qed. + + Lemma aneris_state_interp_heap_valid σ l n q v mh: + aneris_state_interp σ mh -∗ + l ↦[n]{q} v -∗ + ∃ h, ⌜state_heaps σ !! n = Some h ∧ h !! l = Some v⌝. + Proof. + iIntros "Hσ Hl". iDestruct "Hl" as (?) "[#Hn Hl]". + iDestruct (mapsto_node_heap_valid with "Hσ Hn") as (h) "%". + iDestruct "Hσ" + as (mγ mn) + "(? & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iDestruct (node_gnames_valid with "Hnauth Hn") as %?. + iDestruct (big_sepM_local_state_coh_delete with "Hlcoh") + as "(Hstate & Hlcoh)"; [done|]. + iApply (local_state_coh_valid_heap with "Hstate [Hl]"). + iExists _; eauto. + Qed. + + Lemma aneris_state_interp_alloc_heap σ n h l v mh : + let σ' := (σ <| state_heaps := <[n:= <[l:=v]>h]>(state_heaps σ) |>) in + state_heaps σ !! n = Some h → + h !! l = None → + is_node n -∗ + aneris_state_interp σ mh ==∗ aneris_state_interp σ' mh ∗ l ↦[n] v. + Proof. + simpl. iIntros (??) "Hn Hσ". + iDestruct "Hn" as (γs) "Hn". + iDestruct "Hσ" + as (mγ mn) + "(? & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iDestruct (node_gnames_valid with "Hnauth Hn") as %?. + iDestruct (big_sepM_local_state_coh_delete with "Hlcoh") + as "(Hstate & Hlcoh)"; [done|]. + iMod (local_state_coh_alloc_heap with "[Hn] Hstate") as "[Hstate' Hl]"; + [done|done|..]. + { by iExists _. } + iDestruct (big_sepM_local_state_coh_update_heap_notin n with "Hlcoh") + as "Hlcoh". + { apply lookup_delete. } + iDestruct (big_sepM_local_state_coh_insert with "[$] Hlcoh") + as "HX"; [done|]. + iModIntro. iFrame. iExists _, _. iFrame. simplify_eq /=. + iSplitR. + { iPureIntro. by eapply gnames_coh_update_heap. } + iSplitR; first done. + iSplitR; first done. + by iApply free_ips_coh_update_heap. + Qed. + + Lemma aneris_state_interp_heap_update σ1 n h l v1 v2 mh: + let σ2 := (σ1 <| state_heaps := <[n:=<[l:=v2]> h]> (state_heaps σ1) |>) in + state_heaps σ1 !! n = Some h → + aneris_state_interp σ1 mh ∗ l ↦[n] v1 ==∗ + aneris_state_interp σ2 mh ∗ l ↦[n] v2. + Proof. + simpl. iIntros (?) "[Hσ Hl]". + iDestruct "Hl" as (?) "[#Hn Hl]". + iDestruct "Hσ" + as (mγ mn) + "(? & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iDestruct (node_gnames_valid with "Hnauth Hn") as %?. + iDestruct (big_sepM_local_state_coh_delete with "Hlcoh") + as "(Hstate & Hlcoh)"; [done|]. + iMod (local_state_coh_update_heap with "[$Hstate Hl]") as "[Hstate' Hl]"; + [done|..]. + { iExists _; eauto. } + iDestruct (big_sepM_local_state_coh_update_heap_notin n with "Hlcoh") + as "Hlcoh". + { apply lookup_delete. } + iDestruct (big_sepM_local_state_coh_insert with "Hstate' Hlcoh") as "HX"; + [done|]. + iModIntro. iFrame. iExists _, _. iFrame. + iSplitR. + { iPureIntro. by eapply gnames_coh_update_heap. } + iSplitR; first done. + iSplitR; first done. + by iApply free_ips_coh_update_heap. + Qed. + + Lemma mapsto_socket_node q ip sh skt : + sh ↪[ip]{q} skt ⊢ ∃ γ, mapsto_node ip γ ∗ sh ↪[ip]{q} skt. + Proof. + iDestruct 1 as (γs) "[#Hip Hsh]". + iExists _; iSplitR; eauto with iFrame. + iExists _; by iFrame. + Qed. + + Lemma aneris_state_interp_socket_valid σ sh ip q skt mh : + aneris_state_interp σ mh -∗ + sh ↪[ip]{q} skt -∗ + ∃ Sn r, + ⌜state_sockets σ !! ip = Some Sn ∧ + Sn !! sh = Some (skt, r) ∧ + (saddress skt = None → r = [])⌝. + Proof. + iIntros "Hσ Hsh". + iDestruct "Hσ" + as (mγ mn) + "(? & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iPoseProof (mapsto_socket_node with "Hsh") as (γn) "(#Hip & Hsh)". + iDestruct (node_gnames_valid with "Hnauth Hip") as "%Hmin". + iPoseProof (local_state_coh_valid_sockets _ _ γn _ q with "[Hlcoh] [$Hsh]") + as (Sn r0) "(%Hp1 & %Hp2)". + - iDestruct (big_sepM_lookup with "Hlcoh") as "Hl"; done. + - iExists Sn, r0. + iPureIntro. + repeat split; try done. + specialize (Hnscoh ip Sn Hp1) as (?&?&?&Hb). + by eapply Hb. + Qed. + + Lemma aneris_state_interp_sblock_update σ1 a b sh skt Sn r mh : + let ip := ip_of_address a in + let S := <[ip := <[sh:= (skt<| sblock := b|>, r)]> Sn]>(state_sockets σ1) in + let σ2 := σ1 <| state_sockets := S |> in + state_sockets σ1 !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + aneris_state_interp σ1 mh -∗ + sh ↪[ip_of_address a] skt ==∗ + aneris_state_interp σ2 mh ∗ sh ↪[ip] (skt<| sblock := b |>). + Proof. + simpl. iIntros (HS HSn) "Hσ Hsh". + iDestruct "Hσ" + as (mγ mn) + "(? & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iDestruct (mapsto_socket_node with "Hsh") as (γs) "(#Hn & Hsh)". + iDestruct (node_gnames_valid with "Hnauth Hn") as %?. + iDestruct (big_sepM_local_state_coh_delete with "Hlcoh") + as "(Hstate & Hlcoh)"; [done|]. + iMod (local_state_coh_update_sblock with "[$Hstate Hsh]") as + "[Hstate' $]"; try done. + iDestruct + (big_sepM_local_state_coh_update_socket_notin with "Hlcoh") + as "Hlcoh". + { apply lookup_delete. } + iDestruct (big_sepM_local_state_coh_insert with "Hstate' Hlcoh") + as "Hlcoh"; [done|]. + iMod (free_ips_coh_update_sblock with "Hfreeips") as "Hfreeips"; eauto. + iModIntro. iExists mγ, _. iFrame. rewrite /set /=. + iSplit. + { iPureIntro; by eapply gnames_coh_update_sockets. } + iSplitR. + { iPureIntro. by apply network_sockets_coh_update_sblock. } + iPureIntro. destruct Hmhcoh as (Hc1&Hc2&Hc3&Hc4). split_and!; eauto. + by apply receive_buffers_coh_update_sblock. + Qed. + + Lemma aneris_state_interp_alloc_socket s ip sh Sn σ mh : + let σ' := σ <| state_sockets := + <[ip:=<[sh:=(s, [])]> Sn]> (state_sockets σ) |> in + state_sockets σ !! ip = Some Sn → + Sn !! sh = None → + saddress s = None → + is_node ip -∗ + aneris_state_interp σ mh ==∗ aneris_state_interp σ' mh ∗ sh ↪[ip] s. + Proof. + simpl. iIntros (???) "Hn Hσ". + iDestruct "Hn" as (γs) "Hn". + iDestruct "Hσ" + as (mγ mn) + "(? & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iDestruct (node_gnames_valid with "Hnauth Hn") as %?. + iDestruct (big_sepM_local_state_coh_delete with "Hlcoh") + as "(Hstate & Hlcoh)"; [done|]. + iMod (local_state_coh_alloc_socket with "[Hn] Hstate") as "[Hstate' Hl]"; + [done|done|..]. + { by iExists _. } + iDestruct (big_sepM_local_state_coh_update_socket_notin ip with "Hlcoh") + as "Hlcoh". + { apply lookup_delete. } + iDestruct (big_sepM_local_state_coh_insert with "Hstate' Hlcoh") + as "HX"; [done|]. + iModIntro. iFrame. iExists _, _. iFrame. + rewrite /set /=. + iSplitR. + { iPureIntro. by eapply gnames_coh_update_sockets. } + iSplitR. + { iPureIntro. + by apply network_sockets_coh_alloc_socket. } + iSplitR. + { rewrite /messages_history_coh. + iPureIntro. + destruct Hmhcoh as (? & Hrcoh & ?). + eauto using receive_buffers_coh_alloc_socket. } + { by iApply free_ips_coh_alloc_socket. } + Qed. + + Lemma aneris_state_interp_socket_interp_allocate_singleton σ mh sag φ : + aneris_state_interp σ mh -∗ unallocated_groups {[sag]} ==∗ + aneris_state_interp σ mh ∗ sag ⤇* φ. + Proof. + iIntros "Hσ Hunallocated". + iDestruct "Hσ" + as (mγ mn) + "(? & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iMod (socket_interp_coh_allocate_singleton with "Hsi Hunallocated") + as "[Hφ Hsi]". + iModIntro. iFrame. iExists _, _. iFrame. eauto. + Qed. + + Lemma aneris_state_interp_socket_interp_allocate_fun σ mh sags f : + aneris_state_interp σ mh -∗ unallocated_groups sags ==∗ + aneris_state_interp σ mh ∗ [∗ set] sag ∈ sags, sag ⤇* f sag. + Proof. + iIntros "Hσ Hunallocated". + iDestruct "Hσ" + as (mγ mn) + "(? & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iMod (socket_interp_coh_allocate_fun with "Hsi Hunallocated") + as "[Hφ Hsi]". + iModIntro. iFrame. iExists _, _. iFrame. eauto. + Qed. + + Lemma aneris_state_interp_socket_interp_allocate σ mh sags φ : + aneris_state_interp σ mh -∗ unallocated_groups sags ==∗ + aneris_state_interp σ mh ∗ [∗ set] sag ∈ sags, sag ⤇* φ. + Proof. + iIntros "Hσ Hunallocated". + iDestruct "Hσ" + as (mγ mn) + "(? & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iMod (socket_interp_coh_allocate with "Hsi Hunallocated") + as "[Hφ Hsi]". + iModIntro. iFrame. iExists _, _. iFrame. eauto. + Qed. + + Lemma aneris_state_interp_socketbind σ1 sa sh skt Sn mh : + let ip := ip_of_address sa in + let S' := + <[ip := <[sh:=(skt<| saddress := Some sa |>, [])]> Sn]> + (state_sockets σ1) in + let σ2 := σ1 <| state_sockets := S' |> in + state_sockets σ1 !! ip = Some Sn → + Sn !! sh = Some (skt, []) → + port_not_in_use (port_of_address sa) Sn → + saddress skt = None → + aneris_state_interp σ1 mh -∗ + sh ↪[ip_of_address sa] skt -∗ + free_ports ip {[port_of_address sa]} ==∗ + aneris_state_interp σ2 mh ∗ sh ↪[ip] (skt<| saddress := Some sa |>). + Proof. + simpl. iIntros (????) "Hσ Hsh Hp". + iDestruct "Hσ" + as (mγ mn) + "(? & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iDestruct (mapsto_socket_node with "Hsh") as (γs) "(#Hn & Hsh)". + iDestruct (node_gnames_valid with "Hnauth Hn") as %?. + iDestruct (big_sepM_local_state_coh_delete with "Hlcoh") + as "(Hstate & Hlcoh)"; [done|]. + iMod (local_state_coh_socketbind with "[$Hstate Hsh]") as + "[Hstate' $]"; try done. + iDestruct + (big_sepM_local_state_coh_update_socket_notin with "Hlcoh") + as "Hlcoh". + { apply lookup_delete. } + iDestruct (big_sepM_local_state_coh_insert with "Hstate' Hlcoh") + as "Hlcoh"; [done|]. + iMod (free_ips_coh_dealloc _ _ sh skt with "Hfreeips Hp") + as "Hfreeips"; [done..|]. + iModIntro. iExists mγ, _. iFrame. rewrite /set /=. + iSplit. + { iPureIntro; by eapply gnames_coh_update_sockets. } + iSplitR. + { iPureIntro. + apply network_sockets_coh_socketbind; eauto with set_solver. + } + iPureIntro. by apply messages_history_coh_socketbind. + Qed. + + Lemma aneris_state_interp_send + sh saT sagT saR sagR bs br skt Sn r R T φ mbody σ1 mh msg' : + let ip := ip_of_address saT in + let msg := mkMessage saT saR mbody in + let M' := {[+ msg +]} ⊎ state_ms σ1 in + let σ2 := σ1 <| state_ms := M' |> in + state_sockets σ1 !! ip_of_address saT = Some Sn → + Sn !! sh = Some (skt, r) → + saddress skt = Some saT → + msg ≡g{sagT,sagR} msg' → + saT ∈g sagT -∗ + saR ∈g sagR -∗ + sh ↪[ip_of_address saT] skt -∗ + sagT ⤳*[bs, br] (R, T) -∗ + sagR ⤇* φ -∗ + φ msg' -∗ + aneris_state_interp σ1 mh ==∗ + ⌜(mh.1, {[msg]} ∪ mh.2) = + message_history_evolution + (state_ms σ1) M' (state_sockets σ1) (state_sockets σ1) mh⌝ ∗ + aneris_state_interp σ2 (mh.1, {[msg]} ∪ mh.2) ∗ + sh ↪[ip_of_address saT] skt ∗ + sagT ⤳*[bs, br] (R, {[msg]} ∪ T). + Proof. + simpl. + iIntros (HS HSn Hskt Hmeq) "#HsagT #HsagR Hsh Hrt #Hφ Hmsg Hσ". + iDestruct "Hσ" + as (mγ mh') + "(%Hhst & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iDestruct (mapsto_socket_node with "Hsh") as (γs) "(#Hn & Hsh)". + iDestruct (node_gnames_valid with "Hnauth Hn") as %?. + set (msg := {| + m_sender := saT; + m_destination := saR; + m_body := mbody |}). + iDestruct (messages_mapsto_ctx_valid with "Hrt Hmctx") as %Hma. + destruct (decide (msg ∈ T)). + - assert (T = {[msg]} ∪ T) as <- by set_solver. + iFrame. iModIntro. + iSplit. + + iPureIntro. + destruct Hmhcoh as (Hmscoh & ? & ? & ?). + eapply message_history_evolution_send_message. + rewrite /messages_received_sent in Hhst. + inversion Hhst as [[ Hrcvd Hsent ]]. + simplify_eq /=. + intros m0 Hm0. + apply elem_of_messages_sent. + edestruct Hmscoh as (R0 & T0 & sag0 & ? & ? & ?); first by apply gmultiset_elem_of_dom. + exists sag0, (R0,T0). set_solver. + + iExists mγ, (<[sagT:=(R, T)]> mh'). iFrame. + simpl. + rewrite {2 3 4} (insert_id mh'); eauto. + iFrame. + iDestruct (elem_of_group_unfold with "HsagT") as "[%HsagT _]". + iPureIntro; split_and!; eauto. + * rewrite /messages_received_sent. + rewrite /messages_received_sent in Hhst. + apply insert_id in Hma. simplify_eq /=. + rewrite - {3 4} Hma. + rewrite !messages_sent_insert. + rewrite !messages_received_insert. + assert (T = {[msg]} ∪ T) as Ht by set_solver. + rewrite {1} Ht. f_equal; set_solver. + * assert (mh' = <[sagT := (R, {[msg]} ∪ T)]> mh') as ->. + assert (T = {[msg]} ∪ T) as <- by set_solver. + -- by rewrite insert_id. + -- by eapply messages_history_coh_send. + - iMod (messages_mapsto_update sagT bs br R T R ({[msg]} ∪ T) mh' + with "[$Hrt $Hmctx]") as "[Hmctx Hrt]". + iFrame. iModIntro. + iSplit. iPureIntro. + destruct Hmhcoh as (Hmscoh & ? & ? & ?). + eapply message_history_evolution_send_message. + rewrite /messages_received_sent in Hhst. + inversion Hhst as [[ Hrcvd Hsent ]]. + simplify_eq /=. + intros m0 Hm0. + apply elem_of_messages_sent. + edestruct Hmscoh as (R0 & T0 & sag0 & ? & ?); first by apply gmultiset_elem_of_dom. + exists sag0, (R0,T0). set_solver. + iExists mγ, (<[sagT:=(R, {[msg]} ∪ T)]> mh'). iFrame. + simpl. + iSplit. + { iPureIntro. + rewrite /messages_received_sent. + rewrite /messages_received_sent in Hhst. + apply insert_id in Hma. simplify_eq /=. + rewrite - {3 4} Hma. + rewrite !messages_sent_insert. + rewrite !messages_received_insert. + f_equal; set_solver. } + do 2 (iSplit; [done|]). + iDestruct (elem_of_group_unfold with "HsagT") as "[%HsagT _]". + iSplit. + { iPureIntro. by eapply messages_history_coh_send. } + iApply (messages_resource_coh_send with "[HsagR] [Hφ] [$Hmres] [Hmsg]"); eauto. + by destruct Hmhcoh; intuition. + Qed. + + Lemma aneris_state_interp_send_duplicate sh saT sagT saR sagR bs br skt Sn r R T mbody σ1 mh : + let ip := ip_of_address saT in + let msg := mkMessage saT saR mbody in + let M' := {[+ msg +]} ⊎ state_ms σ1 in + let σ2 := σ1 <| state_ms := M' |> in + state_sockets σ1 !! ip_of_address saT = Some Sn → + Sn !! sh = Some (skt, r) → + saddress skt = Some saT → + set_Exists (λ m, m ≡g{sagT,sagR} msg) T → + saT ∈g sagT -∗ + saR ∈g sagR -∗ + sh ↪[ip_of_address saT] skt -∗ + sagT ⤳*[bs, br] (R, T) -∗ + aneris_state_interp σ1 mh ==∗ + ⌜(mh.1, {[msg]} ∪ mh.2) = + message_history_evolution + (state_ms σ1) M' (state_sockets σ1) (state_sockets σ1) mh⌝ ∗ + aneris_state_interp σ2 (mh.1, {[msg]} ∪ mh.2) ∗ + sh ↪[ip_of_address saT] skt ∗ + sagT ⤳*[bs, br] (R, {[msg]} ∪ T). + Proof. + simpl. + iIntros (HS HSn Hskt Hexist) "#HsagT #HsagR Hsh Hrt Hσ". + iDestruct "Hσ" + as (mγ mh') + "(%Hhst & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iDestruct (mapsto_socket_node with "Hsh") as (γs) "(#Hn & Hsh)". + iDestruct (node_gnames_valid with "Hnauth Hn") as %?. + set (msg := {| + m_sender := saT; + m_destination := saR; + m_body := mbody |}). + iDestruct (messages_mapsto_ctx_valid with "Hrt Hmctx") as %Hma. + destruct (decide (msg ∈ T)). + - assert (T = {[msg]} ∪ T) as <- by set_solver. + iFrame. iModIntro. + iSplit. + + iPureIntro. + destruct Hmhcoh as (Hmscoh & ? & ? & ?). + eapply message_history_evolution_send_message. + rewrite /messages_received_sent in Hhst. + inversion Hhst as [[ Hrcvd Hsent ]]. + simplify_eq /=. + intros m0 Hm0. + apply elem_of_messages_sent. + edestruct Hmscoh as (R0 & T0 & sag0 & ? & ? & ?); first by apply gmultiset_elem_of_dom. + exists sag0, (R0,T0). set_solver. + + iExists mγ, (<[sagT:=(R, T)]> mh'). iFrame. + simpl. + rewrite {2 3 4} (insert_id mh'); eauto. + iFrame. + iDestruct (elem_of_group_unfold with "HsagT") as "[%HsagT _]". + iPureIntro; split_and!; eauto. + * rewrite /messages_received_sent. + rewrite /messages_received_sent in Hhst. + apply insert_id in Hma. simplify_eq /=. + rewrite - {3 4} Hma. + rewrite !messages_sent_insert. + rewrite !messages_received_insert. + assert (T = {[msg]} ∪ T) as Ht by set_solver. + rewrite {1} Ht. f_equal; set_solver. + * assert (mh' = <[sagT := (R, {[msg]} ∪ T)]> mh') as ->. + assert (T = {[msg]} ∪ T) as <- by set_solver. + -- by rewrite insert_id. + -- by eapply messages_history_coh_send. + - iMod (messages_mapsto_update sagT bs br R T R ({[msg]} ∪ T) mh' + with "[$Hrt $Hmctx]") as "[Hmctx Hrt]". + iFrame. iModIntro. + iSplit. iPureIntro. + destruct Hmhcoh as (Hmscoh & ? & ? & ?). + eapply message_history_evolution_send_message. + rewrite /messages_received_sent in Hhst. + inversion Hhst as [[ Hrcvd Hsent ]]. + simplify_eq /=. + intros m0 Hm0. + apply elem_of_messages_sent. + edestruct Hmscoh as (R0 & T0 & sag0 & ? & ?); first by apply gmultiset_elem_of_dom. + exists sag0, (R0,T0). set_solver. + iExists mγ, (<[sagT:=(R, {[msg]} ∪ T)]> mh'). iFrame. + simpl. + iDestruct (elem_of_group_unfold with "HsagT") as "[%HsagT _]". + iSplit. + { iPureIntro. + rewrite /messages_received_sent. + rewrite /messages_received_sent in Hhst. + apply insert_id in Hma. simplify_eq /=. + rewrite - {3 4} Hma. + rewrite !messages_sent_insert. + rewrite !messages_received_insert. + f_equal; set_solver. } + do 2 (iSplit; [done|]). + iSplit. + { iPureIntro. by eapply messages_history_coh_send. } + iApply (messages_resource_coh_send_duplicate with "[HsagR] [$Hmres]"); eauto. + by destruct Hmhcoh; intuition. + Qed. + + Lemma messages_addresses_coh_disj mhm : + messages_addresses_coh mhm → all_disjoint (dom mhm). + Proof. rewrite /messages_addresses_coh. naive_solver. Qed. + + Lemma aneris_state_interp_receive_some sa sag bs br sh skt + (Ψo : option (socket_interp Σ)) σ1 Sn r R T m mh : + let ip := ip_of_address sa in + let S' := <[ip :=<[sh:=(skt, r)]> Sn]> (state_sockets σ1) in + let σ2 := σ1 <| state_sockets := S' |> in + state_sockets σ1 !! ip = Some Sn → + Sn !! sh = Some (skt, r ++ [m]) → + saddress skt = Some sa → + sa ∈g sag -∗ + match Ψo with Some Ψ => sag ⤇* Ψ | _ => True end -∗ + aneris_state_interp σ1 mh -∗ + sh ↪[ip] skt -∗ + sag ⤳*[bs, br] (R, T) -∗ + ∃ R' sagT, + ⌜m_destination m = sa⌝ ∗ + m_sender m ∈g sagT ∗ + ⌜(R' ∪ mh.1, mh.2) = + message_history_evolution + (state_ms σ1) (state_ms σ1) (state_sockets σ1) S' mh⌝ ∗ + ⌜R' = {[ m ]} ∪ R⌝ ∗ + ((⌜set_Forall (λ m', ¬ m ≡g{sagT, sag} m') R⌝ ∗ + ∃ m', ⌜m ≡g{sagT, sag} m'⌝ ∗ + ▷ match Ψo with Some Ψ => Ψ m' | _ => ∃ φ, sag ⤇* φ ∗ φ m' end) + ∨ + ⌜set_Exists (λ m', m ≡g{sagT, sag} m') R⌝) + ∗ |==> aneris_state_interp σ2 (R' ∪ mh.1, mh.2) + ∗ sh ↪[ip_of_address sa] skt ∗ sag ⤳*[bs, br] (R', T). + Proof. + simpl. iIntros (HS HSn Hskt) "#Hsag #Hproto Hσ Hsh Ha". + iDestruct (elem_of_group_unfold with "Hsag") as "[%Hsag _]". + rewrite {1}/aneris_state_interp. + iDestruct "Hσ" + as (mγ mh') + "(%Hhst & %Hgcoh & %Hnscoh & %Hmhcoh + & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iDestruct (mapsto_socket_node with "Hsh") as (γs) "(#Hn & Hsh)". + iDestruct (node_gnames_valid with "Hnauth Hn") as %?. + assert ( network_sockets_coh (state_sockets σ1)) + as Hnscoh2 by eauto. + destruct (Hnscoh (ip_of_address sa) Sn) + as (Hshcoh & Hsmcoh & Hsacoh & Hsucoh); + first done. + iDestruct (messages_mapsto_ctx_valid with "[$Ha] [$Hmctx]") as %Hmha. + assert (m_destination m = sa) as Hma by (eapply Hsmcoh =>//; set_solver). + iDestruct (big_sepM_local_state_coh_delete with "Hlcoh") + as "(Hstate & Hlcoh)"; [done|]. + iDestruct (local_state_coh_update_rb sa sh skt σ1 γs Sn (r ++ [m]) r + with "[$Hstate $Hsh]") as "Hstate"; eauto. + destruct Hmhcoh as (? & Hrscoh & Hacoh & Hrsbcoh). + assert ( ∃ sagT R' T', m_sender m ∈ sagT ∧ mh' !! sagT = Some (R', T') ∧ + m ∈ T') as Hrcoh2. + { destruct (Hrscoh (ip_of_address sa) Sn sh skt _ m HS HSn ltac:(set_solver)). + destruct H1 as (T' & sagT & HsagT & Hlookup & HinT). + eexists _,_,_. + eauto. } + destruct Hrcoh2 as (sagT&R'&T'&HsagT&Hmh&Hm). + iPoseProof (messages_resource_coh_socket_address_group_own sagT with "Hmres") + as "[Hmres #HownT]". + { apply elem_of_dom. eexists _. set_solver. } + iAssert (m_sender m ∈g sagT) as "#HsagT". + { iSplit; done. } + iExists ({[m]} ∪ R), sagT. iSplit; first done. + iSplit; [iSplit;done|]. + destruct (set_Forall_Exists_message_group_equiv_dec sagT sag m R) + as [Hmeq | Hmeq]; last first. + - pose proof Hmeq as [m' [Hmin Hmq]]. + iPoseProof + (messages_resource_coh_receive sag sagT _ _ _ _ m with "[Hsag] [HsagT] Hmres") + as "(Hmres & _)"; [set_solver..|by simplify_eq|by simplify_eq|]. + iSplitR. + { iPureIntro. + eapply message_history_evolution_receive; eauto. + intros ???. destruct (Hnscoh2 ip Sn0); eauto. naive_solver. + rewrite /messages_received_sent in Hhst. + inversion Hhst as [[ Hrcvd Hsent ]]. + simplify_eq /=. + intros m0 Hm0. + apply elem_of_messages_received. + exists sag, (R,T); done. } + iSplit; [done|]. + iSplitR; [ by iRight | ]. + iMod "Hstate" as "(Hstate & Hsh)". + iDestruct (big_sepM_local_state_coh_insert + with "[$Hstate] [Hlcoh]") as "Hlcoh"; eauto. + { iApply (big_sepM_mono with "Hlcoh"). + iIntros (ip' γs' Hdel) "Hlcoh". + ddeq ip' (ip_of_address sa). + rewrite lookup_delete_ne in Hdel; last done. + iDestruct "Hlcoh" as (h' s') "Hlcoh". + iExists h', s'. rewrite !lookup_insert_ne; eauto. } + iMod (messages_mapsto_update sag bs br R T ({[m]} ∪ R) T mh' + with "[$Ha $Hmctx]") as "[Hmctx Ha]". + iModIntro. + iFrame. + iExists mγ, (<[sag:=({[m]} ∪ R, T)]> mh'). + simpl. iFrame. simpl. iSplit; eauto. iPureIntro. + { rewrite /messages_received_sent. + rewrite /messages_received_sent in Hhst. + destruct mh. simplify_eq /=. + apply insert_id in Hmha. rewrite - {4} Hmha. + rewrite !messages_sent_insert. + f_equal. + rewrite - {2} Hmha. + rewrite !messages_received_insert. + set_solver. } + iPoseProof + (free_ips_coh_update_msg with "Hfreeips") as "Hfreeips"; eauto. + iFrame. + iPureIntro. + split_and!. + + by eapply gnames_coh_update_sockets. + + by eapply network_sockets_coh_receive. + + eapply messages_history_coh_receive_2; eauto. + by rewrite /messages_history_coh. + - iPoseProof + (messages_resource_coh_receive sag sagT _ _ _ _ m + with "[Hsag] [HsagT] Hmres") + as "(Hmres & Hres)"; + [set_solver..|by simplify_eq|by simplify_eq|]. + iDestruct ("Hres" with "[//]") as "(%φ & %m'' & %Hmeq' & #Hφ & Hres)". + iSplitR. + { iPureIntro. + eapply message_history_evolution_receive; eauto. + intros ???. destruct (Hnscoh2 ip Sn0); eauto. naive_solver. + rewrite /messages_received_sent in Hhst. + inversion Hhst as [[ Hrcvd Hsent ]]. + simplify_eq /=. + intros m0 Hm0. + apply elem_of_messages_received. + exists sag, (R,T); split; last done. + eauto. } + iSplit; [done|]. + iSplitL "Hres". + { iLeft. iSplit; eauto. destruct Ψo as [ψ|]. + - iPoseProof (socket_interp_agree _ _ _ _ _ m'' with "Hproto Hφ") + as (?) "Heq"; eauto. + iExists _. iSplit; [done|]. + iNext. by iRewrite "Heq". + - iExists m''. iSplit; [done|]. iNext. + iExists φ. by iFrame. } + iMod "Hstate" as "(Hstate & Hsh)". + iDestruct (big_sepM_local_state_coh_insert + with "[$Hstate] [Hlcoh]") as "Hlcoh"; eauto. + { iApply (big_sepM_mono with "Hlcoh"). + iIntros (ip' γs' Hdel) "Hlcoh". + ddeq ip' (ip_of_address sa). + rewrite lookup_delete_ne in Hdel; last done. + iDestruct "Hlcoh" as (h' s') "Hlcoh". + iExists h', s'. rewrite !lookup_insert_ne; eauto. } + iMod (messages_mapsto_update sag bs br R T ({[m]} ∪ R) T mh' + with "[$Ha $Hmctx]") as "[Hmctx Ha]". + iModIntro. iFrame. + iExists mγ, (<[sag:=({[m]} ∪ R, T)]> mh'). + iFrame. simpl. iSplitR. + { iPureIntro. + rewrite /messages_received_sent. + rewrite /messages_received_sent in Hhst. + destruct mh. simplify_eq /=. + apply insert_id in Hmha. rewrite - {4} Hmha. + rewrite !messages_sent_insert. + f_equal. + rewrite - {2} Hmha. + rewrite !messages_received_insert. + set_solver. } + iSplit. + { iPureIntro. by eapply gnames_coh_update_sockets. } + iSplit. + { iPureIntro. by eapply network_sockets_coh_receive. } + iSplit. + { iPureIntro. by eapply messages_history_coh_receive_2; eauto. } + by iApply free_ips_coh_update_msg. + Qed. + + Definition messages_sent_from (sag: socket_address_group) (rt: messages_history) : message_soup := + filter (λ m, m.(m_sender) ∈ sag) rt.2. + +End aneris_state_interpretation. + +Section state_interpretation. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + (* Lemma aneris_state_interp_model_agree m ex atr : *) + (* state_interp ex atr -∗ frag_st m -∗ ⌜(trace_last atr) = m⌝. *) + (* Proof. *) + (* iIntros "(_ & _ & Ha & _) Hf". *) + (* by iDestruct (auth_frag_st_agree with "Ha Hf") as %<-. *) + (* Qed. *) + + (* Lemma aneris_state_interp_model_extend m1 m2 ex atr : *) + (* state_interp ex (atr :tr[()]: m1) -∗ *) + (* frag_st m1 -∗ *) + (* ⌜trace_last atr = m1⌝ -∗ *) + (* ⌜m1 = m2 ∨ Mdl.(model_rel) m1 m2⌝ ==∗ *) + (* state_interp ex (atr :tr[()]: m2) ∗ frag_st m2. *) + (* Proof. *) + (* iIntros "Hsi Hfrag %Hm1 %Hrel". *) + (* iDestruct (aneris_state_interp_model_agree with "Hsi Hfrag") as %Heq. *) + (* iDestruct "Hsi" as "(? & ? & Hauth & %Hv & Hsteps)". simpl. *) + (* iDestruct (frag_st_rtc with "Hfrag") as %?. *) + (* iMod (auth_frag_st_update _ m2 with "Hauth Hfrag") as "[Hauth Hfrag]". *) + (* { destruct Hrel as [->|?]; [done|]. by eapply rtc_r. } *) + (* iModIntro. iFrame. iPureIntro. simpl in *. *) + (* rewrite Hm1. destruct Hrel as [->|?]; by [left|right]. *) + (* Qed. *) + + Lemma aneris_state_interp_sent_mapsto_agree_group sag R T ex atr : + sag ⤳* (R, T) -∗ + state_interp ex atr -∗ + ⌜messages_sent_from sag (trace_messages_history ex) = T⌝. + Proof. + iIntros "Hlt Hsi". + rewrite /state_interp /= /aneris_state_interp /messages_sent_from. + iDestruct "Hsi" as "[[Hsi Hauth] [% Hlive]]". + iDestruct "Hsi" as (γm mh Hmh Hgnms Hnetsock Hhistcoh) "(?&?&?&?& Hctx &?)". + rewrite -Hmh /=. + iDestruct (messages_mapsto_ctx_valid with "Hlt Hctx") as %Hma. + iPureIntro. + rewrite /messages_sent. + destruct Hhistcoh as (Hmspcoh&?&Haddrcoh&?). + destruct Haddrcoh as (Hdisj & Hne & Haddrcoh). + apply set_eq_subseteq; split. + - intros m; rewrite elem_of_filter elem_of_collect. + intros [? (sag'&[R' T']& Hma' & HmT')]; simpl in *. + destruct (Haddrcoh _ _ _ Hma') as [Hma'1 Hma'2]. + pose proof (Hma'2 _ HmT'); simplify_eq /=. + assert (sag = sag') as <-. + { eapply elem_of_all_disjoint_eq; eauto. + apply elem_of_dom. by eexists _. + apply elem_of_dom. by eexists _. } + rewrite Hma in Hma'; simplify_eq; done. + - intros m; rewrite elem_of_filter elem_of_collect. + intros HmT. + destruct (Haddrcoh _ _ _ Hma) as [Hma1 Hma2]. + pose proof (Hma2 _ HmT); eauto. + Qed. + + Lemma aneris_state_interp_sent_mapsto_agree sa R T ex atr : + sa ⤳ (R, T) -∗ + state_interp ex atr -∗ + ⌜messages_sent_from {[sa]} (trace_messages_history ex) = T⌝. + Proof. + iIntros "[Hlt H'] Hsi". + by iApply (aneris_state_interp_sent_mapsto_agree_group with "Hlt Hsi"). + Qed. + +End state_interpretation. + +Global Opaque aneris_state_interp. diff --git a/fairneris/aneris_lang/state_interp/state_interp_config_wp.v b/fairneris/aneris_lang/state_interp/state_interp_config_wp.v new file mode 100644 index 0000000..9ea188d --- /dev/null +++ b/fairneris/aneris_lang/state_interp/state_interp_config_wp.v @@ -0,0 +1,253 @@ +From iris.proofmode Require Import tactics. +From trillium.program_logic Require Export adequacy. +From fairneris Require Import fuel env_model. +From fairneris.aneris_lang Require Import + aneris_lang network resources network_model. +From fairneris.prelude Require Import gmultiset. +From fairneris.aneris_lang.state_interp Require Import + state_interp_def + state_interp_local_coh + state_interp_gnames_coh + state_interp_free_ips_coh + state_interp_network_sockets_coh + state_interp_socket_interp_coh + state_interp_messages_resource_coh + state_interp_messages_history_coh + state_interp_events + state_interp_messages_history. +From fairneris Require Import fairness fair_resources. +From RecordUpdate Require Import RecordSet. +Set Default Proof Using "Type". + +Import uPred. +Import RecordSetNotations. + +Section state_interpretation. + Context `{LM: LiveModel aneris_lang (joint_model Mod net_model)}. + Context `{LMeq: !LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + (* TODO: Move this elsehwere and use it where we now use ad hoc induction *) + Lemma fupd_elim_laterN E1 E2 n (P:iProp Σ) : + E2 ⊆ E1 → (|={E1}=> P)%I -∗ |={E1,E2}=> |={E2}▷=>^n |={E2,E1}=> P. + Proof. + iIntros (Hle) "HP". + iApply fupd_mask_intro; [done|]. + iIntros "Hclose". + iInduction n as [|n] "IHn"; [by iMod "Hclose"|]=> /=. + iIntros "!>!>!>". + iApply ("IHn" with "HP Hclose"). + Qed. + + (* OBS: A general update lemma could be nicer, but needs changes to + [network_sockets_coh] API *) + (* Lemma state_buffers_insert ip (skts : gmap ip_address sockets) *) + (* sh skt bs m R Sn sa : *) + (* network_sockets_coh skts → *) + (* m_destination m = sa → *) + (* ip = ip_of_address sa → *) + (* skts !! ip = Some Sn → *) + (* Sn !! sh = Some (skt, R) → *) + (* saddress skt = Some sa → *) + (* model_state_socket_coh skts bs → *) + (* model_state_socket_coh (<[ip:=<[sh:=(skt, m :: R)]> Sn]> skts) *) + (* (<[sa:=m :: R]> bs). *) + (* Proof. *) + (* intros Hscoh Hm -> Hip Hsh Hsa Hcoh ip' Sn' sh' skt' sa' R' Hip' Hsh' Hskt'. *) + (* assert (network_sockets_coh (<[ip_of_address sa:=<[sh:=(skt, m :: R)]> Sn]> skts)) as Hscoh'. *) + (* { by eapply network_sockets_coh_deliver_message. } *) + (* assert (ip_of_address sa' = ip') as <-. *) + (* { by eapply Hscoh'. } *) + (* destruct (decide (sa = sa')) as [<-|Hsaneq]. *) + (* { destruct sa. *) + (* rewrite lookup_total_insert. *) + (* rewrite lookup_insert in Hip'. *) + (* simplify_eq. *) + (* assert(sh = sh') as <-. *) + (* { eapply Hscoh'; [| |done|..]. *) + (* - apply lookup_insert. *) + (* - rewrite lookup_insert. done. *) + (* - done. *) + (* - rewrite Hsa. rewrite Hskt'. done. } *) + (* rewrite lookup_insert in Hsh'. *) + (* simplify_eq. done. } *) + (* rewrite lookup_total_insert_ne; [|done]. *) + (* destruct (decide (ip_of_address sa = ip_of_address sa')) as [Heq|Hneq]. *) + (* { rewrite Heq in Hip'. rewrite lookup_insert in Hip'. *) + (* simplify_eq. *) + (* assert(sh ≠ sh') as Hshneq. *) + (* { intros <-. rewrite lookup_insert in Hsh'. simplify_eq. } *) + (* rewrite lookup_insert_ne in Hsh'; [|done]. *) + (* by eapply Hcoh. } *) + (* rewrite lookup_insert_ne in Hip'; [|done]. *) + (* by eapply Hcoh. *) + (* Qed. *) + + (* Lemma state_buffers_delete ip (skts : gmap ip_address sockets) *) + (* sh skt bs m R Sn sa : *) + (* network_sockets_coh skts → *) + (* m_destination m = sa → *) + (* ip = ip_of_address sa → *) + (* skts !! ip = Some Sn → *) + (* Sn !! sh = Some (skt, R ++ [m]) → *) + (* saddress skt = Some sa → *) + (* model_state_socket_coh skts bs → *) + (* model_state_socket_coh (<[ip:=<[sh:=(skt, R)]> Sn]> skts) *) + (* (<[sa:=R]> bs). *) + (* Proof. *) + (* intros Hscoh Hm -> Hip Hsh Hsa Hcoh ip' Sn' sh' skt' sa' R' Hip' Hsh' Hskt'. *) + (* assert (network_sockets_coh (<[ip_of_address sa:=<[sh:=(skt, R)]> Sn]> skts)) as Hscoh'. *) + (* { by eapply network_sockets_coh_receive. } *) + (* assert (ip_of_address sa' = ip') as <-. *) + (* { by eapply Hscoh'. } *) + (* destruct (decide (sa = sa')) as [<-|Hsaneq]. *) + (* { destruct sa. *) + (* rewrite lookup_total_insert. *) + (* rewrite lookup_insert in Hip'. *) + (* simplify_eq. *) + (* assert(sh = sh') as <-. *) + (* { eapply Hscoh'; [| |done|..]. *) + (* - apply lookup_insert. *) + (* - rewrite lookup_insert. done. *) + (* - done. *) + (* - rewrite Hsa. rewrite Hskt'. done. } *) + (* rewrite lookup_insert in Hsh'. *) + (* simplify_eq. done. } *) + (* rewrite lookup_total_insert_ne; [|done]. *) + (* destruct (decide (ip_of_address sa = ip_of_address sa')) as [Heq|Hneq]. *) + (* { rewrite Heq in Hip'. rewrite lookup_insert in Hip'. *) + (* simplify_eq. *) + (* assert(sh ≠ sh') as Hshneq. *) + (* { intros <-. rewrite lookup_insert in Hsh'. simplify_eq. } *) + (* rewrite lookup_insert_ne in Hsh'; [|done]. *) + (* by eapply Hcoh. } *) + (* rewrite lookup_insert_ne in Hip'; [|done]. *) + (* by eapply Hcoh. *) + (* Qed. *) + + (*TODO: lots of copy pasta! *) + Lemma config_wp_correct : ⊢ config_wp. + Proof using LM LMeq Mod aG Σ. + rewrite /config_wp. iModIntro. + iIntros (ex atr c lbl σ2 Hexvalid Hex Hstep) "[[Hsi Hauth] [% Hlive]]". + rewrite (last_eq_trace_ends_in ex c); [|done]. + rewrite /aneris_state_interp. + iDestruct "Hsi" as (γm mh) + "(%Hhist & %Hgcoh & %Hnscoh & %Hmhcoh & + Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)". + iMod (steps_auth_update_S with "Hauth") as "Hauth". + iApply fupd_elim_laterN; [solve_ndisj|]. + destruct c as [tp1 σ1]=> /=. + rewrite /valid_state_evolution_fairness in H. + rewrite /trace_ends_in in Hex. + have Hlstep: locale_step (tp1, σ1) (inr lbl) (tp1, σ2) by econstructor. + destruct σ1; simpl in *; simplify_eq. + pose (trace_last atr) as δ. + pose net' := (env_apply_trans aneris_lang net_model (env_state δ) (inr lbl)). + unshelve iExists ({| ls_data := + {| ls_under := (usr_state δ, net'): fmstate (joint_model Mod net_model); ls_map := δ.(ls_data).(ls_map) |} |}). + { intros **. eapply ls_map_disj=>//. } + { intros **. eapply ls_map_live=>//. } + simpl. + iExists (Config_step (lbl : fmconfig (joint_model Mod net_model)) lbl). + inversion Hstep as + [ip σ Sn Sn' sh a skt R m Hm HSn Hsh HSn' Hsaddr| + σ| + σ]; + simplify_eq/=. + (* Deliver *) + - destruct H as (Hsteps & Hmatch & Htids). + iSplitR "Hlive". + + iFrame "Hauth". + iExists γm, mh. iFrame. simpl. iModIntro. + iSplit. + { apply (last_eq_trace_ends_in) in Hex as ->. + erewrite <- message_history_evolution_deliver_message; + eauto with set_solver. } + iSplitR; [eauto using gnames_coh_update_sockets|]. + assert (m_destination m = a) by set_solver. (* TODO: Remove filter thing *) + iSplitR; [eauto using network_sockets_coh_deliver_message|]. + iSplitR; [iPureIntro; apply messages_history_coh_drop_message; + eauto using messages_history_coh_deliver_message|]. + iSplitL "Hlcoh"; + [by iApply (local_state_coh_deliver_message with "Hlcoh")|]. + by iApply (free_ips_coh_deliver_message with "Hfreeips"). + + iModIntro. + iSplit. + * simpl. iPureIntro. + rewrite /valid_state_evolution_fairness. + rewrite /messages_to_receive_at_multi_soup in Hm. + split. + { econstructor; [done|econstructor|done]; simpl. + - destruct (trace_last atr) as [[[??]]] eqn:Heq. simpl. + rewrite /usr_state. simpl. + apply NetTrans. + by eapply env_apply_trans_spec_trans. + - split=>//. } + split; [|]. + simpl. split=>//. by apply cfg_labels_match_is_eq. + by rewrite /tids_smaller ?Hex //= in Htids *. + * iDestruct "Hlive" as "(%fm&?&?&?&Hst&?&%Hem)". + iExists _. iFrame. iPureIntro. + unshelve by eapply env_apply_trans_spec_both. + exact inhabitant. + - destruct H as (Hsteps & Hmatch & Htids). + iSplitR "Hlive". + + iFrame "Hauth". iModIntro. simpl. + iExists γm, mh. iFrame. + iSplit. + { apply (last_eq_trace_ends_in) in Hex as ->. + erewrite <- message_history_evolution_duplicate_message; + eauto with set_solver. multiset_solver. } + iSplitR; [eauto using gnames_coh_update_sockets|]. + iSplitR; [eauto using network_sockets_coh_deliver_message|]. + eauto using messages_history_coh_duplicate_message. + + iModIntro. + iSplit. + * simpl. iPureIntro. + rewrite /valid_state_evolution_fairness. + split. + { econstructor; [done|econstructor|done]; simpl. + - destruct (trace_last atr) as [[[??]]] eqn:Heq. simpl. + rewrite /usr_state. simpl. + apply NetTrans. + by eapply env_apply_trans_spec_trans. + - split=>//. } + split; [|]. + simpl. split=>//. by apply cfg_labels_match_is_eq. + by rewrite /tids_smaller ?Hex //= in Htids *. + * iDestruct "Hlive" as "(%fm&?&?&?&Hst&?&%Hem)". + iExists _. iFrame. iFrame. iPureIntro. + unshelve by eapply env_apply_trans_spec_both. + exact inhabitant. + - destruct H as (Hsteps & Hmatch & Htids). + iSplitR "Hlive". + + iFrame "Hauth". simpl. iModIntro. + iExists γm, mh. iFrame. + iSplit. + { apply (last_eq_trace_ends_in) in Hex as ->. + erewrite <- message_history_evolution_drop_message; + eauto with set_solver. multiset_solver. } + iSplitR; [eauto using gnames_coh_update_sockets|]. + iSplitR; [eauto using network_sockets_coh_deliver_message|]. + eauto using messages_history_coh_drop_message. + + iSplitR. + * simpl. iPureIntro. + rewrite /valid_state_evolution_fairness. + split. + { econstructor; [done|econstructor|done]; simpl. + - destruct (trace_last atr) as [[[??]]] eqn:Heq. simpl. + rewrite /usr_state. simpl. + apply NetTrans. + by eapply env_apply_trans_spec_trans. + - split=>//. } + split; [|]. + simpl. split=>//. by apply cfg_labels_match_is_eq. + by rewrite /tids_smaller ?Hex //= in Htids *. + * iDestruct "Hlive" as "(%fm&?&?&?&Hst&?&%Hem)". + iExists _. iFrame. iFrame. iPureIntro. + unshelve by eapply env_apply_trans_spec_both. + exact inhabitant. + Qed. + +End state_interpretation. diff --git a/fairneris/aneris_lang/state_interp/state_interp_def.v b/fairneris/aneris_lang/state_interp/state_interp_def.v new file mode 100644 index 0000000..429b0b9 --- /dev/null +++ b/fairneris/aneris_lang/state_interp/state_interp_def.v @@ -0,0 +1,323 @@ +From RecordUpdate Require Import RecordSet. +From stdpp Require Import fin_maps gmap option finite. +From trillium.prelude Require Import + quantifiers finitary classical_instances sigma. +From iris.bi.lib Require Import fractional. +From iris.algebra Require Import auth. +From iris.proofmode Require Import tactics. +From iris.base_logic.lib Require Import saved_prop gen_heap mono_nat. +From trillium.program_logic Require Import weakestpre adequacy. +From trillium.events Require Import event. +From fairneris Require Import fairness fuel fair_resources env_model. +From fairneris.prelude Require Import collect gset_map gmultiset. +From fairneris.algebra Require Import disj_gsets. +From fairneris.aneris_lang Require Import resources events. +From fairneris.lib Require Import gen_heap_light. +From fairneris.aneris_lang Require Export aneris_lang network resources. +From fairneris.aneris_lang.state_interp Require Export messages_history. + +Set Default Proof Using "Type". + +Import uPred. +Import RecordSetNotations. + +Section definitions. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + Implicit Types σ : state aneris_lang. + Implicit Types h : heap. + Implicit Types H : gmap ip_address heap. + Implicit Types S : gmap ip_address sockets. + Implicit Types Sn : sockets. + Implicit Types ps : gset port. + Implicit Types ips : gset ip_address. + Implicit Types M : message_multi_soup. + Implicit Types R T : message_soup. + Implicit Types m : message. + Implicit Types a : socket_address. + Implicit Types ip : ip_address. + Implicit Types sh : socket_handle. + Implicit Types skt : socket. + Implicit Types A B : gset socket_address_group. + Implicit Types mhm : messages_history_map. + Implicit Types rt : message_soup * message_soup. + Implicit Types γm : gmap ip_address node_gnames. + Implicit Types sis : gmap socket_address_group gname. + + (** Local state coherence *) + + (* The local state of the node at [ip] is coherent + with physical state [σ] and ghost names [γs]. *) + Definition local_state_coh σ ip γs := + (∃ h Sn, + ⌜state_heaps σ !! ip = Some h⌝ ∗ + ⌜state_sockets σ !! ip = Some Sn⌝ ∗ + mapsto_node ip γs ∗ + heap_ctx γs h ∗ + sockets_ctx γs ((λ x, x.1) <$> Sn))%I. + + (** The domains of heaps and sockets coincide with the gname map [γm] *) + Definition gnames_coh γm H S := + dom γm = dom H ∧ + dom γm = dom S. + + Definition sis_own (sags : gset socket_address_group) : iProp Σ := + ∃ (sis : gmap socket_address_group gname), + saved_si_auth sis ∗ + ⌜dom sis = sags⌝ ∗ + [∗ set] sag ∈ sags, ∃ φ, sag ⤇* φ. + + (** Socket interpretation coherence *) + (* Addresses with socket interpretations are bound *) + Definition socket_interp_coh := + (∃ (sags : gset socket_address_group) + (A : gset socket_address_group), + ⌜A ⊆ sags⌝ ∗ + (* socket_address_group_ctx A ∗ *) + socket_address_group_ctx sags ∗ + (* [A] is the set of socket addresses without an interpretation *) + unallocated_groups_auth A ∗ + (* [sags ∖ A] is the set of addresses with a saved socket interpretation *) + sis_own (sags ∖ A))%I. + + (** Free ips coherence *) + (* Free ips have no bound ports, no heap, and no sockets *) + Definition free_ips_coh σ := + (∃ free_ips free_ports, + (* the domains of [free_ips] and [free_ports] are disjoint *) + (⌜dom free_ports ## free_ips ∧ + (* if the ip [ip] is free, neither a heap nor a socket map has been + allocated *) + (∀ ip, ip ∈ free_ips → + state_heaps σ !! ip = None ∧ state_sockets σ !! ip = None) ∧ + (* free ports and bound ports are disjoint *) + (∀ ip ps, free_ports !! ip = Some (GSet ps) → + ∀ Sn, (state_sockets σ) !! ip = Some Sn → + ∀ p, p ∈ ps → port_not_in_use p Sn)⌝) ∗ + (* we have the auth parts of the resources for free ips and ports *) + free_ips_auth free_ips ∗ + free_ports_auth free_ports)%I. + + (** Network sockets coherence for bound ports, socket handlers, + receive buffers, and socket addresses *) + (* All sockets in [Sn] with the same address have the same handler *) + Definition socket_handlers_coh Sn := + ∀ sh sh' skt skt' r r', + Sn !! sh = Some (skt, r) → + Sn !! sh' = Some (skt', r') → + is_Some (saddress skt) → + saddress skt = saddress skt' → + sh = sh'. + + (* Sent and received messages at all socket in [Sn] are in [M] *) + Definition socket_messages_coh Sn := + ∀ sh skt r a, + Sn !! sh = Some (skt, r) → + saddress skt = Some a → + ∀ m, m ∈ r → m_destination m = a. + + (* All sockets in [Sn] are bound to ip address [ip] *) + Definition socket_addresses_coh Sn ip := + ∀ sh skt r a, + Sn !! sh = Some (skt, r) → + saddress skt = Some a → + ip_of_address a = ip. + + (* Receive buffers of unbound sockets are empty. *) + Definition socket_unbound_empty_buf_coh Sn ip := + ∀ sh skt r, + Sn !! sh = Some (skt, r) → + saddress skt = None → + r = []. + + Definition network_sockets_coh S := + ∀ ip Sn, + S !! ip = Some Sn → + socket_handlers_coh Sn ∧ + socket_messages_coh Sn ∧ + socket_addresses_coh Sn ip ∧ + socket_unbound_empty_buf_coh Sn ip. + + (* Every message present in the message soup [M] has been recorded in the + message history [mhm] as sent from the node of its origin. *) + Definition message_soup_coh M mhm := + ∀ m, m ∈ M → ∃ R T sag, (m_sender m) ∈ sag ∧ mhm !! sag = Some (R, T) ∧ m ∈ T. + + (* Every message in the receive buffers of [S] has been recorded in the + message history [mhm] as sent from the node of its origin. *) + Definition receive_buffers_coh S mhm := + ∀ ip Sn sh skt r m, + S !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + m ∈ r → + ∃ R T sag, (m_sender m) ∈ sag ∧ mhm !! sag = Some (R, T) ∧ m ∈ T. + + Definition messages_history_coh M S mhm := + message_soup_coh M mhm ∧ + receive_buffers_coh S mhm ∧ + messages_addresses_coh mhm ∧ + messages_received_from_sent_coh mhm. + + (* For all messages [m] in [M], either the network owns the resources [Φ m] + described by some socket protocol [Φ] or it has been delivered. *) + Definition messages_resource_coh mhm : iProp Σ := + (* All sets in the domain of [mhm] are disjoint *) + own (A:=authUR socket_address_groupUR) aneris_socket_address_group_name + (◯ (DGSets (dom mhm))) ∗ + (* Take the set [ms] of sent messages closed under group equivalence *) + ∃ ms, + (* [ms] is a subset of [mhm], ... *) + ⌜ms ⊆ (messages_sent mhm)⌝ ∗ + (* and carries one message, for each message sent by a group in `mhm` *) + ([∗ set] m ∈ messages_sent mhm, ∃ sagT sagR m', + ⌜m ≡g{sagT,sagR} m' ∧ m' ∈ ms⌝ ∗ + socket_address_group_own sagT ∗ + socket_address_group_own sagR) ∗ + (* For any message [m] in [ms] *) + ([∗ set] m ∈ ms, + ∃ sagT sagR Φ, + (* The group of the message is disjoint, and *) + ⌜m_destination m ∈ sagR⌝ ∗ sagR ⤇* Φ ∗ + socket_address_group_own sagT ∗ + (* either [m] is governed by a protocol [Φ] and the network owns the + resources specified by the protocol *) + ((∃ m', ⌜m ≡g{sagT,sagR} m'⌝ ∗ ▷ Φ m') ∨ + (* or [m] has been delivered somewhere *) + (∃ m', ⌜m ≡g{sagT,sagR} m'⌝ ∗ ⌜message_received m' mhm⌝))). + + (** State interpretation *) + Definition aneris_state_interp σ (rt : messages_history) := + (∃ γm mhm, + ⌜messages_received_sent mhm = rt⌝ ∗ + ⌜gnames_coh γm (state_heaps σ) (state_sockets σ)⌝ ∗ + ⌜network_sockets_coh (state_sockets σ)⌝ ∗ + ⌜messages_history_coh (state_ms σ) (state_sockets σ) mhm⌝ ∗ + node_gnames_auth γm ∗ + socket_interp_coh ∗ + ([∗ map] ip ↦ γs ∈ γm, local_state_coh σ ip γs) ∗ + free_ips_coh σ ∗ + messages_ctx mhm ∗ + messages_resource_coh mhm)%I. + + Program Definition aneris_events_state_interp (ex : execution_trace aneris_lang) : iProp Σ := + ∃ (As Ar : gset socket_address_group) (lbls : gset string), + own (A:=authUR socket_address_groupUR) aneris_socket_address_group_name + (◯ (DGSets (As ∪ Ar))) ∗ + observed_send_groups As ∗ observed_receive_groups Ar ∗ + sendon_evs_ctx (fn_to_gmap As (λ sag, events_of_trace (sendonEV_groups sag) ex)) ∗ + receiveon_evs_ctx (fn_to_gmap Ar (λ sag, events_of_trace (receiveonEV_groups sag) ex)) ∗ + alloc_evs_ctx (fn_to_gmap lbls (λ lbl, events_of_trace (allocEV lbl) ex)). + + Definition buffers (S : gmap ip_address sockets) : message_multi_soup := + (multi_collect (λ ip Sn, multi_collect (λ sh sr, list_to_set_disj sr.2) Sn) S). + + Definition message_history_evolution + (M1 M2 : message_multi_soup) + (S1 S2 : gmap ip_address sockets) + (mhm : messages_history) : messages_history := + (dom (buffers S1 ∖ buffers S2) ∪ mhm.1, (gset_of_gmultiset M2 ∖ gset_of_gmultiset M1) ∪ mhm.2). + + Fixpoint trace_messages_history (ex : execution_trace aneris_lang) : messages_history := + match ex with + | {tr[c]} => (∅, gset_of_gmultiset (state_ms c.2)) + | ex' :tr[_]: c => + message_history_evolution + (state_ms (trace_last ex').2) + (state_ms c.2) + (state_sockets (trace_last ex').2) + (state_sockets c.2) + (trace_messages_history ex') + end. + +End definitions. + +Section Aneris_AS. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + Definition ipA := "0.0.0.0". + Definition saA := SocketAddressInet ipA 80. + Definition sA := mkSocket (Some saA) true. + Definition tidA := 0. + Definition localeA := (ipA, tidA). + + Definition ipB := "0.0.0.1". + Definition saB := SocketAddressInet ipB 80. + Definition sB := mkSocket (Some saB) true. + Definition tidB := 0. + Definition localeB := (ipB, tidB). + + Definition mAB := mkMessage saA saB "Hello". + + Definition map_oζα + (f : execution_trace aneris_lang → auxiliary_trace LM → iProp Σ) + oζα : execution_trace aneris_lang → auxiliary_trace LM → iProp Σ := + (match oζα with + | None => f + | Some (ζ,α) => λ ex atr, ∃ ex', ⌜trace_contract ex (inl (ζ,α)) ex'⌝ ∗ + ⌜language.locale_step (trace_last ex') (inl (ζ, α)) (trace_last ex)⌝ ∗ + f ex' atr + end)%I. + + Definition aneris_state_interp_σ (ex : execution_trace aneris_lang) := + (aneris_state_interp (trace_last ex).2 (trace_messages_history ex) ∗ + steps_auth (trace_length ex))%I. + + Definition aneris_state_interp_δ + (ex : execution_trace aneris_lang) (atr : auxiliary_trace LM) := + (⌜valid_state_evolution_fairness ex atr⌝ ∗ + model_state_interp (trace_last ex) (trace_last atr))%I. + + Definition aneris_state_interp_opt oζα ex atr := + (aneris_state_interp_σ ex ∗ + map_oζα aneris_state_interp_δ oζα ex atr)%I. + + Global Instance anerisG_irisG : + irisG aneris_lang (live_model_to_model LM) Σ := { + iris_invGS := _; + state_interp ex atr := + aneris_state_interp_opt None ex atr; + fork_post ζ _ := (ζ ↦M ∅)%I }. + + (* Global Instance anerisG_irisG : *) + (* irisG aneris_lang (live_model_to_model LM) Σ := { *) + (* iris_invGS := _; *) + (* state_interp_opt oζα ex atr := *) + (* (map_oζα (λ ex atr, ⌜valid_state_evolution_fairness ex atr⌝) oζα ex atr ∗ *) + (* aneris_state_interp *) + (* (trace_last ex).2 *) + (* (trace_messages_history ex) ∗ *) + (* (map_oζα (λ ex atr, model_state_interp (trace_last ex) (trace_last atr)) *) + (* oζα ex atr)∗ *) + (* steps_auth (trace_length ex))%I; *) + (* fork_post ζ _ := (ζ ↦M ∅)%I }. *) + +End Aneris_AS. + +Global Opaque iris_invGS. + +Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _; simpl : core. +Local Hint Constructors head_step : core. +Local Hint Resolve alloc_fresh : core. +Local Hint Resolve to_of_val : core. + +Ltac ddeq k1 k2 := + destruct (decide (k1 = k2)); subst; + repeat + match goal with + | Hyp : context[ (<[_:=_]>_) !! _ ] |- _ => + rewrite lookup_insert in + Hyp || (rewrite lookup_insert_ne in Hyp; last done); + simplify_eq /= + | Hyp : is_Some _ |- _ => destruct Hyp + | |- context[ (<[_:=_]>_) !! _ ] => + rewrite lookup_insert || (rewrite lookup_insert_ne; last done); + simplify_eq /= + | H1 : ?x = ?z, Heq : ?x = ?y |- _ => + rewrite Heq in H1; simplify_eq /=; try eauto + | Hdel : context[ delete ?n ?m !! ?n = _] |- _ => + rewrite lookup_delete in Hdel; simplify_eq /= + end. diff --git a/fairneris/aneris_lang/state_interp/state_interp_events.v b/fairneris/aneris_lang/state_interp/state_interp_events.v new file mode 100644 index 0000000..fa79d47 --- /dev/null +++ b/fairneris/aneris_lang/state_interp/state_interp_events.v @@ -0,0 +1,360 @@ +From fairneris.aneris_lang Require Import aneris_lang network resources. +From fairneris.prelude Require Import gset_map. +From iris.proofmode Require Import tactics. +From trillium.program_logic Require Import traces. +From fairneris Require Import fuel env_model. +From fairneris.aneris_lang Require Import events. +From fairneris.aneris_lang.state_interp Require Import state_interp_def. +From fairneris.algebra Require Import disj_gsets. +From iris.algebra Require Import auth. + +Set Default Proof Using "Type". + +Section state_interpretation. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + Lemma aneris_events_state_interp_same_tp ex c oζ c': + valid_exec (ex :tr[oζ]: c') → + trace_ends_in ex c → + c.1 = c'.1 → + aneris_events_state_interp (ex :tr[oζ]: c') ⊣⊢ aneris_events_state_interp ex. + Proof. + rewrite /aneris_events_state_interp. + iIntros (Hexvalid Hc Heq). + destruct c as [tp σ]; destruct c' as [tp' σ']; simplify_eq/=. + iSplit. + - iDestruct 1 as (As Ar lbls) "(#Hown&#HAs&#HAr&Hsend&Hrec&Halloc)". + iExists _, _, _; iFrame "#". + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (sendonEV_groups sag) ex)); + first iFrame "Hsend"; last first. + { intros sag; simpl; erewrite events_of_trace_extend_same_tp; [done|done| |done]; done. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (receiveonEV_groups sag) ex)); + first iFrame "Hrec"; last first. + { intros sag; simpl; erewrite events_of_trace_extend_same_tp; [done|done| |done]; done. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (allocEV sag) ex)); first by iFrame. + intros lbl; simpl; erewrite events_of_trace_extend_same_tp; [done|done| |done]; done. + - iDestruct 1 as (As Ar lbls) "(#Hown&#HAs&#HAr&Hsend&Hrec&Halloc)". + iExists _, _, _; iFrame "#". + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (sendonEV_groups sag) ex)); + first iFrame "Hsend"; last first. + { intros sag; simpl; erewrite events_of_trace_extend_same_tp; [done|done| |done]; done. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (receiveonEV_groups sag) ex)); + first iFrame "Hrec"; last first. + { intros sag; simpl; erewrite events_of_trace_extend_same_tp; [done|done| |done]; done. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (allocEV sag) ex)); first by iFrame. + intros lb; simpl; erewrite events_of_trace_extend_same_tp; [done|done| |done]; done. + Qed. + + Lemma aneris_events_state_interp_pure ex c oζ c': + valid_exec (ex :tr[oζ]: c') → + trace_ends_in ex c → + c.2 = c'.2 → + aneris_events_state_interp (ex :tr[oζ]: c') ⊣⊢ aneris_events_state_interp ex. + Proof. + rewrite /aneris_events_state_interp. + iIntros (Hexvalid Hc Heq). + destruct c as [tp σ]; destruct c' as [tp' σ']; simplify_eq/=. + iSplit. + - iDestruct 1 as (As Ar lbls) "(#Hown&#HAs&#HAr&Hsend&Hrec&Halloc)". + iExists _, _, _; iFrame "#". + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (sendonEV_groups sag) ex)); + first iFrame "Hsend"; last first. + { intros sag; simpl; erewrite events_of_trace_extend_pure; + [done| apply sendonEV_groups_impure |done| |done]; done. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (receiveonEV_groups sag) ex)); + first iFrame "Hrec"; last first. + { intros sag; simpl; erewrite events_of_trace_extend_pure; + [done| apply receiveonEV_groups_impure |done| |done]; done. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (allocEV sag) ex)); first by iFrame. + intros lbl; simpl; erewrite events_of_trace_extend_pure; + [done| apply allocEV_impure |done| |done]; done. + - iDestruct 1 as (As Ar lbls) "(#Hown&#HAs&#HAr&Hsend&Hrec&Halloc)". + iExists _, _, _; iFrame "#". + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (sendonEV_groups sag) ex)); + first iFrame "Hsend"; last first. + { intros sag; simpl; erewrite events_of_trace_extend_pure; + [done| apply sendonEV_groups_impure |done| |done]; done. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (receiveonEV_groups sag) ex)); + first iFrame "Hrec"; last first. + { intros sag; simpl; erewrite events_of_trace_extend_pure; + [done| apply receiveonEV_groups_impure |done| |done]; done. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (allocEV sag) ex)); first by iFrame. + intros lbl; simpl; erewrite events_of_trace_extend_pure; + [done| apply allocEV_impure |done| |done]; done. + Qed. + + Lemma aneris_events_state_interp_no_triggered' ex tp1 K e1 tp2 efs σ1 α e2 σ2 oζ: + valid_exec ex → + trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) → + head_step e1 σ1 α e2 σ2 efs → + (∀ sag, ¬ sendonEV_groups sag e1 σ1 e2 σ2) → + (∀ sag, ¬ receiveonEV_groups sag e1 σ1 e2 σ2) → + (∀ lbl, ¬ allocEV lbl e1 σ1 e2 σ2) → + aneris_events_state_interp (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) ⊣⊢ aneris_events_state_interp ex. + Proof. + rewrite /aneris_events_state_interp. + iIntros (Hexvalid Hei Hstep Hns Hnr Hna). + iSplit. + - iDestruct 1 as (As Ar lbls) "(#Hown&#HAs&#HAr&Hsend&Hrec&Halloc)". + iExists _, _, _; iFrame "#". + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (sendonEV_groups sag) ex)); + first iFrame "Hsend"; last first. + { intros sag; simpl. rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); eauto. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (receiveonEV_groups sag) ex)); + first iFrame "Hrec"; last first. + { intros sag; simpl. rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); eauto. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (allocEV sag) ex)); first by iFrame. + intros lbl; simpl. rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); eauto. + - iDestruct 1 as (As Ar lbls) "(#Hown&#HAs&#HAr&Hsend&Hrec&Halloc)". + iExists _, _, _; iFrame "#". + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (sendonEV_groups sag) ex)); + first iFrame "Hsend"; last first. + { intros sag; simpl. rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); eauto. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (receiveonEV_groups sag) ex)); + first iFrame "Hrec"; last first. + { intros sag; simpl. rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); eauto. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (allocEV sag) ex)); first by iFrame. + intros lbl; simpl. rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); eauto. + Qed. + + Lemma aneris_events_state_interp_no_triggered ex tp1 K e1 tp2 efs σ1 α e2 σ2 oζ : + valid_exec ex → + trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) → + head_step e1 σ1 α e2 σ2 efs → + (∀ sh mbody to, expr_e e1 ≠ SendTo sh mbody to ) → + (∀ sh, expr_e e1 ≠ ReceiveFrom sh) → + (∀ lbl e', expr_e e1 ≠ ref<< lbl >> e')%E → + aneris_events_state_interp (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) ⊣⊢ aneris_events_state_interp ex. + Proof. + intros ??? Hns Hnr Hna. + eapply aneris_events_state_interp_no_triggered'; [done|done|done| | |]. + - intros ? (?&?&?&?&?&?&?&?&?&?&?&?&?&?). + eapply Hns; simplify_eq; done. + - intros ? (?&?&?&?&?&?&?&?&?&?&?&?&?). + eapply Hnr; simplify_eq; done. + - intros ? (?&?&?&?&?&?&?&?&?). + eapply Hna; simplify_eq; done. + Qed. + + Lemma aneris_events_state_interp_alloc_triggered lbl evs ex tp1 K e1 α tp2 efs + σ1 e2 σ2 oζ : + valid_exec ex → + trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) → + head_step e1 σ1 α e2 σ2 efs → + allocEV lbl e1 σ1 e2 σ2 → + alloc_evs lbl evs -∗ + aneris_events_state_interp ex ==∗ + aneris_events_state_interp (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) ∗ + alloc_evs lbl (evs ++ [mkEventObservation e1 σ1 e2 σ2]). + Proof. + rewrite /aneris_events_state_interp. + iIntros (Hexvalid Hei Hstep HEV) "Hevs". + iDestruct 1 as (As Ar lbls) "(#Hown&#HAs&#HAr&Hsend&Hrec&Halloc)". + iDestruct (alloc_evs_lookup with "Halloc Hevs") as %[Hexevs ?]%lookup_fn_to_gmap. + iMod (alloc_evs_update with "Halloc Hevs") as "[Halloc $]". + iModIntro. + iExists _, _, _; iFrame "#". + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (sendonEV_groups sag) ex)); + first iFrame "Hsend"; last first. + { intros sag; simpl. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); + last eapply ev_not_others_alloc_groups; eauto. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (receiveonEV_groups sag) ex)); + first iFrame "Hrec"; last first. + { intros sag; simpl. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); + last eapply ev_not_others_alloc_groups; eauto. } + rewrite -fn_to_gmap_insert //. + erewrite fn_to_gmap_eq_fns; first iFrame "Halloc"; last first. + intros lbl'; simpl. + destruct (decide (lbl' = lbl)) as [->|Hneq]. + - rewrite fn_lookup_insert. + rewrite -Hexevs. + rewrite (events_of_trace_extend_triggered _ _ _ _ _ e1 _ α _ σ1); eauto. + - rewrite fn_lookup_insert_ne //. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); [done|done|done|done|]. + intros ?; apply Hneq; eapply allocEV_inj; done. + Qed. + + Lemma aneris_events_state_interp_send_triggered sag evs ex tp1 K e1 α tp2 efs + σ1 e2 σ2 oζ: + valid_exec ex → + trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) → + head_step e1 σ1 α e2 σ2 efs → + sendonEV_groups sag e1 σ1 e2 σ2 → + sendon_evs_groups sag evs -∗ + aneris_events_state_interp ex ==∗ + aneris_events_state_interp (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) ∗ + sendon_evs_groups sag (evs ++ [mkEventObservation e1 σ1 e2 σ2]). + Proof. + rewrite /aneris_events_state_interp. + iIntros (Hexvalid Hei Hstep HEV) "Hevs". + iDestruct 1 as (As Ar lbls) "(#Hown&#HAs&#HAr&Hsend&Hrec&Halloc)". + iDestruct (sendon_evs_lookup with "Hsend Hevs") as %[Hexevs ?]%lookup_fn_to_gmap. + iMod (sendon_evs_update with "Hsend Hevs") as "[Hsend $]". + iModIntro. + iDestruct (own_valid with "Hown") as %Hvalid. + setoid_rewrite auth_frag_valid in Hvalid. + setoid_rewrite disj_gsets_valid in Hvalid. + iExists _, _, _; iFrame "#". + erewrite (fn_to_gmap_eq_fns _ (λ lbl, events_of_trace (allocEV lbl) ex)); + first iFrame "Halloc"; last first. + { intros lbl; simpl. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); + last eapply ev_not_others_sendon_groups; eauto. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (receiveonEV_groups sag) ex)); + first iFrame "Hrec"; last first. + { intros sag'; simpl. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); + last eapply ev_not_others_sendon_groups; eauto. } + rewrite -fn_to_gmap_insert //. + erewrite fn_to_gmap_eq_fns; first iFrame "Hsend"; last first. + intros sag' Hsag'. + destruct (decide (sag' = sag)) as [->|Hneq]. + - rewrite fn_lookup_insert. + rewrite -Hexevs. + rewrite (events_of_trace_extend_triggered _ _ _ _ _ e1 _ α _ σ1); eauto. + - rewrite fn_lookup_insert_ne //. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); [done|done|done|done|]. + intros ?. apply Hneq. + eapply sendonEV_groups_inj; [ apply Hvalid; set_solver | | ]; done. + Qed. + + Lemma aneris_events_state_interp_send_untracked sag rtrck R T ex tp1 K e1 α tp2 + efs σ1 e2 σ2 oζ: + valid_exec ex → + trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) → + head_step e1 σ1 α e2 σ2 efs → + sendonEV_groups sag e1 σ1 e2 σ2 → + sag ⤳*[false, rtrck] (R, T) -∗ + aneris_events_state_interp ex -∗ + aneris_events_state_interp (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) ∗ + sag ⤳*[false, rtrck] (R, T). + Proof. + rewrite /aneris_events_state_interp. + iIntros (Hexvalid Hei Hstep HEV) "Hsag". + iDestruct (messages_mapsto_observed with "Hsag") as "[$ Hsag]". + iDestruct "Hsag" as (As Ar) "(#HAs&#HAr&#Hown&%HAssa&%HArsa)". + iDestruct 1 as (As' Ar' lbls) "(#Hown'&#HAs'&#HAr'&Hsend&Hrecv&Halloc)". + iDestruct (observed_send_agree with "HAs HAs'") as %<-. + iDestruct (observed_receive_agree with "HAr HAr'") as %<-. + iExists _, _, _; iFrame "#". + iDestruct (own_op with "[Hown Hown']") as "Hown''". + { iSplit; [ iApply "Hown" | iApply "Hown'" ]. } + rewrite -auth_frag_op. + iDestruct (own_valid with "Hown''") as %Hvalid. + setoid_rewrite auth_frag_valid in Hvalid. + setoid_rewrite disj_gsets_valid in Hvalid. + erewrite (fn_to_gmap_eq_fns _ (λ lbl, events_of_trace (allocEV lbl) ex)); + first iFrame "Halloc"; last first. + { intros lbl; simpl. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); + last eapply ev_not_others_sendon_groups; eauto. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (receiveonEV_groups sag) ex)); + first iFrame "Hrecv"; last first. + { intros sag'; simpl. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); + last eapply ev_not_others_sendon_groups; eauto. } + erewrite fn_to_gmap_eq_fns; first iFrame "Hsend"; last first. + intros sag'. + destruct (decide (sag' = sag)) as [->|Hneq]. + - rewrite HAssa; done. + - intros Hsa'. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); [done|done|done|done|]. + intros ?; apply Hneq. eapply sendonEV_groups_inj; eauto. + apply Hvalid; set_solver. + Qed. + + Lemma aneris_events_state_interp_receive_triggered sag evs ex tp1 K e1 α tp2 + efs σ1 e2 σ2 oζ : + valid_exec ex → + trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) → + head_step e1 σ1 α e2 σ2 efs → + receiveonEV_groups sag e1 σ1 e2 σ2 → + receiveon_evs_groups sag evs -∗ + aneris_events_state_interp ex ==∗ + aneris_events_state_interp (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) ∗ + receiveon_evs_groups sag (evs ++ [mkEventObservation e1 σ1 e2 σ2]). + Proof. + rewrite /aneris_events_state_interp. + iIntros (Hexvalid Hei Hstep HEV) "Hevs". + iDestruct 1 as (As Ar lbls) "(#Hown&#HAs&#HAr&Hsend&Hrec&Halloc)". + iDestruct (receiveon_evs_lookup with "Hrec Hevs") + as %[Hexevs ?]%lookup_fn_to_gmap. + iMod (receiveon_evs_update with "Hrec Hevs") as "[Hrec $]". + iDestruct (own_valid with "Hown") as %Hvalid. + setoid_rewrite auth_frag_valid in Hvalid. + setoid_rewrite disj_gsets_valid in Hvalid. + iModIntro. + iExists _, _, _; iFrame "#". + erewrite (fn_to_gmap_eq_fns _ (λ lbl, events_of_trace (allocEV lbl) ex)); + first iFrame "Halloc"; last first. + { intros lbl; simpl. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); + last eapply ev_not_others_receiveon_groups; eauto. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (sendonEV_groups sag) ex)); + first iFrame "Hsend"; last first. + { intros sag'; simpl. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); + last eapply ev_not_others_receiveon_groups; eauto. } + rewrite -fn_to_gmap_insert //. + erewrite fn_to_gmap_eq_fns; first iFrame "Hrec"; last first. + intros sag' Hsag'. + destruct (decide (sag' = sag)) as [->|Hneq]. + - rewrite fn_lookup_insert. + rewrite -Hexevs. + rewrite (events_of_trace_extend_triggered _ _ _ _ _ e1 _ α _ σ1); eauto. + - rewrite fn_lookup_insert_ne //. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); [done|done|done|done|]. + intros ?; apply Hneq. + eapply receiveonEV_groups_inj; [ apply Hvalid; set_solver | | ]; done. + Qed. + + Lemma aneris_events_state_interp_receive_untracked sag strck R T ex tp1 K e1 α + tp2 efs σ1 e2 σ2 oζ : + valid_exec ex → + trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) → + head_step e1 σ1 α e2 σ2 efs → + receiveonEV_groups sag e1 σ1 e2 σ2 → + sag ⤳*[strck, false] (R, T) -∗ + aneris_events_state_interp ex -∗ + aneris_events_state_interp (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) ∗ + sag ⤳*[strck, false] (R, T). + Proof. + rewrite /aneris_events_state_interp. + iIntros (Hexvalid Hei Hstep HEV) "Hsag". + iDestruct (messages_mapsto_observed with "Hsag") as "[$ Hsag]". + iDestruct "Hsag" as (As Ar) "(#HAs&#HAr&#Hown&%HAssa&%HArsa)". + iDestruct 1 as (As' Ar' lbls) "(#Hown'&HAs'&#HAr'&Hsend&Hrec&Halloc)". + iDestruct (observed_send_agree with "HAs HAs'") as %<-. + iDestruct (observed_receive_agree with "HAr HAr'") as %<-. + iExists _, _, _; iFrame "#". + iDestruct (own_op with "[Hown Hown']") as "Hown''". + { iSplit; [ iApply "Hown" | iApply "Hown'" ]. } + rewrite -auth_frag_op. + iDestruct (own_valid with "Hown''") as %Hvalid. + setoid_rewrite auth_frag_valid in Hvalid. + setoid_rewrite disj_gsets_valid in Hvalid. + erewrite (fn_to_gmap_eq_fns _ (λ lbl, events_of_trace (allocEV lbl) ex)); + first iFrame "Halloc"; last first. + { intros lbl; simpl. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); + last eapply ev_not_others_receiveon_groups; eauto. } + erewrite (fn_to_gmap_eq_fns _ (λ sag, events_of_trace (sendonEV_groups sag) ex)); + first iFrame "Hsend"; last first. + { intros sag'; simpl. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); + last eapply ev_not_others_receiveon_groups; eauto. } + erewrite fn_to_gmap_eq_fns; first iFrame "Hrec"; last first. + intros sag'. + destruct (decide (sag' = sag)) as [->|Hneq]. + - rewrite HArsa; done. + - intros Hsag'. + rewrite (events_of_trace_extend_not_triggered _ _ _ _ _ e1 _ α _ σ1); [done|done|done|done|]. + intros ?; apply Hneq; eapply receiveonEV_groups_inj; try eauto. + apply Hvalid; set_solver. + Qed. + +End state_interpretation. diff --git a/fairneris/aneris_lang/state_interp/state_interp_free_ips_coh.v b/fairneris/aneris_lang/state_interp/state_interp_free_ips_coh.v new file mode 100644 index 0000000..73dd4a5 --- /dev/null +++ b/fairneris/aneris_lang/state_interp/state_interp_free_ips_coh.v @@ -0,0 +1,257 @@ +From stdpp Require Import fin_maps gmap. +From iris.bi.lib Require Import fractional. +From iris.proofmode Require Import tactics. +From iris.base_logic.lib Require Import saved_prop gen_heap. +From fairneris Require Import fuel env_model. +From fairneris.lib Require Import gen_heap_light. +From fairneris.aneris_lang Require Import + aneris_lang network resources. +From fairneris.aneris_lang.state_interp Require Import + state_interp_def. + +From RecordUpdate Require Import RecordSet. +Set Default Proof Using "Type". + +Import uPred. +Import RecordSetNotations. + +Section state_interpretation. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + Definition ip_is_free (ip : ip_address) (σ : state aneris_lang) : Prop := + state_heaps σ !! ip = None ∧ state_sockets σ !! ip = None. + + (** free_ips_coh *) + Lemma free_ips_coh_init ips σ : + (∀ ip, ip ∈ ips → ip_is_free ip σ) → + free_ips_auth ips ∗ free_ports_auth ∅ -∗ + free_ips_coh σ. + Proof. + iIntros (Hip) "[HipsCtx HPiu]". + iExists _, _; iFrame. + iPureIntro. set_solver. + Qed. + + (** free_ips_coh_strong *) + Lemma free_ips_coh_init_strong ips Ps σ : + dom Ps ## ips → + (∀ ip, ip ∈ ips → ip_is_free ip σ) → + ((∀ ip ps, Ps !! ip = Some (GSet ps) → + ∀ Sn, (state_sockets σ) !! ip = Some Sn → + ∀ p, p ∈ ps → port_not_in_use p Sn)) → + free_ips_auth ips ∗ free_ports_auth Ps -∗ + free_ips_coh σ. + Proof. + iIntros (Hdisj Hip Hnuse) "[HipsCtx HPiu]". + iExists _, _; iFrame. + iPureIntro. done. + Qed. + + Lemma free_ips_coh_free_ports_valid σ a Sn : + state_sockets σ !! ip_of_address a = Some Sn → + free_ips_coh σ -∗ + free_ports (ip_of_address a) {[port_of_address a]} -∗ + ⌜port_not_in_use (port_of_address a) Sn⌝. + Proof. + iDestruct 1 as (Fip Piu (Hdsj & HFip)) "[HfCtx HpCtx]". iIntros "Hp". + iDestruct (free_ports_included with "HpCtx Hp") as (?) "[%Hlookup %]". + unfold port_not_in_use. iPureIntro. intros sh skt sa r Hsh Hsa. + destruct HFip as [? HFip]. eapply HFip; eauto. set_solver. + Qed. + + Lemma free_ips_coh_alloc_node σ ip ports : + free_ips_coh σ -∗ + free_ip ip ==∗ + free_ips_coh (σ <| state_heaps := <[ip:=∅]> (state_heaps σ)|> + <| state_sockets := <[ip:=∅]> (state_sockets σ) |>) ∗ + free_ports ip ports. + Proof. + iDestruct 1 as (Fip Piu (Hdsj & HFip)) "[HfCtx HpCtx]". + iIntros "Hfip". + iDestruct (free_ip_included with "HfCtx Hfip") as %Hin. + iMod (free_ip_dealloc with "HfCtx Hfip") as "HfCtx". + iMod (free_ports_alloc _ ip ports with "HpCtx") as "[HpCtx Hports]"; + [set_solver|]. + iModIntro. iFrame. iExists _, _. simpl. iFrame. iPureIntro. + split; [set_solver|]. split. + { intros. rewrite !lookup_insert_ne //; set_solver. } + intros ip' ??????????. + destruct (decide (ip = ip')). + - subst. simpl_map. naive_solver. + - simplify_map_eq. eapply HFip; eauto. + Qed. + + Lemma free_ips_coh_update_heap σ ip h h' : + state_heaps σ !! ip = Some h → + free_ips_coh σ -∗ + free_ips_coh (σ <| state_heaps := <[ip:=h']> (state_heaps σ) |>). + Proof. + iIntros (?). + iDestruct 1 as (Fip Piu (Hdsj & HFip)) "[HfCtx HpCtx]". + iExists _, _. simpl. iFrame. iPureIntro. + split; auto. split; try apply HFip. + intros ip' ?. + split; [|set_solver]. + destruct (decide (ip = ip')); simplify_map_eq; [set_solver|]. + by apply HFip. + Qed. + + Lemma free_ips_coh_alloc_socket σ ip Sn sh s: + let σ' := + σ <| state_sockets := <[ip:=<[sh:=(s, [])]> Sn]> (state_sockets σ) |> in + saddress s = None → + state_sockets σ !! ip = Some Sn → + Sn !! sh = None → + free_ips_coh σ -∗ free_ips_coh σ'. + Proof. + iIntros (????). + iDestruct 1 as (Fip Piu (Hdsj & HFip)) "[HfCtx HpCtx]". + iExists _, _. iFrame. iPureIntro. + split; [done|]. simpl. split. + - intros ip' ?. split; [by eapply HFip|]. + destruct (decide (ip = ip')); simplify_map_eq; [set_solver|]. + by apply HFip. + - intros ip' ??????????. + destruct (decide (ip = ip')) as [->|Hipneq]. + + simplify_map_eq. + destruct (decide (sh = sh0)) as [->|Hshneq]. + * intros Hsocket ?. rewrite lookup_insert in Hsocket. by simplify_eq. + * intros Hsocket ?. apply (lookup_insert_ne Sn sh sh0 (s, [])) in Hshneq. + rewrite Hshneq in Hsocket. by eapply HFip. + + simplify_map_eq. by eapply HFip. + Qed. + + Lemma free_ips_coh_dealloc σ1 a sh skt Sn : + let ip := ip_of_address a in + let S' := <[ip := <[sh:=(skt<| saddress := Some a |>, [])]> Sn]> + (state_sockets σ1) in + let σ2 := σ1 <| state_sockets := S' |> in + state_sockets σ1 !! ip = Some Sn → + free_ips_coh σ1 -∗ + free_ports (ip_of_address a) {[port_of_address a]} ==∗ + free_ips_coh σ2. + Proof. + rewrite /free_ips_coh /=. + iDestruct 1 as (Fip Piu (Hdsj & HFip)) "[HfCtx HpCtx]". + iIntros "Hp". + iMod (free_ports_dealloc with "HpCtx Hp") + as (ps' [Hps' Hin%elem_of_subseteq_singleton]) "HpCtx". + iModIntro. iExists _, _; iFrame. iPureIntro. + split; [set_solver|]. split. + - intros ip ?. + destruct (decide (ip = ip_of_address a)); simplify_eq; [set_solver|]. + rewrite lookup_insert_ne //. by apply HFip. + - intros ip ??????????. + destruct (decide (ip= (ip_of_address a))) as [->|Hipneq]. + + simplify_map_eq. destruct (decide (sh = sh0)) as [->|Hsneq]. + * intros Hsockets ?. apply lookup_insert_rev in Hsockets. set_solver. + * apply (lookup_insert_ne Sn sh sh0 + ({| saddress := Some a; sblock := sblock skt |}, [])) in Hsneq. + intros Hsockets ?. rewrite Hsneq in Hsockets. set_solver. + + simplify_map_eq. eapply HFip; eauto. + Qed. + +Lemma free_ips_coh_update_msg sh a skt Sn r m σ1 : + let ip := ip_of_address a in + let S' := <[ip := <[sh:=(skt, r)]> Sn]> (state_sockets σ1) in + let σ2 := σ1 <| state_sockets := S' |> in + Sn !! sh = Some (skt, r ++ [m]) → + state_sockets σ1 !! ip_of_address a = Some Sn → + free_ips_coh σ1 -∗ free_ips_coh σ2. + Proof. + rewrite /free_ips_coh /=. + iDestruct 1 as (Fip Piu (Hdsj & HFip)) "[HfCtx HpCtx]". + iExists _, _. iFrame. iPureIntro. + split; [auto|]. split. + - intros ip ?. split; [set_solver|]. + destruct (decide (ip = ip_of_address a)); simplify_map_eq; [set_solver|]. + by apply HFip. + - intros ip ??????????. destruct (decide (ip = (ip_of_address a))) as [->|Hipneq]. + + simpl_map. simplify_eq. intros Hsockets ?. + destruct (decide (sh = sh0)) as [->|Hshneq]. + * apply (lookup_insert_rev Sn sh0 + (skt, r) (skt0, r0)) in Hsockets. simplify_eq. + eapply HFip; eauto. + * apply (lookup_insert_ne Sn sh sh0 (skt, r)) in Hshneq. + rewrite Hshneq in Hsockets. eapply HFip; eauto. + + simplify_map_eq. eapply HFip; eauto. + Qed. + + Lemma free_ips_coh_deliver_message σ Ms Sn Sn' ip sh skt a R m : + m ∈ messages_to_receive_at a Ms → + (state_sockets σ) !! ip = Some Sn → + Sn !! sh = Some (skt, R) → + Sn' = <[sh:=(skt, m :: R)]> Sn → + saddress skt = Some a → + free_ips_coh σ -∗ + free_ips_coh + {| state_heaps := state_heaps σ; + state_sockets := <[ip:=Sn']> (state_sockets σ); + state_ms := state_ms σ |}. + Proof. + rewrite /free_ips_coh /=. + iDestruct 1 as (Fip Piu (Hdsj & HFip)) "[HfCtx HpCtx]". + iExists _, _. simpl. iFrame. iPureIntro. + split; [auto|]. split. + - intros ip' ?. + ddeq ip ip'. + + naive_solver. + + destruct (decide (ip' = ip_of_address a)); simplify_map_eq; [set_solver|]. + by apply HFip. + - intros ip' ??????????. + destruct (decide (ip = ip')) as [->|Hipneq]. + + simpl_map. simplify_eq. intros Hsockets ?. + destruct (decide (sh = sh0)) as [->|Hshneq]. + * apply (lookup_insert_rev Sn sh0 + (skt, m :: R) (skt0, r)) in Hsockets. + simplify_eq. eapply HFip; eauto. + * apply (lookup_insert_ne Sn sh sh0 + (skt, m :: R)) in Hshneq. rewrite Hshneq in Hsockets. + eapply HFip; eauto. + + simplify_map_eq. eapply HFip; eauto. + Qed. + + Lemma free_ips_coh_update_sblock σ1 a Sn sh skt b r : + let ip := ip_of_address a in + let S := <[ip := <[sh:= (skt<| sblock := b|>, r)]> Sn]>(state_sockets σ1) in + let σ2 := σ1 <| state_sockets := S |> in + state_sockets σ1 !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + free_ips_coh σ1 ==∗ free_ips_coh σ2. + Proof. + iIntros (?). + iDestruct 1 as (Fip Piu (Hdsj & HFip)) "[HfCtx HpCtx]". + iExists _, _. simpl. iFrame. iPureIntro. + split; auto. split. + - intros ip' Hip'. + simplify_map_eq. subst S. + ddeq ip ip'; set_solver. + - intros ip' ??????????. unfold S in H2. + destruct (decide (ip = ip')) as [->|Hipneq]. + -- simpl_map. simplify_eq. intros Hsockets ?. + destruct (decide (sh = sh0)) as [->|Hshneq]. + + apply (lookup_insert_rev Sn sh0 + ({| saddress := saddress skt; sblock := b |}, r) (skt0, r0)) in Hsockets. + simplify_eq. eapply HFip; eauto. + + apply (lookup_insert_ne Sn sh sh0 + ({| saddress := saddress skt; sblock := b |}, r)) in Hshneq. + rewrite Hshneq in Hsockets. eapply HFip; eauto. + -- simplify_map_eq. eapply HFip; eauto. + Qed. + + Lemma free_ips_coh_ms hps skts ms1 ms2 : + free_ips_coh {| + state_heaps := hps; + state_sockets := skts; + state_ms := ms1; + |} -∗ + free_ips_coh {| + state_heaps := hps; + state_sockets := skts; + state_ms := ms2; + |}. + Proof. by eauto. Qed. + +End state_interpretation. diff --git a/fairneris/aneris_lang/state_interp/state_interp_gnames_coh.v b/fairneris/aneris_lang/state_interp/state_interp_gnames_coh.v new file mode 100644 index 0000000..74a0d38 --- /dev/null +++ b/fairneris/aneris_lang/state_interp/state_interp_gnames_coh.v @@ -0,0 +1,52 @@ +From stdpp Require Import fin_maps gmap. +From fairneris Require Import fuel env_model. +From fairneris.aneris_lang Require Import aneris_lang network resources. +From fairneris.aneris_lang.state_interp Require Import state_interp_def. +From RecordUpdate Require Import RecordSet. +Set Default Proof Using "Type". + +Import uPred. +Import RecordSetNotations. + +Section state_interpretation. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + (** gnames_coh *) + Lemma gnames_coh_singleton ip γs h Sn : + gnames_coh {[ip:=γs]} {[ip:=h]} {[ip:=Sn]}. + Proof. rewrite /gnames_coh !dom_singleton_L //. Qed. + + Lemma gnames_coh_valid γm H S ip : + H !! ip = None → + gnames_coh γm H S → + γm !! ip = None. + Proof. rewrite -!not_elem_of_dom => _ [-> _] //. Qed. + + Lemma gnames_coh_alloc_node γm H S ip γn : + gnames_coh γm H S → + gnames_coh (<[ip:=γn]> γm) (<[ip:=∅]> H) (<[ip:=∅]> S). + Proof. rewrite /gnames_coh. set_solver. Qed. + + Lemma gnames_coh_update_heap n γm H S h h' : + H !! n = Some h → + gnames_coh γm H S → + gnames_coh γm (<[n:=h']> H) S. + Proof. + intros ?%elem_of_dom_2 [? ?]. + rewrite /gnames_coh dom_insert_L subseteq_union_1_L //=. + set_solver. + Qed. + + Lemma gnames_coh_update_sockets n γm H S Sn Sn' : + S !! n = Some Sn → + gnames_coh γm H S → + gnames_coh γm H (<[n:=Sn']> S). + Proof. + intros ?%elem_of_dom_2 [? ?]. + rewrite /gnames_coh dom_insert_L subseteq_union_1_L //=. + set_solver. + Qed. + +End state_interpretation. diff --git a/fairneris/aneris_lang/state_interp/state_interp_local_coh.v b/fairneris/aneris_lang/state_interp/state_interp_local_coh.v new file mode 100644 index 0000000..96a203e --- /dev/null +++ b/fairneris/aneris_lang/state_interp/state_interp_local_coh.v @@ -0,0 +1,288 @@ +From stdpp Require Import fin_maps gmap. +From iris.bi.lib Require Import fractional. +From iris.proofmode Require Import tactics. +From iris.base_logic.lib Require Import saved_prop gen_heap. +From fairneris Require Import fairness fuel env_model. +From fairneris.lib Require Import gen_heap_light. +From fairneris.aneris_lang Require Export aneris_lang network resources. +From fairneris.aneris_lang.state_interp Require Export state_interp_def. + +From RecordUpdate Require Import RecordSet. +Set Default Proof Using "Type". + +Import uPred. +Import RecordSetNotations. + +Section state_interpretation. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + (** local_state_coh *) + Lemma local_state_coh_heaps n γs γm σ : + γm !! n = Some γs → + ([∗ map] n' ↦ γs ∈ γm, local_state_coh σ n' γs) -∗ + ∃ h, ⌜(state_heaps σ) !! n = Some h⌝. + Proof. + iIntros (?) "Hmap". + iDestruct (big_sepM_lookup with "Hmap") as "Hl"; [done|]. + iDestruct "Hl" as (????) "_"; eauto. + Qed. + + Lemma local_state_coh_sockets n γs γm σ : + γm !! n = Some γs → + ([∗ map] n' ↦ γs ∈ γm, local_state_coh σ n' γs) -∗ + ∃ Sn, ⌜(state_sockets σ) !! n = Some Sn⌝. + Proof. + iIntros (?) "Hmap". + iDestruct (big_sepM_lookup with "Hmap") as "Hl"; [done|]. + iDestruct "Hl" as (????) "_"; eauto. + Qed. + + Lemma local_state_coh_alloc_heap σ n γs l v h : + let σ' := σ <| state_heaps := <[n:=<[l:=v]> h]> (state_heaps σ) |> in + state_heaps σ !! n = Some h → + h !! l = None → + is_node n -∗ + local_state_coh σ n γs ==∗ local_state_coh σ' n γs ∗ l ↦[n] v. + Proof. + simpl. iIntros (??) "Hn Hstate". iDestruct "Hn" as (?) "#Hn". + iDestruct "Hstate" as (h' S Hh Hs) "(Hn' & Hheap & ?)". + iDestruct (mapsto_node_agree with "Hn Hn'") as %->. + simplify_eq. + iMod (gen_heap_light_alloc with "Hheap") as "[Hheap Hl]"; [done|]. + iModIntro. iFrame. + iSplitR "Hl"; [| iExists _; eauto]. + iExists _, _. iFrame. + rewrite lookup_insert //. + Qed. + + Lemma local_state_coh_valid_heap σ n γs l v q : + local_state_coh σ n γs -∗ + l ↦[n]{q} v -∗ + ∃ h, ⌜state_heaps σ !! n = Some h ∧ h !! l = Some v⌝. + Proof. + iDestruct 1 as (h' S Hh Hs) "(Hn & Hheap & Hsock)". + iDestruct 1 as (γs') "[Hn' Hl]". + iDestruct (mapsto_node_agree with "Hn Hn'") as %->. + iDestruct (gen_heap_light_valid with "Hheap Hl") as "%". + iExists _. iPureIntro; eauto. + Qed. + + Lemma local_state_coh_update_heap σ1 n γs h l v1 v2 : + let σ2 := (σ1 <| state_heaps := <[n:=<[l:=v2]> h]> (state_heaps σ1) |>) in + state_heaps σ1 !! n = Some h → + local_state_coh σ1 n γs ∗ l ↦[n] v1 ==∗ local_state_coh σ2 n γs ∗ l ↦[n] v2. + Proof. + simpl. iIntros (?) "[Hstate Hl]". + iDestruct "Hstate" as (h' Sn Hh Hs) "(#Hn & Hheap & ?)". + iDestruct "Hl" as (γs') "[Hn' Hl]". + iDestruct (mapsto_node_agree with "Hn Hn'") as %->. + simplify_eq. + iMod (gen_heap_light_update with "Hheap Hl") as "[Hheap' Hl]". + iModIntro. iFrame. + iSplitR "Hl"; [| iExists _; eauto]. + iExists _, _. iFrame. + rewrite lookup_insert /set /=; eauto. + Qed. + + Lemma local_state_coh_valid_sockets σ ip γs sh q skt : + local_state_coh σ ip γs -∗ + sh ↪[ip]{q} skt -∗ + ∃ Sn r, ⌜state_sockets σ !! ip = Some Sn ∧ Sn !! sh = Some (skt, r)⌝. + Proof. + iDestruct 1 as (h' Sn Hh Hs) "(Hn & Hh & Hs)". + iDestruct 1 as (γs') "[Hn' Hsh]". + iDestruct (mapsto_node_agree with "Hn Hn'") as %->. + iDestruct (gen_heap_light_valid with "Hs Hsh") as "%Hfd". + rewrite lookup_fmap in Hfd. + destruct (@lookup _ _ (gmap _ _) _ sh Sn) as [[skt' r]|] eqn:Hskteq; + simplify_eq/=; eauto. + Qed. + + Lemma local_state_coh_alloc_socket σ ip γs sh Sn skt: + let σ' := σ <| state_sockets := + <[ip:=<[sh:=(skt, [])]> Sn]> (state_sockets σ)|> in + state_sockets σ !! ip = Some Sn → + Sn !! sh = None → + is_node ip -∗ + local_state_coh σ ip γs ==∗ + local_state_coh σ' ip γs ∗ sh ↪[ip] skt. + Proof. + simpl. iIntros (? HSn) "Hn Hstate". iDestruct "Hn" as (?) "#Hn". + iDestruct "Hstate" as (h' Sn' Hh Hs) "(Hn' & Hh & Hs)". + iDestruct (mapsto_node_agree with "Hn Hn'") as %->. + simplify_eq. + iMod (gen_heap_light_alloc _ sh _ ((skt, ∅ : message_soup).1) with "Hs") + as "[Hsock Hsh]". + { rewrite lookup_fmap HSn //. } + iModIntro. iFrame. + iSplitR "Hsh"; [|iExists _; eauto]. + iExists _, (<[sh:=(skt, [])]> Sn). + rewrite lookup_insert fmap_insert. + eauto with iFrame. + Qed. + + Lemma local_state_coh_socketbind σ1 γs sh skt a Sn r : + let ip := ip_of_address a in + let S' := + <[ip := + <[sh:=(skt<| saddress := Some a |>, r)]> Sn]> (state_sockets σ1) in + let σ2 := σ1 <| state_sockets := S' |> in + state_sockets σ1 !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + saddress skt = None → + local_state_coh σ1 ip γs ∗ sh ↪[ip] skt ==∗ + local_state_coh σ2 ip γs ∗ sh ↪[ip] (skt<| saddress := Some a |>). + Proof. + simpl. iIntros (???) "[Hlcoh Hsh]". + iDestruct "Hlcoh" as (h' S Hh Hs) "(#Hn & ? & Hsock)". + iDestruct "Hsh" as (γs') "[Hn' Hsh]". + iDestruct (mapsto_node_agree with "Hn Hn'") as %<-. + simplify_eq. + iMod (gen_heap_light_update _ _ _ _ ((skt<| saddress := Some a |>, r).1) + with "Hsock Hsh") as "[Hsock' Hsh]". + rewrite -fmap_insert /=. + iModIntro. iFrame. + iSplitR "Hsh"; [| iExists _; eauto]. + iExists _, _; iFrame. + rewrite lookup_insert /=; eauto. + Qed. + + Lemma local_state_coh_update_rb a sh skt σ1 γs Sn r r' : + let ip := ip_of_address a in + let S' := <[ip := <[sh:=(skt, r')]> Sn]> (state_sockets σ1) in + let σ2 := σ1 <| state_sockets := S' |> in + state_sockets σ1 !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + local_state_coh σ1 ip γs ∗ sh ↪[ip] skt ==∗ + local_state_coh σ2 ip γs ∗ sh ↪[ip] skt. + Proof. + iIntros (?????) "[Hstate Hsh]". + iDestruct "Hstate" as (h' S Hh Hs) "(#Hn & ? & Hsock)". + iDestruct "Hsh" as (γs') "[Hn' Hsh]". + iDestruct (mapsto_node_agree with "Hn Hn'") as %->. + simplify_eq. + iMod (gen_heap_light_update _ _ _ _ ((skt, r').1) + with "Hsock Hsh") as "[Hsock' Hsh]". + iModIntro. iFrame. iSplitR "Hsh". + { iExists _, _. iFrame. rewrite lookup_insert //. + iSplit; first done. iSplit; first done. + rewrite fmap_insert /=. eauto with iFrame. } + iExists _; eauto. + Qed. + + Lemma local_state_coh_update_sblock a sh skt σ1 γs Sn r b : + let ip := ip_of_address a in + let S := <[ip := <[sh:= (skt<| sblock := b|>, r)]> Sn]>(state_sockets σ1) in + let σ2 := σ1 <| state_sockets := S |> in + state_sockets σ1 !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + local_state_coh σ1 ip γs ∗ sh ↪[ip] skt ==∗ + local_state_coh σ2 ip γs ∗ sh ↪[ip] (skt<|sblock := b|>). + Proof. + simpl. iIntros (??) "[Hstate Hsh]". + iDestruct "Hstate" as (h' S Hh Hs) "(#Hn & ? & Hsock)". + iDestruct "Hsh" as (γs') "[Hn' Hsh]". + iDestruct (mapsto_node_agree with "Hn Hn'") as %->. + simplify_eq. + iMod (gen_heap_light_update _ _ _ _ ((skt<|sblock := b|>, r).1) + with "Hsock Hsh") as "[Hsock' Hsh]". + iModIntro. iFrame. iSplitR "Hsh". + { iExists _, _. iFrame. rewrite lookup_insert //. + iSplit; first done. iSplit; first done. + rewrite fmap_insert /=. eauto with iFrame. } + iExists _; eauto. + Qed. + + Lemma big_sepM_local_state_coh_insert n γs γm σ : + γm !! n = Some γs → + local_state_coh σ n γs -∗ + ([∗ map] n' ↦ x ∈ delete n γm, local_state_coh σ n' x) -∗ + [∗ map] n' ↦ x ∈ γm, local_state_coh σ n' x. + Proof. + iIntros (Hlookup%insert_id) "Hl Hmap". + iDestruct (big_sepM_insert with "[$]") as "HP". + { apply lookup_delete. } + rewrite insert_delete_insert Hlookup //. + Qed. + + Lemma big_sepM_local_state_coh_delete n γs γm σ : + γm !! n = Some γs → + ([∗ map] n' ↦ x ∈ γm, local_state_coh σ n' x) -∗ + local_state_coh σ n γs ∗ + [∗ map] n' ↦ x ∈ delete n γm, local_state_coh σ n' x. + Proof. iIntros (?) "?"; rewrite -big_sepM_delete //. Qed. + + + Lemma big_sepM_local_state_coh_alloc_node n γm σ : + γm !! n = None → + ([∗ map] n' ↦ x ∈ γm, local_state_coh σ n' x) -∗ + [∗ map] n' ↦ x ∈ γm, + local_state_coh (σ <| state_heaps := <[n:=∅]> (state_heaps σ)|> + <| state_sockets := <[n:=∅]> (state_sockets σ) |>) n' x. + Proof. + intros ?. + iApply big_sepM_mono. + intros n' x Hdel. + destruct (decide (n = n')); simplify_eq. + rewrite /local_state_coh !lookup_insert_ne //. + Qed. + + Lemma big_sepM_local_state_coh_update_heap_notin n γm σ1 h : + let σ2 := (σ1 <| state_heaps := <[n:=h]>(state_heaps σ1) |>) in + γm !! n = None → + ([∗ map] n' ↦ x ∈ γm, local_state_coh σ1 n' x) -∗ + [∗ map] n' ↦ x ∈ γm, local_state_coh σ2 n' x. + Proof. + simpl. intros ?. + iApply big_sepM_mono. + intros n' x Hdel. + destruct (decide (n = n')); simplify_eq. + rewrite /local_state_coh lookup_insert_ne //. + Qed. + + + Lemma big_sepM_local_state_coh_update_socket_notin n γm Sn σ1 : + let σ2 := (σ1 <| state_sockets := <[n:=Sn]>(state_sockets σ1) |>) in + γm !! n = None → + ([∗ map] n' ↦ x ∈ γm, local_state_coh σ1 n' x) -∗ + [∗ map] n' ↦ x ∈ γm, local_state_coh σ2 n' x. + Proof. + simpl. intros ?. + iApply big_sepM_mono. + intros n' x Hdel. + destruct (decide (n = n')); simplify_eq. + rewrite /local_state_coh lookup_insert_ne //. + Qed. + + Lemma local_state_coh_deliver_message γm σ Ms Sn Sn' ip sh skt a R m : + m ∈ messages_to_receive_at a Ms → + (state_sockets σ) !! ip = Some Sn → + Sn !! sh = Some (skt, R) → + Sn' = <[sh:=(skt, m :: R)]> Sn → + saddress skt = Some a → + ([∗ map] ip0↦γs ∈ γm, local_state_coh σ ip0 γs) -∗ + [∗ map] ip0↦γs ∈ γm, local_state_coh + {| state_heaps := state_heaps σ; + state_sockets := <[ip:=Sn']> (state_sockets σ); + state_ms := state_ms σ |} ip0 γs. + Proof. + iIntros (HM Hσ Hsh -> Hskt) "Hγm". + iApply big_sepM_mono; last done. + iIntros (ip' γ Hγ) "Hx". + iDestruct "Hx" as (h Sn' Hip' Hσip') "(Hγ1 & Hγ2 & Hγ3)". + destruct (decide (ip = ip')) as [->|]. + - simplify_eq. + rewrite /local_state_coh /= lookup_insert. + iExists _, _. + iSplit; first done. + iSplit; first done. + rewrite fmap_insert /=. + rewrite insert_id; first by iFrame. + rewrite lookup_fmap Hsh //=. + - rewrite /local_state_coh /= lookup_insert_ne //=. + iExists _, _; eauto with iFrame. + Qed. + +End state_interpretation. diff --git a/fairneris/aneris_lang/state_interp/state_interp_messages_history.v b/fairneris/aneris_lang/state_interp/state_interp_messages_history.v new file mode 100644 index 0000000..ce08632 --- /dev/null +++ b/fairneris/aneris_lang/state_interp/state_interp_messages_history.v @@ -0,0 +1,360 @@ +From RecordUpdate Require Import RecordSet. +From stdpp Require Import fin_maps gmap option gmultiset. +From iris.bi.lib Require Import fractional. +From iris.proofmode Require Import tactics. +From iris.base_logic.lib Require Import saved_prop gen_heap. +From trillium.program_logic Require Export traces. +From fairneris.prelude Require Import collect gmultiset. +From fairneris.lib Require Import gen_heap_light. +From fairneris.aneris_lang Require Export aneris_lang network resources. +From fairneris.aneris_lang.state_interp Require Import + state_interp_def + state_interp_network_sockets_coh + state_interp_socket_interp_coh + state_interp_messages_history_coh. + +Set Default Proof Using "Type". + +Import uPred. +Import RecordSetNotations. + +(* TODO: move to stdpp? *) +Lemma elem_of_list_to_set_disj `{EqDecision A, Countable A} (x : A) l: + x ∈ l -> x ∈ (list_to_set_disj l : gmultiset _). +Proof. + induction l; first set_solver. + rewrite list_to_set_disj_cons. + intros [-> | Hin]%elem_of_cons; multiset_solver. +Qed. + +Lemma subseteq_of_buffers S Sn ip skt sh r m: + S !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + m ∈ r → + m ∈ buffers S. +Proof. + intros Hsip HSn Hm. + apply elem_of_multi_collect. + exists ip, Sn. split; first done. + apply elem_of_multi_collect. + eexists _,_. split=>//=. by apply elem_of_list_to_set_disj. +Qed. + +Lemma buffers_subseteq S ip Sn skt r sh m: + S !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + buffers S ⊆ buffers (<[ip:=<[sh:=(skt, m :: r)]> Sn]> S). +Proof. + intros HSn Hsh Hincl. + apply multi_collect_subseteq. + intros ip' Sn' HSn'. + destruct (decide (ip = ip')) as [->|Hneq]. + - eexists. rewrite lookup_insert. split; first done. + rewrite HSn' in HSn. injection HSn. intros ->. + apply multi_collect_subseteq. intros sh' [??] Hsh'. + destruct (decide (sh = sh')) as [<-|Hneq]. + + eexists. rewrite lookup_insert. split; first done. simpl. + rewrite Hsh in Hsh'. simplify_eq. multiset_solver. + + eexists. rewrite lookup_insert_ne //. + - eexists. rewrite lookup_insert_ne //. +Qed. + +Lemma set_diff_distr (X Y Z : message_soup) : + X ## Z → + Y ## Z → + (X ∪ Z) ∖ (Y ∪ Z) = X ∖ Y. +Proof. + intros Hxz Hyz. + set_solver. +Qed. + + +Lemma buffers_subseteq_new_ip S ip : + S !! ip = None → + buffers S ⊆ buffers (<[ip:=∅]> S). +Proof. + intros Hnone. + rewrite /buffers. + rewrite insert_union_singleton_l. + rewrite multi_collect_disjoint_union. + - multiset_solver. + - by apply map_disjoint_singleton_l_2. +Qed. + +(* TODO: deduplicate all the subseteq lemmas in this file. *) +Lemma buffers_subseteq_new_socket S Sn ip sh : + S !! ip = Some Sn → + Sn !! sh = None → + buffers S ⊆ buffers (<[ip:=<[sh:=(mkSocket None true, [])]> Sn]> S). +Proof. + intros HSn Hsh. + apply multi_collect_subseteq. + intros ip' Sn' HSn'. + destruct (decide (ip = ip')) as [->|Hneq]. + - eexists. rewrite lookup_insert. split; first done. + rewrite HSn' in HSn. injection HSn. intros ->. + apply multi_collect_subseteq. intros sh' [??] Hsh'. + destruct (decide (sh = sh')) as [<-|Hneq]. + + eexists. rewrite lookup_insert. split; first done. simpl. + rewrite Hsh in Hsh'. by simplify_eq. + + eexists. rewrite lookup_insert_ne //. + - eexists. rewrite lookup_insert_ne //. +Qed. + +Lemma buffers_subseteq_update_socket S Sn ip sh sa skt r: + S !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + buffers S ⊆ buffers (<[ip:=<[sh:=(skt<| saddress := sa |>, r)]> Sn]> S). +Proof. + intros HSn Hsh. + apply multi_collect_subseteq. + intros ip' Sn' HSn'. + destruct (decide (ip = ip')) as [->|Hneq]. + - eexists. rewrite lookup_insert. split; first done. + rewrite HSn' in HSn. injection HSn. intros ->. + apply multi_collect_subseteq. intros sh' [??] Hsh'. + destruct (decide (sh = sh')) as [<-|Hneq]. + + eexists. rewrite lookup_insert. split; first done. simpl. + rewrite Hsh in Hsh'. by simplify_eq. + + eexists. rewrite lookup_insert_ne //. + - eexists. rewrite lookup_insert_ne //. +Qed. + +Lemma buffers_subseteq_update_socket_sblock S Sn ip sh skt r b: + S !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + buffers S ⊆ buffers (<[ip:=<[sh:=(skt<| sblock := b |>, r)]> Sn]> S). +Proof. + intros HSn Hsh. + apply multi_collect_subseteq. + intros ip' Sn' HSn'. + destruct (decide (ip = ip')) as [->|Hneq]. + - eexists. rewrite lookup_insert. split; first done. + rewrite HSn' in HSn. injection HSn. intros ->. + apply multi_collect_subseteq. intros sh' [??] Hsh'. + destruct (decide (sh = sh')) as [<-|Hneq]. + + eexists. rewrite lookup_insert. split; first done. simpl. + rewrite Hsh in Hsh'. by simplify_eq. + + eexists. rewrite lookup_insert_ne //. + - eexists. rewrite lookup_insert_ne //. +Qed. + +Lemma message_history_evolution_update_sblock S Sn ip M mh sh skt r b: + S !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + mh = message_history_evolution + M M S (<[ip:=<[sh:=(skt<| sblock := b |>, r)]> Sn]> S) mh. +Proof. + intros ??. rewrite /message_history_evolution. + destruct mh as (R,T). + rewrite difference_diag_L !left_id_L. f_equal. + rewrite gmultiset_empty_difference; first set_solver. + rewrite /buffers. simplify_eq /=. + by eapply buffers_subseteq_update_socket_sblock. +Qed. + +Lemma message_history_evolution_new_socket S Sn ip M mh sh : + S !! ip = Some Sn → + Sn !! sh = None → + mh = message_history_evolution + M M S (<[ip:=<[sh:=(mkSocket None true, [])]> Sn]> S) mh. +Proof. + intros ??. rewrite /message_history_evolution. + destruct mh as (R,T). + rewrite !difference_diag_L !left_id_L. f_equal. + rewrite gmultiset_empty_difference; first set_solver. + rewrite /buffers. simplify_eq /=. + by eapply buffers_subseteq_new_socket. +Qed. + +Lemma message_history_evolution_socketbind S Sn ip M mh sh skt r sa: + S !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + mh = message_history_evolution + M M S (<[ip:=<[sh:=(skt<| saddress := sa |>, r)]> Sn]> S) mh. +Proof. + intros ??. rewrite /message_history_evolution. + destruct mh as (R,T). + rewrite !difference_diag_L !left_id_L. f_equal. + rewrite gmultiset_empty_difference; first set_solver. + rewrite /buffers. simplify_eq /=. + by eapply buffers_subseteq_update_socket. +Qed. + +Lemma message_history_evolution_deliver_message ip Sn sh skt r m S M rt : + S !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + rt = message_history_evolution + M (M ∖ {[+ m +]}) S (<[ip:=<[sh:=(skt, m::r)]> Sn]> S) rt. +Proof. + intros ??. + rewrite /message_history_evolution. + destruct rt as (R, T). + assert (gset_of_gmultiset (M ∖ {[+ m +]}) ∖ gset_of_gmultiset M = ∅) as ->. + { rewrite subseteq_empty_difference_L; [done|]. + intros x Hin%elem_of_gset_of_gmultiset. + apply elem_of_gset_of_gmultiset. + destruct (decide (x = m)) as [->|Hneq]. + - rewrite multiplicity_difference multiplicity_singleton in Hin. lia. + - rewrite multiplicity_difference multiplicity_singleton_ne in Hin; [|done]. + lia. } + f_equal; [|by set_solver]. + rewrite gmultiset_empty_difference; first set_solver. + by eapply buffers_subseteq. +Qed. + +Lemma message_history_evolution_duplicate_message S M M' rt : + M' ⊆ M → rt = message_history_evolution M (M ⊎ M') S S rt. +Proof. + intros ?. + rewrite /message_history_evolution. + destruct rt as (R, T). + rewrite !gmultiset_difference_diag. + assert (dom (D := message_soup) (∅ : gmultiset _) = ∅) as Hempty by multiset_solver. + rewrite Hempty. f_equal; [multiset_solver|]. + rewrite gset_of_gmultiset_disj_union_subseteq; [|done]. + rewrite difference_diag_L. set_solver. +Qed. + +Lemma message_history_evolution_drop_message S M M' rt : + M' ⊆ M → + rt = message_history_evolution M M' S S rt. +Proof. + intros ?. + rewrite /message_history_evolution. + destruct rt as (R, T). + rewrite !gmultiset_difference_diag. + assert (dom (D := message_soup) (∅ : gmultiset _) = ∅) as Hempty by multiset_solver. + rewrite Hempty. f_equal; first multiset_solver. + rewrite subseteq_empty_difference_L; [|by apply gset_of_gmultiset_subseteq_mono]. + set_solver. +Qed. + +(* TODO: add to stdpp *) +Section more_lemmas. + Context `{Countable A}. + Implicit Types x y : A. + Implicit Types X Y Z : gmultiset A. + + Lemma gmultiset_difference_disj_union X Y Z : + X ∖ Y = (X ⊎ Z) ∖ (Y ⊎ Z). + Proof. + multiset_solver. + Qed. +End more_lemmas. + +Lemma message_history_evolution_receive ip S Sn M sh skt r R mh m: + (∀ ip Sn, + S !! ip = Some Sn → + socket_handlers_coh Sn ∧ + socket_addresses_coh Sn ip ∧ + socket_messages_coh Sn ∧ + socket_unbound_empty_buf_coh Sn ip) → + R ⊆ mh.1 → + S !! ip = Some Sn → + Sn !! sh = Some (skt, r ++ [m]) → + ({[ m ]} ∪ R ∪ mh.1, mh.2) = + message_history_evolution + M M S (<[ip :=<[sh:=(skt, r)]> Sn]> S) mh. +Proof. + intros Hcoh HR HS HSn. + rewrite /message_history_evolution. + rewrite !difference_diag_L !left_id_L. f_equal. + assert ({[m]} ∪ mh.1 = {[m]} ∪ R ∪ mh.1) as Heq by set_solver. + rewrite -Heq. f_equal. + rewrite /buffers /multi_collect. + rewrite -insert_delete_insert. + rewrite map_fold_insert; last first. + { apply lookup_delete. } + { intros. multiset_solver. } + rewrite -(insert_delete S ip Sn) //. + rewrite map_fold_insert; last first. + { apply lookup_delete. } + { intros. multiset_solver. } + rewrite delete_insert; last apply lookup_delete. + rewrite -gmultiset_difference_disj_union. + rewrite -insert_delete_insert. + rewrite map_fold_insert; last first. + { apply lookup_delete. } + { intros. multiset_solver. } + rewrite -(insert_delete Sn sh (skt, r ++ [m])) //. + rewrite map_fold_insert; last first. + { apply lookup_delete. } + { intros. multiset_solver. } + rewrite delete_insert; last apply lookup_delete. + rewrite -gmultiset_difference_disj_union /=. + rewrite list_to_set_disj_app /=. + + match goal with + [|- _ = dom ?x ] => assert (x = {[+ m +]}) as H; last by rewrite H; multiset_solver + end. + multiset_solver. +Qed. + +Lemma message_history_evolution_send_message S M msg mh : + gset_of_gmultiset M ⊆ mh.2 → + (mh.1, {[msg]} ∪ mh.2) = message_history_evolution M ({[+ msg +]} ⊎ M) S S mh. +Proof. + intro Hms. rewrite /message_history_evolution. + destruct mh as (R,T). + rewrite !gmultiset_difference_diag. + assert (dom (D := message_soup) (∅ : gmultiset _) = ∅) as Hempty by multiset_solver. + rewrite Hempty. f_equal; first multiset_solver. + destruct (decide (msg ∈ T)) as [Hin|Hnin]=> /=. + - assert ({[msg]} ∪ T = T) as -> by set_solver. + rewrite gset_of_gmultiset_disj_union + difference_union_distr_l_L + difference_diag_L. + set_solver. + - rewrite gset_of_gmultiset_disj_union + difference_union_distr_l_L. + set_solver. +Qed. + +Lemma message_history_evolution_send_duplicate_message S M msg mh : + msg ∈ mh.2 → + (mh.1, mh.2) = message_history_evolution M ({[+ msg +]} ⊎ M) S S mh. +Proof. + intro Hms. rewrite /message_history_evolution. + destruct mh as (R,T). + rewrite !gmultiset_difference_diag. + assert (dom (D := message_soup) (∅ : gmultiset _) = ∅) as Hempty by multiset_solver. + rewrite Hempty. f_equal; first multiset_solver. + f_equal. + rewrite gset_of_gmultiset_disj_union + difference_union_distr_l_L + difference_diag_L. + set_solver. +Qed. + +Lemma message_history_evolution_new_ip S ip M mh : + S !! ip = None → + mh = message_history_evolution M M S (<[ip := ∅]>S) mh. +Proof. + intros ?. rewrite /message_history_evolution. + destruct mh as (r,t). + rewrite difference_diag_L !left_id_L. f_equal. + rewrite gmultiset_empty_difference; first set_solver. + rewrite /buffers. simplify_eq /=. by eapply buffers_subseteq_new_ip. +Qed. + +Lemma message_history_evolution_id σ mh : + mh = message_history_evolution + (state_ms σ) (state_ms σ) (state_sockets σ) + (state_sockets σ) mh. +Proof. + rewrite /message_history_evolution !gmultiset_difference_diag. + destruct mh. f_equal; set_solver. +Qed. + +Lemma trace_messages_history_includes_last ex msg : + msg ∈ state_ms (trace_last ex).2 → msg ∈ (trace_messages_history ex).2. +Proof. + revert msg; induction ex as [c|ex IHex c]; intros msg. + { rewrite elem_of_gset_of_gmultiset elem_of_multiplicity; done. } + simpl; intros Hmsg. + destruct (decide (msg ∈ state_ms (trace_last ex).2)) as [Hin|Hnin]. + - apply elem_of_union; right; auto. + - apply elem_of_union; left. + apply elem_of_difference. rewrite !elem_of_gset_of_gmultiset. set_solver. +Qed. diff --git a/fairneris/aneris_lang/state_interp/state_interp_messages_history_coh.v b/fairneris/aneris_lang/state_interp/state_interp_messages_history_coh.v new file mode 100644 index 0000000..e118e45 --- /dev/null +++ b/fairneris/aneris_lang/state_interp/state_interp_messages_history_coh.v @@ -0,0 +1,302 @@ +From stdpp Require Import fin_maps gmap. +From iris.bi.lib Require Import fractional. +From iris.proofmode Require Import tactics. +From iris.base_logic.lib Require Import saved_prop gen_heap. +From fairneris Require Import fuel env_model. +From fairneris.prelude Require Import collect gmultiset. +From fairneris.lib Require Import gen_heap_light. +From fairneris.aneris_lang Require Import + aneris_lang network resources. +From fairneris.aneris_lang.state_interp Require Import + state_interp_def. +From fairneris.algebra Require Import disj_gsets. + +From RecordUpdate Require Import RecordSet. +Set Default Proof Using "Type". + +Import uPred. +Import RecordSetNotations. + +Section state_interpretation. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + (* receive_buffers_coh *) + Lemma receive_buffers_coh_alloc_socket σ mh s sh ip Sn : + state_sockets σ !! ip = Some Sn → + Sn !! sh = None → + receive_buffers_coh (state_sockets σ) mh → + receive_buffers_coh (<[ip:=<[sh:=(s, [])]> Sn]> (state_sockets σ)) mh. + Proof. + rewrite /receive_buffers_coh. + intros HSn HNone Hrbcoh ip' Sn' sh' skt' r' m' HSn' Hskt' Hm'. + ddeq ip ip'. + - ddeq sh sh'; [ set_solver | by eapply Hrbcoh ]. + - by eapply Hrbcoh. + Qed. + + Lemma receive_buffers_coh_update_sblock σ mh sh skt r ip Sn b : + state_sockets σ !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + receive_buffers_coh (state_sockets σ) mh → + receive_buffers_coh + (<[ip:=<[sh:=({| saddress := saddress skt; + sblock := b |}, r)]> Sn]> (state_sockets σ)) mh. + Proof. + rewrite /receive_buffers_coh. + intros HSn HNone Hrbcoh ip' Sn' sh' skt' r' m' HSn' Hskt' Hm'. + ddeq ip ip'. + - ddeq sh sh'; [ eauto | by eapply Hrbcoh ]. + - by eapply Hrbcoh. + Qed. + + Local Ltac mhc_unfold_all := + rewrite /messages_history_coh /message_soup_coh + /receive_buffers_coh /messages_addresses_coh + /messages_received_from_sent_coh. + + (** messages_history_coh *) + Lemma messages_history_coh_init ip B : + all_disjoint B → + set_Forall (λ x, x ≠ ∅) B → + messages_history_coh ∅ {[ip := ∅]} (gset_to_gmap (∅, ∅) B). + Proof. + mhc_unfold_all. split; first set_solver. + split; first by intros; simplify_map_eq. + split. + { rewrite dom_gset_to_gmap. split; [done|]. split; [done|]. + intros ???. rewrite lookup_gset_to_gmap_Some. + intros [? [= <- <-]]. set_solver. } + rewrite messages_received_init messages_sent_init //. + Qed. + + Lemma messages_history_coh_alloc_node M S mh ip : + messages_history_coh M S mh → + messages_history_coh M (<[ip:=∅]> S) mh. + Proof. + mhc_unfold_all. intros (?&?&?&?). split; first set_solver. + split; last set_solver. intros ip0 ???????. ddeq ip ip0; set_solver. + Qed. + + Lemma messages_history_coh_socketbind M S Sn mh sh skt a: + let ip := ip_of_address a in + S !! ip = Some Sn → + Sn !! sh = Some (skt, []) → + saddress skt = None → + messages_history_coh M S mh → + messages_history_coh + M (<[ip:=(<[sh:=((skt <| saddress := Some a |>), [])]>Sn)]> S) mh. + Proof. + rewrite /messages_history_coh. + intros HSn Hsh Hskt (Hmcoh & Hrcoh & Hacoh). + split; eauto. split; last eauto. + intros ip1 Sn1 sh1 skt1 r1 m1 HSn1 Hskt1 Hm1. + destruct a as (ip & p). ddeq ip ip1; ddeq sh sh1; eauto. + Qed. + + Lemma messages_history_coh_send mh M S Sn ip sh skt sa sag r m R T : + S !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + saddress skt = Some sa → + m_sender m = sa → + sa ∈ sag → + mh !! sag = Some (R, T) → + messages_history_coh M S mh → + messages_history_coh ({[+ m +]} ⊎ M) S (<[sag:=(R, {[m]} ∪ T)]> mh). + Proof. + mhc_unfold_all. + intros HSn Hsh Hskt <- Hsag Hmh (Hmcoh & Hrcoh & (Hdisj & Hne & Hacoh) & Hsrcoh). + split_and!. + - intros m' [->%gmultiset_elem_of_singleton|]%gmultiset_elem_of_disj_union. + + eexists R,({[m]} ∪ T),_. split; [done|]. rewrite lookup_insert. + set_solver. + + destruct (Hmcoh m' H) as (R' & T' & sag' & Hsag' & Heq & Hin'). + destruct (decide (sag' = sag)) as [->|Hnin]. + * eexists _, _, _. split; [done|]. + rewrite lookup_insert. split; [done|]. set_solver. + * eexists _, _, _. split; [done|]. + rewrite lookup_insert_ne; last done. eauto with set_solver. + - intros ip1 Sn1 sh1 skt1 r1 m1 HSn1 Hskt1 Hm1. + destruct (Hrcoh ip1 Sn1 sh1 skt1 r1 m1 HSn1 Hskt1 Hm1) as + (R' & T' & sag' & Hsag' & Heq & Hin'). + destruct (decide (sag' = sag)) as [->|Hnin]. + + eexists _, _, _. split; [done|]. + rewrite lookup_insert. + split; [done|]. set_solver. + + eexists _, _, _. split; [done|]. + rewrite lookup_insert_ne; last done. eauto with set_solver. + - rewrite dom_insert_lookup_L; [ by apply Hdisj | by eexists _ ]. + - rewrite dom_insert_lookup_L; [ by apply Hne | by eexists _ ]. + - intros sag' ???. + ddeq sag sag'; set_solver. + - apply elem_of_subseteq. + intros m'. + rewrite !elem_of_collect. + intros (sag' & (R',T') & Hlk & Hm). + destruct (decide (sag = sag')) as [->|]. + + rewrite lookup_insert in Hlk. + simplify_map_eq. + assert (m' ∈ messages_received mh). + { apply elem_of_messages_received. set_solver. } + assert (m' ∈ messages_sent mh) as Hms by by set_solver. + apply elem_of_messages_sent in Hms as (sag & rt & Hrt & Hmrt). + ddeq sag sag'. + * exists sag', (R', {[m]} ∪ T). + rewrite lookup_insert. set_solver. + * eexists sag, rt. rewrite lookup_insert_ne; last done. set_solver. + + rewrite lookup_insert_ne in Hlk; last done. + simplify_map_eq. + assert (m' ∈ messages_received mh). + { apply elem_of_messages_received. set_solver. } + assert (m' ∈ messages_sent mh) as Hms by by set_solver. + apply elem_of_messages_sent in Hms as (sag'' & rt & Hrt & Hmrt). + destruct (decide (sag'' = sag)) as [->|]. + * exists sag, (R, {[m]} ∪ T). + rewrite lookup_insert. split; first done. + destruct rt. simpl in *. simplify_map_eq /=. set_solver. + * exists sag'', rt. rewrite lookup_insert_ne; last done. + set_solver. + Qed. + + Lemma messages_history_coh_receive mh M S Sn ip sh skt sa sag r m R T : + S !! ip = Some Sn → + Sn !! sh = Some (skt, r ++ [m]) → + saddress skt = Some sa → + sa ∈ sag → + mh !! sag = Some (R, T) → + messages_history_coh M S mh → + messages_history_coh M (<[ip_of_address sa:=<[sh:=(skt, r)]> Sn]> S) mh. + Proof. + mhc_unfold_all. + intros HSn Hsh Hskt Hsag Hmh + (Hmcoh & Hrcoh & (Hdisj & Hne & Hacoh) & Hsrcoh). + split_and!; try done. + intros ip1 Sn1 sh1 skt1 r1 m1 HSn1 Hskt1 Hm1. + ddeq ip1 (ip_of_address sa); last eauto. + ddeq sh1 sh; last eauto. + ddeq m m1; [ eapply Hrcoh =>//; set_solver | by eapply Hrcoh; eauto; set_solver ]. + Qed. + + Lemma messages_history_coh_receive_2 mh M S Sn ip sh skt sa sag r m R T : + S !! ip = Some Sn → + Sn !! sh = Some (skt, r ++ [m]) → + saddress skt = Some sa → + m_destination m = sa → + sa ∈ sag → + mh !! sag = Some (R, T) → + messages_history_coh M S mh → + messages_history_coh M (<[ip_of_address sa:=<[sh:=(skt, r)]> Sn]> S) + (<[sag:=({[m]} ∪ R, T)]>mh). + Proof. + mhc_unfold_all. + intros HSn Hsh Hskt Hdest Hsag Hmh (Hmcoh & Hrcoh & (Hdisj & Hne & Hacoh) & Hsrcoh). + split_and!. + - intros m' Hm'. clear Hdest. + destruct (Hmcoh m' Hm') as (R' & T' & sag' & Hsag' & Heq & Hin). + ddeq sag sag'. + + eexists _, _, _. split; [done|]. rewrite lookup_insert. + eauto with set_solver. + + eexists _, _, _. split; [done|]. rewrite lookup_insert_ne; [|done]. + eauto with set_solver. + - intros ip1 Sn1 sh1 skt1 r1 m1 HSn1 Hskt1 Hm1. + clear Hdest. + ddeq ip1 (ip_of_address sa). + + ddeq sh sh1. + * destruct (Hrcoh ip Sn sh1 skt1 (r1++[m]) m1 HSn Hsh) as + (R' & T' & sag' & Hsag' & Heq & Hin). + { set_solver. } + destruct (decide (sag' = sag)) as [->|Hne']. + -- eexists _, _, _. split; [done|]. rewrite lookup_insert. + split; [done|]. set_solver. + -- eexists _, _, _. split; [done|]. rewrite lookup_insert_ne; [|done]. + split; [done|]. set_solver. + * destruct (Hrcoh ip Sn sh1 skt1 r1 m1 HSn Hskt1 Hm1) as + (R' & T' & sag' & Hsag' & Heq & Hin). + destruct (decide (sag' = sag)) as [->|Hne']. + -- eexists _, _, _. split; [done|]. + rewrite lookup_insert. split; [done|]. set_solver. + -- eexists _, _, _. split; [done|]. + rewrite lookup_insert_ne; [|done]. split; [done|]. set_solver. + + destruct (Hrcoh ip1 Sn1 sh1 skt1 r1 m1 HSn1 Hskt1 Hm1) as + (R' & T' & sag' & Hsag' & Heq & Hin). + destruct (decide (sag' = sag)) as [->|Hne']. + -- eexists _, _, _. split; [done|]. rewrite lookup_insert. + split; [done|]. set_solver. + -- eexists _, _, _. split; [done|]. rewrite lookup_insert_ne; [|done]. + split; [done|]. set_solver. + - rewrite dom_insert_lookup_L; [ by apply Hdisj | by eexists _ ]. + - rewrite dom_insert_lookup_L; [ by apply Hne | by eexists _ ]. + - intros sag' ???. ddeq sag sag'; eauto. + split_and!. + * intros m0 [->%elem_of_singleton|]%elem_of_union; first done. + by eapply Hacoh. + * by eapply Hacoh. + - assert (messages_sent (<[sag:=({[m]} ∪ R, T)]> mh) = messages_sent mh) as ->. + { apply insert_id in Hmh. symmetry in Hmh. rewrite {2} Hmh. + by rewrite !messages_sent_insert. } + assert (messages_received (<[sag:=({[m]} ∪ R, T)]> mh) = + {[m]} ∪ R ∪ messages_received (delete sag mh)) as ->. + { rewrite /messages_received. by rewrite collect_insert. } + apply insert_id in Hmh. symmetry in Hmh. rewrite {1} Hmh in Hsrcoh. + assert (messages_received (<[sag:=(R, T)]> mh) = + R ∪ messages_received (delete sag mh)) as Heq. + { rewrite /messages_received. by rewrite collect_insert. } + rewrite Heq in Hsrcoh. + assert (m ∈ messages_sent mh) as Hm. + { apply elem_of_collect. + specialize (Hrcoh ip Sn sh skt (r ++ [m]) m HSn Hsh ltac:(set_solver)) as (R'&T'&HRT'). + naive_solver. } + set_solver. + Qed. + + Lemma messages_history_coh_deliver_message mh M S Sn Sn' ip sh skt a R m : + m ∈ messages_to_receive_at_multi_soup a M → + S !! ip = Some Sn → + Sn !! sh = Some (skt, R) → + Sn' = <[sh:=(skt, m :: R)]> Sn → + saddress skt = Some a → + messages_history_coh M S mh → + messages_history_coh M (<[ip:=Sn']> S) mh. + Proof. + rewrite /messages_history_coh. + intros Hm HSn Hsh HSn' Hskt (Hmcoh & Hrcoh & Hacoh). + split; eauto. split; last eauto. + intros ip1 Sn1 sh1 skt1 r1 m1 HSn1 Hskt1 Hm1. + destruct (decide (ip = ip1)) as [->|]. + - rewrite lookup_insert in HSn1. + simplify_eq. destruct (decide (sh = sh1)) as [->|]. + + rewrite lookup_insert in Hskt1; simplify_eq. + apply elem_of_cons in Hm1 as [->| Hm1]. + * apply Hmcoh. + rewrite /messages_to_receive_at_multi_soup in Hm. + revert Hm; rewrite elem_of_filter; intros [? ?%gmultiset_elem_of_dom] =>//. + * subst. eapply Hrcoh; eauto. + + rewrite lookup_insert_ne in Hskt1; eauto. + - by rewrite lookup_insert_ne in HSn1; eauto. + Qed. + + Lemma message_soup_coh_subseteq M N mhm : + (∀ m, m ∈ M → m ∈ N) → message_soup_coh N mhm → message_soup_coh M mhm. + Proof. intros Hle Hcoh m Hin. by apply Hcoh, Hle. Qed. + + Lemma messages_history_coh_duplicate_message M S mhm m : + m ∈ M → + messages_history_coh M S mhm → messages_history_coh (M ⊎ {[+ m +]}) S mhm. + Proof. + intros Hin (HMcoh&Hrbuf&Hacoh&Hrsfcoh). + split; [|done]. eapply message_soup_coh_subseteq; [|done]. set_solver. + Qed. + + Lemma messages_history_coh_drop_message M S mhγ m : + messages_history_coh M S mhγ → + messages_history_coh (M ∖ {[+ m +]}) S mhγ. + Proof. + unfold messages_history_coh. intros (Hmsh & Hrb & Hmac & Hmr). + split_and!; [|done..]. + intros m' Hm'; eapply Hmsh. + eapply gmultiset_elem_of_subseteq; first done. + apply gmultiset_difference_subseteq. + Qed. + +End state_interpretation. diff --git a/fairneris/aneris_lang/state_interp/state_interp_messages_resource_coh.v b/fairneris/aneris_lang/state_interp/state_interp_messages_resource_coh.v new file mode 100644 index 0000000..69a7da1 --- /dev/null +++ b/fairneris/aneris_lang/state_interp/state_interp_messages_resource_coh.v @@ -0,0 +1,652 @@ +From stdpp Require Import fin_maps gmap. +From iris.proofmode Require Import tactics. +From fairneris Require Import fuel env_model. +From fairneris.prelude Require Import collect. +From fairneris.aneris_lang Require Import aneris_lang network resources. +From fairneris.aneris_lang.state_interp Require Import state_interp_def. +From RecordUpdate Require Import RecordSet. +From fairneris.algebra Require Import disj_gsets. +From iris.algebra Require Import auth. +Set Default Proof Using "Type". + +Import uPred. +Import RecordSetNotations. + +Section state_interpretation. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{LMeq: !LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + Lemma messages_resource_coh_init B : + own (A:=authUR socket_address_groupUR) aneris_socket_address_group_name + (◯ (DGSets B)) -∗ + messages_resource_coh (gset_to_gmap (∅, ∅) B). + Proof. + rewrite /messages_resource_coh messages_sent_init. + iIntros "Hown". + iSplitL; [ |]. + { by rewrite dom_gset_to_gmap. } + iExists _. + iSplit; [done|]. + iSplit; by iApply big_sepS_empty. + Qed. + + (* TODO: Repeated lemma - Why is anerisG needed over anerisPreG? *) + Lemma socket_address_group_own_subseteq + γ (sags sags' : gset socket_address_group) : + sags' ⊆ sags → + own (A:=(authR socket_address_groupUR)) γ + (◯ (DGSets sags)) -∗ + own (A:=(authR socket_address_groupUR)) γ + (◯ (DGSets sags')). + Proof. + iIntros (Hle) "Hsags". + apply subseteq_disjoint_union_L in Hle. + destruct Hle as [Z [-> Hdisj]]. + setoid_rewrite <-disj_gsets_op_union. + iDestruct "Hsags" as "[H1 H2]". + iFrame. + Qed. + + Lemma messages_resource_coh_socket_address_group_own + (sag : socket_address_group) mh : + sag ∈ dom mh → + messages_resource_coh mh -∗ + messages_resource_coh mh ∗ + socket_address_group_own sag. + Proof. + iIntros (Hin) "[#H Hrest]". + rewrite /socket_address_group_own. + iPoseProof (socket_address_group_own_subseteq _ _ {[sag]} with "H") as "$"; + [set_solver|]. + rewrite /messages_resource_coh. iFrame "H". + done. + Qed. + + Lemma messages_resource_coh_send mh sagT sagR R T msg msg' ϕ : + mh !! sagT = Some (R, T) → + m_sender msg ∈ sagT → + messages_addresses_coh mh → + msg ≡g{sagT, sagR} msg' → + m_destination msg ∈g sagR -∗ + sagR ⤇* ϕ -∗ + messages_resource_coh mh -∗ + ϕ msg' -∗ + messages_resource_coh (<[sagT:=(R, {[msg]} ∪ T)]> mh). + Proof. + rewrite /messages_resource_coh /=. + iIntros (Hmh HsagT Hmcoh Hmeq) "[%HsagR _] #HΦ [#Hown Hcoh] Hm". + iAssert (socket_address_group_own sagT) as "HownT". + { + rewrite -(insert_id mh sagT (R,T)); [|set_solver]. + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iDestruct "Hown" as "[$ Hown]". + } + destruct Hmcoh as (Halldisj & Hne & Hmcoh). + iDestruct "Hcoh" as (ms Hle) "[#HcohT Hcoh]". + iDestruct (socket_interp_own with "HΦ") as "#Hown'". + iSplitR. + { + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iApply own_op. + iFrame "Hown HownT". + } + iExists ({[msg]} ∪ ms). + iSplitR. + { + iPureIntro. + rewrite messages_sent_insert. + rewrite -union_assoc_L. + rewrite -(messages_sent_split sagT R T mh Hmh). + set_solver. + } + iSplitR. + { + rewrite messages_sent_insert. + rewrite -union_assoc_L. + rewrite -(messages_sent_split sagT R T mh Hmh). + rewrite !big_sepS_forall. + iIntros (m' Hin). + setoid_rewrite elem_of_union in Hin. + destruct Hin as [Hin|Hin]. + { + assert (m' = msg) as <- by set_solver. + iExists sagT, sagR, m'. + iSplit; [iSplit; [|iPureIntro; set_solver] |]. + { iPureIntro. apply message_group_equiv_refl. + - by destruct Hmeq as (Hmin & _). + - done. } + iFrame "HownT Hown'". + } + iDestruct ("HcohT" $!(m') (Hin)) + as (sagT' sagR' m'' [Hmeq' Hmin]) "[HcohT' HcohT'']". + iExists sagT', sagR', m''. + apply (elem_of_union_r m'' {[msg]} ms) in Hmin. + iFrame "#". + iSplit; [done|]. iPureIntro. done. + } + destruct (decide (msg ∈ ms)). + { + assert ({[msg]} ∪ ms = ms) as -> by set_solver. iClear "Hm". + assert (ms ⊆ {[msg]} ∪ messages_sent mh) by set_solver. + rewrite /message_received. + rewrite !messages_received_insert. + iApply (big_sepS_mono with "Hcoh"). + iIntros (x Hin') "Hcoh". + iDestruct "Hcoh" as (sagT' sagR' Φ Hin'') "[#HΦ' [HownT' Hcoh]]". + subst. + iExists _, _, _. + iFrame "HΦ'". + iSplit. + { iPureIntro. set_solver. } + iFrame "HownT'". + iDestruct "Hcoh" as "[Hcoh | Hcoh]". + { by iLeft. } + iRight. + iDestruct "Hcoh" as %(m' & Heq & Hrecv). + iExists m'. iSplit; [done|]. + iPureIntro. + rewrite -(insert_id mh sagT (R,T) Hmh) in Hrecv. + apply message_received_insert in Hrecv. + set_solver. + } + rewrite big_sepS_union; [|set_solver]. + rewrite big_sepS_singleton. + iSplitL "Hm". + + iExists _,_, _. iFrame "HΦ". + iFrame "HownT". + iSplit. + { iPureIntro. set_solver. } + iLeft. iExists _. + iSplitR "Hm"; [done | iApply "Hm"]. + + iApply (big_sepS_mono with "Hcoh"). + iIntros (x Hin') "Hcoh". + iDestruct "Hcoh" as (sagT' sagR' Φ Hin'') "[#HΦ' [HownT Hcoh]]". + subst. + iExists _,_, _. + iFrame "HΦ'". iFrame "HownT". + iSplit. + { iPureIntro. set_solver. } + iDestruct "Hcoh" as "[Hcoh | Hcoh]". + { by iLeft. } + iRight. + iDestruct "Hcoh" as %(m' & Heq & Hrecv). + iExists m'. iSplit; [done|]. + iPureIntro. + rewrite -(insert_id mh sagT (R,T) Hmh) in Hrecv. + rewrite message_received_insert. + by apply message_received_insert in Hrecv. + Qed. + + Lemma messages_resource_coh_send_duplicate mh sagT sagR R T msg : + mh !! sagT = Some (R, T) → + m_sender msg ∈ sagT → + messages_addresses_coh mh → + set_Exists (λ m, m ≡g{sagT, sagR} msg) T → + m_destination msg ∈g sagR -∗ + messages_resource_coh mh -∗ + messages_resource_coh (<[sagT:=(R, {[msg]} ∪ T)]> mh). + Proof. + rewrite /messages_resource_coh /=. + iIntros (Hmh HsagT Hmcoh Hexists) "[%HsagR #Hown'] [#Hown Hcoh]". + iAssert (socket_address_group_own sagT) as "HownT". + { + rewrite -(insert_id mh sagT (R,T)); [|set_solver]. + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iDestruct "Hown" as "[$ Hown]". + } + destruct Hmcoh as (Halldisj & Hne & Hmcoh). + iDestruct "Hcoh" as (ms Hle) "[#HcohT Hcoh]". + iSplitR. + { + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iApply own_op. + iFrame "Hown HownT". + } + iExists ms. + rewrite -{3}(insert_id mh sagT (R, T)); [|set_solver]. + rewrite /message_received. + rewrite !messages_received_insert. + iFrame. + iSplitR. + { + iPureIntro. + rewrite messages_sent_insert. + rewrite -union_assoc_L. + rewrite -(messages_sent_split sagT R T mh Hmh); set_solver. + } + rewrite messages_sent_insert. + rewrite -union_assoc_L. + rewrite -(messages_sent_split sagT R T mh Hmh). + destruct (decide (msg ∈ messages_sent mh)) as [Hin|Hnin]. + { assert ({[msg]} ∪ messages_sent mh = messages_sent mh) as Heq by set_solver. + rewrite Heq. done. } + rewrite big_sepS_union; [|set_solver]. + iFrame "HcohT". + rewrite big_sepS_singleton. + destruct Hexists as [m' [Hin Hmeq]]. + assert (m_destination m' ∈ sagR). + { by destruct Hmeq as (_ & _ & H' & _). } + rewrite -{2}(insert_id mh sagT (R,T)); [|set_solver]. + rewrite messages_sent_insert. + iDestruct (big_sepS_elem_of_acc _ _ m' with "HcohT") as "[Hmsg _]"; + [set_solver|]. + iDestruct "Hmsg" as (sagT' sagR' m'' [Hmeq' Hmin]) "[HownT' HownR']". + iExists sagT', sagR', m''. iFrame "HownT' HownR'". iSplit;[|done]. + iAssert (socket_address_groups_own + ({[sagT]} ∪ {[sagR]} ∪ {[sagT']} ∪ {[sagR']})) as "H". + { + iApply socket_address_groups_own_union. iFrame "HownR'". + iApply socket_address_groups_own_union. iFrame "HownT'". + iApply socket_address_groups_own_union. iFrame "Hown' HownT". + } + iDestruct (own_valid with "H") as %Hvalid. + setoid_rewrite auth_frag_valid in Hvalid. + setoid_rewrite disj_gsets_valid in Hvalid. + iPureIntro. + pose proof (message_group_equiv_trans _ sagT sagT' sagR sagR' msg m' m'' Hvalid) as (<- & <- & Hmeq''); + [set_solver..| | | ]. + - apply message_group_equiv_symmetry; try done. + by destruct Hmeq as (H' & _). + - apply Hmeq'. + - done. + Qed. + + Lemma message_received_delete m mh sag1 sag2 : + messages_addresses_coh mh → + m_destination m ∈ sag1 → + sag1 ∈ dom mh → + sag2 ∈ dom mh → + sag1 ≠ sag2 → + message_received m mh → + message_received m (delete sag2 mh). + Proof. + rewrite /message_received. + rewrite !elem_of_messages_received. + intros (Hdisj & Hne & Hcoh) Hdest Hsag1 Hsag2 Hrecv + [sag [[R T] [Hlookup Hin]]]. + assert (sag = sag1) as ->. + { + eapply elem_of_all_disjoint_eq; eauto. + apply elem_of_dom. eexists _. set_solver. + eapply Hcoh. eauto. eauto. + } + eexists sag1, (R,T). + rewrite lookup_delete_ne; last done. + auto. + Qed. + + (* TODO: Clean up these lemmas and proofs *) + Lemma messages_resource_coh_receive_in sagR sagT R T R' T' m mh : + mh !! sagR = Some (R, T) → + mh !! sagT = Some (R',T') → + set_Forall (λ m', ¬ (m ≡g{sagT,sagR} m')) R → + m ∈ T' → + messages_addresses_coh mh → + m_destination m ∈g sagR -∗ + m_sender m ∈g sagT -∗ + messages_resource_coh mh -∗ + messages_resource_coh (<[sagR:=({[m]} ∪ R, T)]> mh) ∗ + ∃ φ m', ⌜m ≡g{sagT,sagR} m'⌝ ∗ sagR ⤇* φ ∗ ▷ φ m'. + Proof. + iIntros (Hmha Hmhb HmR HmT' (Hdisj & Hne & Hmacoh)). + iIntros "[%Hmdest _] [%Hmsend _]". + iDestruct 1 as "[#Hown Hrcoh]". rewrite /messages_resource_coh. + iDestruct "Hrcoh" as (ms Hle) "[#HrcohT Hrcoh]". + iAssert (⌜∃ m', m ≡g{sagT,sagR} m' ∧ m' ∈ ms⌝%I) as %(m' & Hmeq & Hmin). + { + assert (messages_sent mh = messages_sent (<[sagT:=(R', T')]>mh)) as Heq. + { apply insert_id in Hmhb as Heq. by rewrite {1} Heq. } + rewrite Heq messages_sent_insert. + assert (T' = {[m]} ∪ T') as HTeq by set_solver. + rewrite HTeq. + iDestruct (big_sepS_elem_of_acc _ _ m with "HrcohT") + as "[Hm _]"; [set_solver|]. + iDestruct "Hm" as (sagT' sagR' m' [Hmeq Hmin]) "[HownT' HownR']". + assert (sagR ∈ dom mh). + { apply elem_of_dom. eexists _. set_solver. } + + iAssert (socket_address_group_own sagT) as "HownT". + { + rewrite -(insert_id mh sagT (R',T')); [|set_solver]. + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iDestruct "Hown" as "[$ Hown]". + } + iAssert (socket_address_group_own sagR) as "HownR". + { + rewrite -(insert_id mh sagR (R,T)); [|set_solver]. + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iDestruct "Hown" as "[$ Hown]". + } + iAssert (socket_address_groups_own + ({[sagT]} ∪ {[sagR]} ∪ {[sagT']} ∪ {[sagR']})) as "Hown'". + { + iApply socket_address_groups_own_union. iFrame "HownR'". + iApply socket_address_groups_own_union. iFrame "HownT'". + iApply socket_address_groups_own_union. iFrame "HownR HownT". + } + iDestruct (own_valid with "Hown'") as %Hvalid. + setoid_rewrite auth_frag_valid in Hvalid. + setoid_rewrite disj_gsets_valid in Hvalid. + assert (sagT = sagT') as <-. + { eapply (message_group_equiv_dest_eq _ + sagT sagT' sagR sagR' m m' Hvalid); try set_solver. } + assert (sagR = sagR') as <-. + { eapply (message_group_equiv_dest_eq _ + sagT sagT sagR sagR' m m' Hvalid); try set_solver. } + iPureIntro. + eexists m'. + done. + } + assert (ms = {[m']} ∪ (ms ∖ {[m']})) as Hms. + { rewrite -union_difference_L. eauto. set_solver. } + rewrite Hms. + rewrite big_sepS_union; [|set_solver]. rewrite big_sepS_singleton. + iDestruct "Hrcoh" as "[Hm' Hrcoh]". + iDestruct "Hm'" as (sagT' sagR' Φ Hdest) "[#HΦ [#HownT' Hm]]". + assert (sagR ∈ dom mh) as HsagR. + { rewrite elem_of_dom. eexists _. set_solver. } + iDestruct "Hm" as "[Hm | Hm]"; last first. + { + iDestruct "Hm" as %(m'' & Hmeq' & Hrecv). + iAssert (socket_address_group_own sagT) as "HownT". + { + rewrite -(insert_id mh sagT (R',T')); [|set_solver]. + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iDestruct "Hown" as "[$ Hown]". + } + iAssert (socket_address_group_own sagR) as "HownR". + { + rewrite -(insert_id mh sagR (R,T)); [|set_solver]. + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iDestruct "Hown" as "[$ Hown]". + } + iDestruct (socket_interp_own with "HΦ") as "HownR'". + iAssert (socket_address_groups_own + ({[sagT]} ∪ {[sagT']} ∪ {[sagR]} ∪ {[sagR']})) as "Hown'". + { + iApply socket_address_groups_own_union. iFrame "HownR'". + iApply socket_address_groups_own_union. iFrame "HownR". + iApply socket_address_groups_own_union. iFrame "HownT' HownT". + } + iDestruct (own_valid with "Hown'") as %Hvalid. + setoid_rewrite auth_frag_valid in Hvalid. + setoid_rewrite disj_gsets_valid in Hvalid. + assert (m ≡g{sagT, sagR} m'') as Hmeq''. + { eapply (message_group_equiv_trans _ sagT sagT' sagR sagR' m m' m''); eauto. + set_solver. set_solver. set_solver. set_solver. } + assert (m_destination m'' ∈ sagR). + { by eapply message_group_equiv_dest. } + assert (m'' ∈ R). + { eapply messages_received_in; eauto. + by rewrite /messages_addresses_coh. } + assert (¬ m ≡g{sagT,sagR} m''). + { by apply HmR. } + done. + } + iDestruct "Hm" as (m'' Hmeq') "Hm'". + iAssert (socket_address_group_own sagT) as "HownT". + { + rewrite -(insert_id mh sagT (R',T')); [|set_solver]. + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iDestruct "Hown" as "[$ Hown]". + } + iAssert (socket_address_group_own sagR) as "HownR". + { + rewrite -(insert_id mh sagR (R,T)); [|set_solver]. + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iDestruct "Hown" as "[$ Hown]". + } + iDestruct (socket_interp_own with "HΦ") as "HownR'". + iAssert (socket_address_groups_own + ({[sagT]} ∪ {[sagR]} ∪ {[sagT']} ∪ {[sagR']})) as "Hown'''". + { + iApply socket_address_groups_own_union. iFrame "HownR'". + iApply socket_address_groups_own_union. iFrame "HownT'". + iApply socket_address_groups_own_union. iFrame "HownT HownR". + } + iDestruct (own_valid with "Hown'''") as %Hvalid. + setoid_rewrite auth_frag_valid in Hvalid. + setoid_rewrite disj_gsets_valid in Hvalid. + assert (sagR' = sagR) as ->. + { + symmetry. + eapply (message_group_equiv_trans _ sagT sagT' sagR sagR' m m' m'' Hvalid); + set_solver. } + iSplitR "Hm'"; last first. + { + iExists Φ, m''. iFrame "HΦ Hm'". iPureIntro. + eapply message_group_equiv_trans; eauto. + set_solver. set_solver. set_solver. set_solver. + } + iSplitR. + { + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite !auth_frag_op. iSplit. + iApply "HownR". + iFrame "Hown". + } + iExists ms. + iSplitR. + { + iPureIntro. + rewrite -(insert_id mh sagR (R,T) Hmha) in Hle. + rewrite messages_sent_insert. + rewrite messages_sent_insert in Hle. + done. + } + iSplitR. + { + rewrite -{2}(insert_id mh sagR (R,T) Hmha). + rewrite !messages_sent_insert. + rewrite -Hms. + iApply "HrcohT". + } + rewrite {3} Hms. + rewrite big_sepS_union; last set_solver. + rewrite big_sepS_singleton. + iSplitR. + { iExists sagT, sagR, Φ. + iSplit; [iPureIntro; set_solver | ]. + iFrame "HΦ". + iFrame "HownT". + iRight. + iExists m. + iPureIntro. + split; [by apply message_group_equiv_symmetry | ]. + rewrite message_received_insert. + set_solver. + } + iApply (big_sepS_impl with "Hrcoh"). + iIntros "!>" (m''' Hmin') "Hrcoh". + iDestruct "Hrcoh" as (sagT'' sagR' Φ' Hmin'') "[#HΦ' [#HownT'' H]]". + iExists sagT'', sagR', Φ'. + iFrame "#". + iSplit; [done|]. + iDestruct "H" as "[H|H]"; [ by iFrame | iRight ]. + iDestruct "H" as %(m'''' & Hmeq''' & Hrecv). + assert (m_destination m'''' ∈ sagR'). + { eapply message_group_equiv_dest; eauto. } + pose proof Hrecv as Hrecv'. + rewrite /message_received in Hrecv'. + setoid_rewrite elem_of_messages_received in Hrecv'. + destruct Hrecv' as (sag & [R'' T''] & Hlookup & Hin). + simpl in *. + iAssert (socket_address_group_own sag) as "Hown''''". + { + rewrite -(insert_id mh sag (R'',T'')); [|set_solver]. + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iDestruct "Hown" as "[$ Hown]". + } + iDestruct (socket_interp_own with "HΦ'") as "Hown'''''". + iDestruct (own_op with "[Hown'''' Hown''''']") as "Hown''''''". + { iSplit; [ iApply "Hown''''" | iApply "Hown'''''" ]. } + rewrite -auth_frag_op. + iDestruct (own_valid with "Hown''''''") as %Hvalid'. + setoid_rewrite auth_frag_valid in Hvalid'. + setoid_rewrite disj_gsets_valid in Hvalid'. + iPureIntro. exists m''''. + split; [done|]. + rewrite message_received_insert. + destruct (decide (sagR' = sagR)) as [->|Hneq]; [left|right]. + { apply elem_of_union_r. by eapply messages_received_in. } + rewrite /message_received. + rewrite !elem_of_messages_received. + assert (sag = sagR') as ->. + { + eapply (elem_of_all_disjoint_eq sag sagR' (m_destination m'''')); eauto. + set_solver. set_solver. + eapply Hmacoh. eauto. eauto. + } + eexists _, _. + rewrite lookup_delete_ne; last done. + split; [done|done]. + Qed. + + Lemma messages_resource_coh_receive_nin sagR sagT R T R' T' m mh : + mh !! sagR = Some (R, T) → + mh !! sagT = Some (R',T') → + m ∈ T' → + messages_addresses_coh mh → + m_destination m ∈g sagR -∗ + m_sender m ∈g sagT -∗ + messages_resource_coh mh -∗ + messages_resource_coh (<[sagR:=({[m]} ∪ R, T)]> mh). + Proof. + iIntros (Hmha Hmhb HmT' (Hdisj & Hne & Hmacoh)). + iIntros "[%Hmdest _] [%Hmsend _] Hrcoh". + iDestruct "Hrcoh" as "[#Hown Hrcoh]". + iDestruct "Hrcoh" as (ms Hle) "[HrcohT Hrcoh]". + rewrite /messages_resource_coh. + rewrite dom_insert_L. + iAssert (socket_address_group_own sagR) as "HownR". + { + rewrite -(insert_id mh sagR (R,T)); [|set_solver]. + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iDestruct "Hown" as "[$ Hown]". + } + iSplitR. + { + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iSplit. iApply "HownR". iApply "Hown". + } + iExists ms. + iSplit. + { rewrite messages_sent_insert. + rewrite <- (insert_id _ sagR (R,T)) in Hle; auto. + rewrite messages_sent_insert in Hle. + iPureIntro. + set_solver. } + iSplitR "Hrcoh". + { + rewrite messages_sent_insert. + rewrite -(messages_sent_split sagR R T mh Hmha). + done. + } + iApply (big_sepS_impl with "Hrcoh"). + iIntros "!>" (m'' Hmin') "H". + iDestruct "H" as (sagT' sagR' Φ Hdest) "(#Hsag' & HsagT & [H | H])". + { + iDestruct "H" as (m''' Hmeq') "HΦ". + iExists sagT', sagR', Φ. + iSplit; [done|]. + iSplit; [done|]. + iSplit; [done|]. + iLeft. eauto. + } + iDestruct "H" as %(m''' & Hmeq' & Hrecv). + iExists sagT', sagR', Φ. + iSplit; [done|]. + iSplit; [done|]. + iSplit; [done|]. + iRight. + assert (m_destination m''' ∈ sagR'). + { eapply message_group_equiv_dest; eauto. } + pose proof Hrecv as Hrecv'. + rewrite /message_received in Hrecv'. + setoid_rewrite elem_of_messages_received in Hrecv'. + destruct Hrecv' as (sag & [R'' T''] & Hlookup & Hin). + simpl in *. + iAssert (socket_address_group_own sag) as "Hown'". + { + rewrite -(insert_id mh sag (R'',T'')); [|set_solver]. + rewrite dom_insert_L. + rewrite -disj_gsets_op_union. + rewrite auth_frag_op. + iDestruct "Hown" as "[$ Hown]". + } + iDestruct (socket_interp_own with "Hsag'") as "Hown''". + iDestruct (own_op with "[Hown' Hown'']") as "Hown'''". + { iSplit; [ iApply "Hown'" | iApply "Hown''" ]. } + rewrite -auth_frag_op. + iDestruct (own_valid with "Hown'''") as %Hvalid'. + setoid_rewrite auth_frag_valid in Hvalid'. + setoid_rewrite disj_gsets_valid in Hvalid'. + iPureIntro. exists m'''. + split; [done|]. + rewrite message_received_insert. + destruct (decide (sagR' = sagR)) as [->|Hneq]; [left|right]. + { apply elem_of_union_r. by eapply messages_received_in. } + assert (sag = sagR') as ->. + { + eapply (elem_of_all_disjoint_eq sag sagR' (m_destination m''')); eauto. + set_solver. set_solver. + eapply Hmacoh. eauto. eauto. + } + rewrite /message_received. + rewrite !elem_of_messages_received. + eexists _, _. + rewrite lookup_delete_ne; last done. + split; [done|done]. + Qed. + + Lemma messages_resource_coh_receive sagR sagT R T R' T' m mh : + mh !! sagR = Some (R, T) → + mh !! sagT = Some (R',T') → + m ∈ T' → + messages_addresses_coh mh → + m_destination m ∈g sagR -∗ + m_sender m ∈g sagT -∗ + messages_resource_coh mh -∗ + messages_resource_coh (<[sagR:=({[m]} ∪ R, T)]> mh) ∗ + (⌜set_Forall (λ m', ¬ (m ≡g{sagT,sagR} m')) R⌝ -∗ + ∃ φ m', ⌜m ≡g{sagT,sagR} m'⌝ ∗ sagR ⤇* φ ∗ ▷ φ m'). + Proof. + iIntros (Hmha Hmhb HmT' Hcoh). + iIntros "HsagR HsagT Hcoh". + destruct (decide (set_Forall (λ m', ¬ (m ≡g{sagT,sagR} m')) R)). + - iDestruct (messages_resource_coh_receive_in with "HsagR HsagT Hcoh") + as "[Hcoh Hφ]"; [ by eauto.. |]. + by iFrame. + - iDestruct (messages_resource_coh_receive_nin with "HsagR HsagT Hcoh") + as "[Hcoh Hφ]"; [ by eauto.. |]. + iFrame. by iIntros (H). + Qed. + +End state_interpretation. diff --git a/fairneris/aneris_lang/state_interp/state_interp_network_sockets_coh.v b/fairneris/aneris_lang/state_interp/state_interp_network_sockets_coh.v new file mode 100644 index 0000000..cefde6c --- /dev/null +++ b/fairneris/aneris_lang/state_interp/state_interp_network_sockets_coh.v @@ -0,0 +1,381 @@ +From stdpp Require Import fin_maps gmap. +From iris.bi.lib Require Import fractional. +From iris.proofmode Require Import tactics. +From iris.base_logic.lib Require Import saved_prop gen_heap. +From fairneris Require Import fuel env_model. +From fairneris.lib Require Import gen_heap_light. +From fairneris.aneris_lang Require Import + aneris_lang network resources. +From fairneris.aneris_lang.state_interp Require Import + state_interp_def. + +From RecordUpdate Require Import RecordSet. +Set Default Proof Using "Type". + +Import uPred. +Import RecordSetNotations. + +Section state_interpretation. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + (* TODO: Find alternative *) + Lemma aneris_state_interp_network_sockets_coh_valid σ rt : + aneris_state_interp σ rt -∗ ⌜network_sockets_coh (state_sockets σ)⌝. + Proof. by iDestruct 1 as (??) "(?&?&?&?)". Qed. + + (** socket_handlers_coh *) + Lemma socket_handlers_coh_alloc_socket Sn sh s : + saddress s = None → + socket_handlers_coh Sn → + socket_handlers_coh (<[sh:=(s, [])]> Sn). + Proof. + intros ?? sh1 sh2 * ??? H. symmetry in H. + ddeq sh1 sh2; ddeq sh1 sh; ddeq sh2 sh; eauto. + Qed. + + Lemma socket_handlers_coh_socketbind Sn sh skt a : + (∀ sh' skt' r' a', + Sn !! sh' = Some (skt', r') → + saddress skt' = Some a' → + port_of_address a' ≠ port_of_address a) → + socket_handlers_coh Sn → + socket_handlers_coh (<[sh:=(skt <| saddress := Some a |>, [])]> Sn). + Proof. + intros ? Hscoh sh1 sh2 skt1 skt2 ????? Heq. + ddeq sh1 sh; ddeq sh2 sh; simplify_eq=>//. + - destruct skt, skt2; simplify_map_eq. set_solver. + - destruct skt, skt1. simplify_map_eq. set_solver. + - destruct skt1, skt2. simplify_map_eq. eapply Hscoh; eauto. + Qed. + + Lemma socket_handlers_coh_update_buffer Sn sh skt R R' : + Sn !! sh = Some (skt, R) → + socket_handlers_coh Sn → + socket_handlers_coh (<[sh:=(skt, R')]> Sn). + Proof. + intros Hsh HSn sh1 sh2 skt1 skt2 r1 r2 Hsh1 Hsh2 Hskt1 Hskt12. + destruct (decide (sh1 = sh)) as [->|]; + destruct (decide (sh2 = sh)) as [->|]; simplify_eq; eauto. + - rewrite lookup_insert in Hsh1; rewrite lookup_insert_ne in Hsh2; + last done. + eapply HSn; eauto; naive_solver. + - rewrite lookup_insert_ne in Hsh1; last done; + rewrite lookup_insert in Hsh2. + eapply HSn; eauto; naive_solver. + - rewrite lookup_insert_ne in Hsh1; last done; + rewrite lookup_insert_ne in Hsh2; last done. + eapply HSn; eauto; naive_solver. + Qed. + + Lemma socket_handlers_coh_update_sblock σ Sn ip sh skt r b : + state_sockets σ !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + socket_handlers_coh Sn → + socket_handlers_coh + (<[sh:=({| saddress := saddress skt; + sblock := b |}, r)]> Sn). + Proof. + intros ?? Hscoh sh1 sh2 skt1 skt2 ????? Heq. + ddeq sh1 sh; ddeq sh2 sh; simplify_eq=>//. + - eapply Hscoh; eauto. by rewrite Heq in H1. + - eapply Hscoh; eauto. rewrite Heq. eauto. + - eapply Hscoh; eauto. rewrite Heq. naive_solver. + Qed. + + (** socket_messages_coh *) + Lemma socket_messages_coh_update_socket Sn sh skt : + socket_messages_coh Sn → + socket_messages_coh (<[sh:=(skt, [])]> Sn). + Proof. intros ? sh' **. ddeq sh sh'; [set_solver|]. eauto. Qed. + + Lemma socket_messages_coh_update_buffer a sh skt Sn R R' : + Sn !! sh = Some (skt, R) → + Forall (λ m, m_destination m = a) R' → + saddress skt = Some a → + socket_messages_coh Sn → + socket_messages_coh (<[sh:=(skt, R')]> Sn). + Proof. + intros ? Hall ? Hmcoh sh' skt' r' a' Hsh' ?. + destruct (decide (sh = sh')); simplify_eq; last first. + { rewrite lookup_insert_ne // in Hsh'. by eapply Hmcoh. } + rewrite lookup_insert in Hsh'; simplify_eq. + by rewrite Forall_forall in Hall. + Qed. + + Lemma socket_messages_coh_deliver_message Sn sh skt a R m : + m_destination m = a → + Sn !! sh = Some (skt, R) → + saddress skt = Some a → + socket_messages_coh Sn → + socket_messages_coh (<[sh:=(skt, m :: R)]> Sn). + Proof. + intros ??? Hmcoh. + eapply socket_messages_coh_update_buffer; [done| |done..]. + apply Forall_forall. + intros m' [HR | ?] %elem_of_cons; subst; [done|]. + by eapply Hmcoh. + Qed. + + Lemma socket_messages_coh_shrink_buffer Sn sh skt R1 R2 : + Sn !! sh = Some (skt, R1 ++ R2) → + socket_messages_coh Sn → + socket_messages_coh (<[sh:=(skt, R1)]> Sn). + Proof. + intros HSn Hcoh sh' kt' r' a' Hsh' Hskt' m' Hm'. + ddeq sh sh'; eapply Hcoh; eauto. set_solver. + Qed. + + Lemma socket_messages_coh_receive Sn sh skt r m : + Sn !! sh = Some (skt, r ++ [m]) → + socket_messages_coh Sn → + socket_messages_coh (<[sh:=(skt, r)]> Sn). + Proof. by apply socket_messages_coh_shrink_buffer. Qed. + + Lemma socket_messages_coh_update_sblock Sn sh skt r b: + Sn !! sh = Some (skt, r) → + socket_messages_coh Sn → + socket_messages_coh (<[sh:=({| saddress := saddress skt; + sblock := b |}, r)]> Sn). + Proof. + intros HSn Hcoh sh' kt' r' a' Hsh' Hskt' m' Hm'. + ddeq sh sh'; eapply Hcoh; eauto. + Qed. + + (** socket_addresses_coh *) + Lemma socket_addresses_coh_alloc_socket Sn sh skt n : + saddress skt = None → + socket_addresses_coh Sn n → + socket_addresses_coh (<[sh:=(skt, [])]> Sn) n. + Proof. intros ? ? sh' **. ddeq sh' sh; eauto. Qed. + + Lemma socket_addresses_coh_socketbind Sn sh skt a : + saddress skt = None → + socket_addresses_coh Sn (ip_of_address a) → + socket_addresses_coh + (<[sh:=(skt <| saddress := Some a |>, [])]> Sn) (ip_of_address a). + Proof. intros ? ? sh' **; ddeq sh sh'; eauto. Qed. + + Lemma socket_addresses_coh_insert_received sh a skt m R Sn : + saddress skt = Some a → + socket_addresses_coh Sn (ip_of_address a) → + socket_addresses_coh (<[sh:=(skt, m :: R)]> Sn) (ip_of_address a). + Proof. intros ?? sh' **; ddeq sh sh'; eauto. Qed. + + Lemma socket_addresses_coh_update_buffer Sn sh ip skt R1 R2 : + Sn !! sh = Some (skt, R1) → + socket_addresses_coh Sn ip → + socket_addresses_coh (<[sh:=(skt, R2)]> Sn) ip. + Proof. + intros Hsh HSn sh' skt' R' sa Hsh' Hskt'. + destruct (decide (sh = sh')) as [->|]. + - rewrite lookup_insert in Hsh'; simplify_eq. + eapply HSn; eauto. + - rewrite lookup_insert_ne in Hsh'; last done. + eapply HSn; eauto. + Qed. + + Lemma socket_addresses_coh_update_sblock Sn sh skt r b ip: + Sn !! sh = Some (skt, r) → + socket_addresses_coh Sn ip → + socket_addresses_coh (<[sh:=({| + saddress := saddress skt; + sblock := b |}, r)]> Sn) ip. + Proof. + intros HSn Hcoh sh' kt' r' a' Hsh' Hskt'. + ddeq sh sh'; eapply Hcoh; eauto. + Qed. + + (** socket_unbound_empty_buf_coh *) + Lemma socket_unbound_empty_buf_coh_alloc_socket Sn sh ip skt: + saddress skt = None → + socket_unbound_empty_buf_coh Sn ip → + socket_unbound_empty_buf_coh (<[sh:=(skt, [])]> Sn) ip. + Proof. + intros Hskt HSn sh' skt' R Hsh' Hskt'. + destruct (decide (sh = sh')) as [->|]. + - rewrite lookup_insert in Hsh'; simplify_eq; done. + - rewrite lookup_insert_ne in Hsh'; last done. + eapply HSn; eauto. + Qed. + + Lemma socket_unbound_empty_buf_coh_socketbind Sn sh skt a: + saddress skt = None → + socket_unbound_empty_buf_coh Sn (ip_of_address a) → + socket_unbound_empty_buf_coh + (<[sh:=(skt <|saddress := Some a|> , [])]> Sn) (ip_of_address a). + Proof. + intros Hskt HSn sh' skt' R Hsh' Hskt'. + destruct (decide (sh = sh')) as [->|]. + - rewrite lookup_insert in Hsh'; simplify_eq; done. + - rewrite lookup_insert_ne in Hsh'; last done. + eapply HSn; eauto. + Qed. + + Lemma socket_unbound_empty_buf_coh_update_buffer Sn sh ip skt a R1 R2 : + Sn !! sh = Some (skt, R1) → + saddress skt = Some a → + socket_unbound_empty_buf_coh Sn ip → + socket_unbound_empty_buf_coh (<[sh:=(skt, R2)]> Sn) ip. + Proof. + intros Hsh Hskt HSn sh' skt' R' Hsh' Hskt'. + destruct (decide (sh = sh')) as [->|]. + - rewrite lookup_insert in Hsh'; simplify_eq; done. + - rewrite lookup_insert_ne in Hsh'; last done. + eapply HSn; eauto. + Qed. + + Lemma socket_unbound_empty_buf_coh_shrink_buffer Sn ip sh skt R1 R2 : + Sn !! sh = Some (skt, R1 ++ R2) → + socket_unbound_empty_buf_coh Sn ip → + socket_unbound_empty_buf_coh (<[sh:=(skt, R1)]> Sn) ip. + Proof. + intros Hsn Hcoh sh' skt' r' Hsh' Hskt'. ddeq sh sh'; eauto. + specialize (Hcoh sh' skt' _ Hsn Hskt'). + by apply app_eq_nil in Hcoh as [??]. + Qed. + + Lemma socket_unbound_empty_buf_coh_update_sblock Sn sh skt r b ip: + Sn !! sh = Some (skt, r) → + socket_unbound_empty_buf_coh Sn ip → + socket_unbound_empty_buf_coh (<[sh:=({| saddress := saddress skt; + sblock := b |}, r)]> Sn) ip. + Proof. + intros Hsn Hcoh sh' skt' r' Hsh' Hskt'. ddeq sh sh'; eauto. + Qed. + + (** network_sockets_coh *) + Lemma network_sockets_coh_alloc_node Sn ip : + Sn !! ip = None → + network_sockets_coh Sn → + network_sockets_coh (<[ip:=∅]> Sn). + Proof. + rewrite /network_sockets_coh. + intros ? Hcoh ip' ? Hst. + destruct (decide (ip' = ip)); simplify_eq. + - apply lookup_insert_rev in Hst. subst. split; done. + - eapply Hcoh; by rewrite lookup_insert_ne in Hst. + Qed. + + Lemma network_sockets_coh_init n : network_sockets_coh {[n:= ∅]}. + Proof. + rewrite /network_sockets_coh. + intros n' Sn' HSn. + ddeq n' n; + [rewrite lookup_insert in HSn + |rewrite lookup_insert_ne in HSn]; + rewrite /socket_handlers_coh + /socket_messages_coh + /socket_addresses_coh + /socket_unbound_empty_buf_coh; + set_solver. + Qed. + + Lemma network_sockets_coh_update_sblock σ sh skt r ip Sn b : + state_sockets σ !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + network_sockets_coh (state_sockets σ) → + network_sockets_coh + (<[ip:=<[sh:=({| saddress := saddress skt; + sblock := b |}, r)]> Sn]> (state_sockets σ)). + Proof. + rewrite /network_sockets_coh. + intros ?? Hnets ip' Sn' HSn. ddeq ip' ip; [|eauto]. + destruct (Hnets ip Sn) as (?&?&?&?); [done|]. + split; [by eapply socket_handlers_coh_update_sblock|]. + split; [by eapply socket_messages_coh_update_sblock|]. + split; [by eapply socket_addresses_coh_update_sblock | + by eapply socket_unbound_empty_buf_coh_update_sblock]. + Qed. + + Lemma network_sockets_coh_alloc_socket S Sn n sh skt : + S !! n = Some Sn → + Sn !! sh = None → + saddress skt = None → + network_sockets_coh S → + network_sockets_coh (<[n:=<[sh:=(skt, [])]> Sn]> S). + Proof. + rewrite /network_sockets_coh. + intros ??? Hnets n' Sn' HSn. ddeq n' n; [|eauto]. + destruct (Hnets n Sn) as (?&?&?&?); [done|]. + split; [by apply socket_handlers_coh_alloc_socket|]. + split; [by apply socket_messages_coh_update_socket|]. + split; [by apply socket_addresses_coh_alloc_socket | + by apply socket_unbound_empty_buf_coh_alloc_socket]. + Qed. + + Lemma network_sockets_coh_socketbind S Sn sh skt a : + let ip := ip_of_address a in + let S' := <[ip:= <[sh:= (skt <| saddress := Some a |>, [])]> Sn]> S in + S !! ip = Some Sn → + Sn !! sh = Some (skt, []) → + port_not_in_use (port_of_address a) Sn → + saddress skt = None → + network_sockets_coh S → + network_sockets_coh S'. + Proof. + rewrite /network_sockets_coh /=. + intros ???? Hncoh ip Sn' ?. + assert + (∀ sh' skt' r' a', + Sn !! sh' = Some (skt', r') → + saddress skt' = Some a' → + port_of_address a' ≠ port_of_address a ). + { destruct (Hncoh (ip_of_address a) Sn) as + (HshCoh & HmrCoh & HsaCoh); + [done|]. + intros ** Hp. + assert (ip_of_address a' = ip_of_address a) as Heq. + { eapply HsaCoh; eauto. } + assert (port_of_address a' ≠ port_of_address a) as Hnp. + { eapply H1; eauto. } + set_solver. } + ddeq ip (ip_of_address a). + - destruct (Hncoh (ip_of_address a) Sn) as (?&?&?&?); [done|]. + split; [by eapply socket_handlers_coh_socketbind|]. + split; [by eapply socket_messages_coh_update_socket|]. + split; [by eapply socket_addresses_coh_socketbind |]. + apply socket_unbound_empty_buf_coh_socketbind; done. + - destruct (Hncoh ip Sn') as (HshCoh & HmrCoh & HsaCoh); + [done|split;[done|split; done]]. + Qed. + + Lemma network_sockets_coh_receive S Sn ip sh skt r m : + S !! ip = Some Sn → + Sn !! sh = Some (skt, r ++ [m]) → + network_sockets_coh S → + network_sockets_coh (<[ip:=<[sh:=(skt, r)]> Sn]> S). + Proof. + rewrite /network_sockets_coh. + intros HS HSn Hnet ip' Sn0 HSn0. + ddeq ip' ip; [|eauto]. + specialize (Hnet ip Sn HS) + as (Hshcoh & Hsmcoh & Hsaddrcoh & Hbufcoh). + split; [by eapply socket_handlers_coh_update_buffer|]. + split; [by eapply socket_messages_coh_shrink_buffer|]. + split; [by eapply socket_addresses_coh_update_buffer|]. + by eapply socket_unbound_empty_buf_coh_shrink_buffer. + Qed. + + Lemma network_sockets_coh_deliver_message S Sn Sn' ip sh skt a r m : + m_destination m = a → + S !! ip = Some Sn → + Sn !! sh = Some (skt, r) → + Sn' = <[sh:=(skt, m :: r)]> Sn → + saddress skt = Some a → + network_sockets_coh S → + network_sockets_coh (<[ip:=Sn']> S). + Proof. + rewrite /network_sockets_coh. + intros HM HSn Hsh HSn' Hskt Hnet ip' Sn0 HSn0. + ddeq ip' ip; [|eauto]. + specialize (Hnet ip Sn HSn) + as (Hshcoh & Hsmcoh & Hsaddrcoh & Hbufcoh). + split; [by eapply socket_handlers_coh_update_buffer|]. + split; [by eapply socket_messages_coh_deliver_message|]. + split; [by eapply socket_addresses_coh_update_buffer |]. + by eapply socket_unbound_empty_buf_coh_update_buffer. + Qed. + +End state_interpretation. diff --git a/fairneris/aneris_lang/state_interp/state_interp_socket_interp_coh.v b/fairneris/aneris_lang/state_interp/state_interp_socket_interp_coh.v new file mode 100644 index 0000000..f52e3d4 --- /dev/null +++ b/fairneris/aneris_lang/state_interp/state_interp_socket_interp_coh.v @@ -0,0 +1,93 @@ +From stdpp Require Import fin_maps gmap. +From iris.bi.lib Require Import fractional. +From iris.proofmode Require Import tactics. +From iris.base_logic.lib Require Import saved_prop gen_heap. +From fairneris Require Import fuel env_model. +From fairneris.prelude Require Import misc. +From fairneris.lib Require Import gen_heap_light. +From fairneris.aneris_lang Require Import + aneris_lang network resources. +From fairneris.aneris_lang.state_interp Require Import + state_interp_def. +From fairneris.algebra Require Import disj_gsets. +From iris.algebra Require Import auth. + +From RecordUpdate Require Import RecordSet. +Set Default Proof Using "Type". + +Import uPred. +Import RecordSetNotations. + +Section state_interpretation. + Context `{LM: LiveModel aneris_lang (joint_model Mod Net)}. + Context `{!LiveModelEq LM}. + Context `{aG : !anerisG LM Σ}. + + (* socket_interp_coh *) + Lemma socket_interp_coh_init C : + socket_address_group_ctx C -∗ + unallocated_groups_auth C -∗ + saved_si_auth ∅ -∗ + socket_interp_coh. + Proof. + iIntros "Hsags Hunallocated Hsis". + iExists _, _. iFrame. iSplit; [done|]. + rewrite difference_diag_L. + iExists _. + iFrame. iSplit; [by iPureIntro; set_solver|done]. + Qed. + + Lemma socket_interp_coh_allocate_singleton sag φ : + socket_interp_coh -∗ unallocated_groups {[sag]} ==∗ + socket_interp_coh ∗ sag ⤇* φ. + Proof. + iIntros "Hinterp Hsag". + iDestruct "Hinterp" as (sags A Hle) "(Hsags & Hunallocated & Hsis)". + iAssert (⌜sag ∈ A⌝)%I as %Hin. + { iDestruct (own_valid_2 with "Hunallocated Hsag") as %Hvalid. + rewrite auth_both_valid_discrete in Hvalid. + destruct Hvalid as [Hincluded Hvalid]. + rewrite gset_disj_included in Hincluded. + iPureIntro. set_solver. } + iAssert (socket_address_group_own sag) as "#Hsag'". + { rewrite /socket_address_group_own. + iApply (socket_address_group_own_subseteq sags); [set_solver|]. + by iApply socket_address_groups_ctx_own. } + iMod (unallocated_update_dealloc with "[$Hunallocated $Hsag]") as "Hunallocated". + iDestruct "Hsis" as (sis) "(Hsaved & %Hdom & Hsis)". + iMod (socket_interp_alloc with "Hsag' Hsaved") + as (γsi) "[Hsaved #Hsi]". + { apply not_elem_of_dom. set_solver. } + iModIntro. iFrame "#∗". + iExists sags, (A ∖ {[sag]}). + iSplit; [iPureIntro; set_solver|]. + iFrame. iExists _. iSplit; [done|]. + iSplit; [iPureIntro|]. + { rewrite dom_insert_L. + rewrite Hdom. rewrite difference_difference_union; set_solver. } + rewrite difference_difference_union; [|set_solver]. + iApply big_sepS_union; [set_solver|]. + iFrame. iApply big_sepS_singleton. + iExists _. iFrame "#". + Qed. + + Lemma socket_interp_coh_allocate_fun sags f : + socket_interp_coh -∗ unallocated_groups sags ==∗ + socket_interp_coh ∗ [∗ set] sag ∈ sags, sag ⤇* (f sag). + Proof. + iIntros "Hinterp Hsags". + iInduction sags as [|sag sags Hnin] "IHsags" using set_ind_L; [by eauto|]. + iDestruct (unallocated_groups_split with "Hsags") as "[Hsag Hsags]"; + [set_solver|]. + rewrite big_sepS_union; [|set_solver]. + rewrite big_sepS_singleton. + iMod ("IHsags" with "Hinterp Hsags") as "[Hinterp $]". + iApply (socket_interp_coh_allocate_singleton with "Hinterp Hsag"). + Qed. + + Lemma socket_interp_coh_allocate sags φ : + socket_interp_coh -∗ unallocated_groups sags ==∗ + socket_interp_coh ∗ [∗ set] sag ∈ sags, sag ⤇* φ. + Proof. iApply socket_interp_coh_allocate_fun. Qed. + +End state_interpretation. diff --git a/fairneris/env_model.v b/fairneris/env_model.v new file mode 100644 index 0000000..7e52087 --- /dev/null +++ b/fairneris/env_model.v @@ -0,0 +1,130 @@ +From stdpp Require Import option countable. +From fairneris Require Export inftraces fairness ltl_lite. + +Class GoodLang (Λ : language) + `{Countable (config_label Λ), Inhabited (config_label Λ)} + `{Countable (action Λ)} + `{Countable (locale Λ)} + := {}. + + + +Record Lts lab `{Countable lab, Inhabited lab}: Type := { + lts_state :> Type; + lts_state_eqdec :: EqDecision lts_state; + lts_state_inhabited :: Inhabited lts_state; + + lts_trans: lts_state → lab → lts_state → Prop; +}. + + +Arguments lts_state {_ _ _ _}. +Arguments lts_trans {_ _ _ _}. + +Definition lts_trace {L} `{Countable L, Inhabited L} (LTS: Lts L) := trace LTS.(lts_state) L. +Definition lts_label {L} `{Countable L, Inhabited L} (LTS: Lts L) := L. + +Section models. +Context (Λ: language). +Context `{GoodLang Λ}. + +Record EnvModel := { + env_lts :> Lts (action Λ + config_label Λ); + env_states_match : cfg Λ → env_lts.(lts_state) → Prop; + env_apply_trans : env_lts.(lts_state) → (action Λ + config_label Λ) → env_lts.(lts_state); + env_apply_trans_spec_trans : ∀ m1 m2 cl, + env_apply_trans m1 cl = m2 → + lts_trans env_lts m1 cl m2; + env_apply_trans_spec_both : ∀ ζ c1 m1 cl c2 m2, + env_apply_trans m1 cl = m2 → + locale_step c1 (sum_map (λ α, (ζ, Some α)) id cl) c2 → + env_states_match c1 m1 → + env_states_match c2 m2; + env_match_internal_step : ∀ ζ c1 m c2, + locale_step c1 (inl (ζ, None)) c2 → + env_states_match c1 m → + env_states_match c2 m; + env_fairness: trace env_lts.(lts_state) (action Λ + config_label Λ) → Prop; +}. + +Arguments env_lts {_}. + +Record UserModel := { + usr_role : Type; + + usr_eqdec:: EqDecision usr_role; + usr_countable:: Countable usr_role; + usr_inhabited:: Inhabited usr_role; + + usr_lts :> Lts (usr_role * option (action Λ)); + + usr_live_roles: usr_lts.(lts_state) → gset usr_role; + usr_live_spec: ∀ s ρ α s', usr_lts.(lts_trans) s (ρ,α) s' → ρ ∈ usr_live_roles s; + + usr_fl : usr_lts.(lts_state) → nat; +}. + +Arguments usr_live_roles {_}. + +Section user_fairness. + Context `{M: UserModel}. + + Definition usr_trans_valid (mtr : lts_trace M) := + match mtr with + | ⟨s⟩ => True + | (s -[l]-> tr) => lts_trans _ s l (trfirst tr) + end. + + Definition usr_trace_valid (mtr : lts_trace M) := + trace_always usr_trans_valid mtr. + + Definition usr_fair_scheduling_mtr (ρ : M.(usr_role)) : lts_trace M → Prop := + trace_always_eventually_implies_now + (λ (δ: M) _, ρ ∈ usr_live_roles δ) + (λ δ (ℓ : option (usr_role M * option (action Λ))), ρ ∉ usr_live_roles δ ∨ ∃ α, ℓ = Some (ρ, α)). + + Definition usr_fair_scheduling (mtr : lts_trace M) : Prop := + ∀ ρ, usr_fair_scheduling_mtr ρ mtr. +End user_fairness. + +Inductive joint_trans {M: UserModel} {N: EnvModel} : + (M * N) → ((usr_role M * option (action Λ)) + config_label Λ) → (M * N) → Prop := +| UsrTrans n u1 u2 ρ : lts_trans M u1 (ρ, None) u2 → joint_trans (u1, n) (inl (ρ, None)) (u2, n) +| NetTrans u n1 n2 ℓ : lts_trans N n1 (inr ℓ) n2 → joint_trans (u, n1) (inr ℓ) (u, n2) +| SyncTrans u1 u2 n1 n2 ρ α : + lts_trans M u1 (ρ, Some α) u2 → lts_trans N n1 (inl α) n2 → + joint_trans (u1, n1) (inl (ρ, Some α)) (u2, n2) +. + +Program Definition joint_model (M: UserModel) (N: EnvModel) : FairModel := +{| + fmstate := lts_state (usr_lts M) * lts_state N; + (* Why doesn't this work??? *) + fmrole := usr_role M; + fmaction := option (action Λ); + fmconfig := config_label Λ; + fmtrans s1 ℓ s2 := joint_trans s1 ℓ s2; + live_roles s := usr_live_roles s.1; + fm_fl s := usr_fl _ s.1; + + (* We want somehting like: *) + (* fmfairness tr := env_fairness _ tr; *) + (* but it's not so easy, because this definition is not constructive... *) + (* it may be easier to only state it on the joint model directly... *) + fmfairness _ := True; +|}. +Next Obligation. by intros ??????; inversion 1; simplify_eq; eapply usr_live_spec. Qed. + +End models. + +Arguments usr_role {_ _ _}. +Arguments usr_lts {_ _ _}. +Arguments usr_fl {_ _ _ _}. +Arguments usr_live_roles {_ _ _ _}. +Arguments env_lts {_ _ _}. +Arguments env_states_match {_ _ _ _ _ _ _}. +Arguments joint_model {_ _ _ _ _ _}. +Arguments joint_trans {_ _ _ _ _ _}. +Arguments usr_trace_valid {_ _ _ _} _. +Arguments usr_fair_scheduling {_ _ _ _} _. +Arguments usr_fair_scheduling_mtr {_ _ _ _} _ _. diff --git a/fairneris/env_model_project.v b/fairneris/env_model_project.v new file mode 100644 index 0000000..b356b4d --- /dev/null +++ b/fairneris/env_model_project.v @@ -0,0 +1,723 @@ +From stdpp Require Import option countable. +From fairneris Require Export inftraces trace_utils fairness env_model ltl_lite. +From trillium.prelude Require Import classical classical_instances finitary. +From Paco Require Import paco2 pacotac. +From Coq.Logic Require Import Classical. + +Section measure. + Context {Λ: language}. + Context `{GoodLang Λ}. + Context (M: UserModel Λ). + Context (N: EnvModel Λ). + + Notation JM := (joint_model M N). + + Notation jmtrace := (trace JM (fmlabel JM)). + + Definition jm_trans_valid (mtr : jmtrace) := + match mtr with + | ⟨s⟩ => True + | (s -[l]-> tr) => fmtrans _ s l (trfirst tr) + end. + + Definition jmtrace_valid (mtr : jmtrace) := + trace_always jm_trans_valid mtr. + + Definition jm_fair_scheduling_mtr (ρ : M.(usr_role)) : jmtrace → Prop := + trace_always_eventually_implies_now + (λ (δ: JM) _, ρ ∈ live_roles _ δ) + (λ δ (ℓ: option $ fmlabel JM), ρ ∉ live_roles _ δ ∨ ∃ α, ℓ = Some (inl (ρ, α))). + + Definition jm_fair_scheduling (mtr : jmtrace) : Prop := + ∀ ρ, jm_fair_scheduling_mtr ρ mtr. + + Fixpoint env_steps_count (tr: jmtrace) (bound: nat) : option nat := + match bound with + | 0 => None + | S bound => + match tr with + | ⟨ s ⟩ => Some 0 + | s -[ inl _ ]-> r => Some 0 + | s -[ inr _ ]-> r => option_map (λ x, 1 + x) (env_steps_count r bound) + end + end. + + Lemma env_steps_count_deterministic tr n1 n2 x y : + env_steps_count tr n1 = Some x → + env_steps_count tr n2 = Some y → + x = y. + Proof. + revert tr n2 x y. induction n1 as [|n1 IH]; first naive_solver. + intros tr n2 x y He1 He2. + destruct n2 as [|n2]=>//. + destruct tr as [|s ℓ tr] =>//; first naive_solver. + simpl in *. destruct ℓ; first naive_solver. + destruct (env_steps_count tr n1) eqn:Heq1; last naive_solver. + destruct (env_steps_count tr n2) eqn:Heq2; last naive_solver. + simpl in *. simplify_eq. f_equal. by eapply IH. + Qed. + + Lemma env_steps_count_step n s ℓ tr : + env_steps_count (s -[ ℓ ]-> tr) (1+n) = Some (1+n) → + env_steps_count tr n = Some n. + Proof. + simpl. destruct ℓ. naive_solver. destruct (env_steps_count _ _) eqn:Heq=>//. naive_solver. + Qed. + + Lemma env_steps_count_step_gt' bound n m s ℓ tr : + env_steps_count (s -[ inr ℓ ]-> tr) (S bound) = Some n → + env_steps_count tr bound = Some m → + n > m. + Proof. + simpl. destruct (env_steps_count _ _); naive_solver. + Qed. + + Lemma env_steps_count_step_gt n1 n2 n m s ℓ tr : + env_steps_count (s -[ inr ℓ ]-> tr) n1 = Some n → + env_steps_count tr n2 = Some m → + n > m. + Proof. + destruct n1 as [|n1]; first naive_solver. simpl. + simpl. destruct (env_steps_count _ _) as [n0|] eqn:Heq; last naive_solver. + simpl. intros; simplify_eq. + have -> //: n0 = m; last lia. + by eapply env_steps_count_deterministic. + Qed. + + Definition is_usr_step (_ : JM) (ℓ : option $ fmlabel JM) : Prop := + match ℓ with + | Some (inl _) => True + | _ => False + end. + + Definition is_usr_step_or_disabled ρ (s : JM) (ℓ : option $ fmlabel JM) : Prop := + ρ ∉ live_roles _ s ∨ ∃ ℓ', ℓ = Some $ inl ℓ'. + + Lemma env_steps_count_is_Some' n tr ρ: + jmtrace_valid tr → + ρ ∈ live_roles _ (trfirst tr) → + pred_at tr n (is_usr_step_or_disabled ρ) → + ∃ m, env_steps_count tr (S n) = Some m ∧ pred_at tr m is_usr_step. + Proof. + revert tr. induction n as [|n IH]; intros tr Hval Hρ Henv. + { destruct tr; rewrite /pred_at /is_usr_step_or_disabled //= in Henv; naive_solver. } + destruct tr as [|s ℓ tr]=>//. + simpl. destruct ℓ. + { exists 0. split=>//. } + odestruct (IH tr _ _) as [m [HS Hpa]] =>//. + { unshelve eapply (trace_always_suffix_of _ _ _ _ Hval). by exists 1. } + { simpl in Hρ, Hval. rewrite /jmtrace_valid in Hval. + apply trace_always_elim in Hval. + destruct (trfirst tr) eqn:Heq. + inversion Hval; simplify_eq. simpl in *. congruence. } + exists (1+m). simpl. split=>//. destruct tr as [| ? ℓ ?]; first naive_solver. + destruct ℓ; first naive_solver. simpl in HS. rewrite HS //. + Qed. + + Lemma env_steps_bound_exists ρ tr : + jm_fair_scheduling tr → + ρ ∈ live_roles _ (trfirst tr) → + exists n, pred_at tr n (is_usr_step_or_disabled ρ). + Proof. + unfold jm_fair_scheduling, jm_fair_scheduling_mtr, trace_always_eventually_implies_now, + trace_always_eventually_implies. + intros Hf Hl. specialize (Hf ρ). + apply trace_always_elim in Hf. + rewrite trace_impliesI in Hf. + ospecialize (Hf _). + { rewrite /trace_now. destruct tr=>//. } + rewrite trace_eventuallyI in Hf. destruct Hf as [tr' [Hsuff Hlive]]. + rewrite /trace_now in Hlive. + destruct Hsuff as [n Hafter]. + exists n. rewrite /pred_at /is_usr_step_or_disabled Hafter. rewrite /pred_at in Hlive. + destruct tr'; simpl in Hlive; naive_solver. + Qed. + + Definition env_steps_bound_get_bound ρ tr + (Hf: jm_fair_scheduling tr) + (Hlive: ρ ∈ live_roles _ (trfirst tr)): + nat := epsilon (env_steps_bound_exists _ _ Hf Hlive). + + Lemma env_steps_bound_get_bound_correct ρ tr + (Hf: jm_fair_scheduling tr) + (Hlive: ρ ∈ live_roles _ (trfirst tr)): + pred_at tr (env_steps_bound_get_bound _ _ Hf Hlive) (is_usr_step_or_disabled ρ). + Proof. rewrite /env_steps_bound_get_bound. apply epsilon_correct. Qed. + + Lemma env_steps_count_is_Some tr ρ + (Hval: jmtrace_valid tr) + (Hf: jm_fair_scheduling tr) + (Hlive: ρ ∈ live_roles _ (trfirst tr)): + ∃ m, env_steps_count tr (S $ env_steps_bound_get_bound _ _ Hf Hlive) = Some m ∧ pred_at tr m is_usr_step. + Proof. + eapply env_steps_count_is_Some' =>//. + apply env_steps_bound_get_bound_correct. + Qed. + + Definition env_steps_count_good tr ρ + (Hval: jmtrace_valid tr) + (Hf: jm_fair_scheduling tr) + (Hlive: ρ ∈ live_roles _ (trfirst tr)): + nat + := epsilon (env_steps_count_is_Some _ _ Hval Hf Hlive). + + Lemma env_steps_count_good_correct tr ρ + (Hval: jmtrace_valid tr) + (Hf: jm_fair_scheduling tr) + (Hlive: ρ ∈ live_roles _ (trfirst tr)): + env_steps_count tr (S $ env_steps_bound_get_bound _ _ Hf Hlive) = Some (env_steps_count_good _ _ Hval Hf Hlive) + ∧ pred_at tr (env_steps_count_good _ _ Hval Hf Hlive) is_usr_step. + Proof. rewrite /env_steps_count_good. apply epsilon_correct. Qed. + + #[local] Instance live_dec (tr : jmtrace): Decision (∃ ρ : fmrole JM, ρ ∈ live_roles JM (trfirst tr)). + Proof. apply make_decision. Qed. + #[local] Instance valid_dec (tr: jmtrace) : Decision (jmtrace_valid tr ∧ jm_fair_scheduling tr). + Proof. apply make_decision. Qed. + + Definition env_steps_count_total tr : nat := + match decide (∃ ρ, ρ ∈ live_roles _ (trfirst tr)) with + | left Hin => + let ρ := choose _ Hin in + match decide (jmtrace_valid tr ∧ jm_fair_scheduling tr) with + | left (conj Hval Hf) => + S $ env_steps_count_good tr ρ Hval Hf (choose_correct (λ ρ, ρ ∈ live_roles _ (trfirst tr)) _) + | right _ => 0 + end + | right _ => + 0 + end. + + Definition trace_is_trimmed (tr: jmtrace) := + ∀ n, match after n tr with + | Some (s -[ℓ]-> tr') => + ∃ m, pred_at (s -[ℓ]-> tr') m is_usr_step + | _ => True + end. + + #[local] Instance decide_for_trimming tr: + Decision (∃ m : nat, pred_at tr m is_usr_step). + Proof. apply make_decision. Qed. + + CoFixpoint trim_trace (tr: jmtrace) : jmtrace := + match tr with + | ⟨ s ⟩ => ⟨ s ⟩ + | s -[ℓ]-> tr' => + if decide (∃ m, pred_at (s -[ℓ]-> tr') m is_usr_step) then + s -[ℓ]-> (trim_trace tr') + else + ⟨ s ⟩ + end. + + Inductive trimmed_of_ind (trimmed_of: jmtrace → jmtrace → Prop) : jmtrace → jmtrace → Prop := + | TrimmedEnd s : trimmed_of_ind trimmed_of ⟨s⟩ ⟨s⟩ + | TrimmedKeep s ℓ tr1 tr2 : + trimmed_of tr1 tr2 → + (∃ m, pred_at (s -[ℓ]-> tr1) m is_usr_step) → + trimmed_of_ind trimmed_of (s -[ℓ]-> tr1) (s -[ℓ]-> tr2) + | TrimmedStop s ℓ tr1 tr2 : + trimmed_of tr1 tr2 → + (¬ ∃ m, pred_at (s -[ℓ]-> tr1) m is_usr_step) → + trimmed_of_ind trimmed_of (s -[ℓ]-> tr1) ⟨s⟩. + + Definition trimmed_of := paco2 trimmed_of_ind bot2. + + Lemma trimmed_of_mono : + monotone2 (trimmed_of_ind). + Proof. + unfold monotone2. intros x0 x1 r r' IN LE. + induction IN; try (econstructor; eauto; done). + Qed. + Hint Resolve trimmed_of_mono : paco. + + Lemma trim_trace_trimmed_of tr: + trimmed_of tr (trim_trace tr). + Proof. + revert tr. pcofix CH=> tr. pfold. + destruct tr as [s|s ℓ tr]; rewrite (trace_unfold_fold (trim_trace _)) /=. + { constructor. } + destruct (decide _). + - constructor 2=>//. by right. + - econstructor 3=>//. by right. + Qed. + + Lemma trimmed_of_after m tr1 tr2 tr2': + trimmed_of tr1 tr2 → + after m tr2 = Some tr2' → + ∃ tr1', after m tr1 = Some tr1' ∧ trimmed_of tr1' tr2'. + Proof. + revert tr1 tr2 tr2'. induction m as [|m IH]; intros tr1 tr2 tr2' Hto. + - destruct tr1; simpl; intros ?; simplify_eq; naive_solver. + - destruct tr1=>//; punfold Hto. + + inversion Hto; simplify_eq; naive_solver. + + inversion Hto; simplify_eq; last naive_solver. simpl. + eintros ?%IH=>//. by pclearbot. + Qed. + + Lemma trimmed_of_suffix_of tr1 tr2 tr2': + trimmed_of tr1 tr2 → + trace_suffix_of tr2' tr2 → + ∃ tr1', trace_suffix_of tr1' tr1 ∧ trimmed_of tr1' tr2'. + Proof. + intros ? [? Ha]. eapply trimmed_of_after in Ha as [tr1' ?]=>//. + exists tr1'. rewrite /trace_suffix_of. naive_solver. + Qed. + + Lemma trimmed_of_valid tr1 tr2 : + trimmed_of tr1 tr2 → + jmtrace_valid tr1 → + jmtrace_valid tr2. + Proof. + rewrite /jmtrace_valid !trace_alwaysI. + intros Hto Ha tr2' Hsuff. + destruct (trimmed_of_suffix_of _ _ _ Hto Hsuff) as (tr1'&Hsuff'&Hto'). + specialize (Ha _ Hsuff'). punfold Hto'. inversion Hto' as [| ???? IH |]; simplify_eq=>//. + rewrite /jm_trans_valid in Ha *. pclearbot. punfold IH. inversion IH; simplify_eq=>//. + Qed. + + Lemma trimmed_of_pred_at_usr m tr1 tr2: + trimmed_of tr1 tr2 → + pred_at tr1 m is_usr_step → + pred_at tr2 m is_usr_step. + Proof. + revert tr1 tr2. induction m as [|m IH]; intros tr1 tr2 Hto. + - destruct tr1=>//. punfold Hto. inversion Hto; simplify_eq; naive_solver. + - destruct tr1=>//. punfold Hto. inversion Hto; simplify_eq; last naive_solver. + rewrite !pred_at_S. intros ?. eapply IH=>//. by pclearbot. + Qed. + + Lemma trimmed_of_pred_at_usr_ex tr1 tr2: + trimmed_of tr1 tr2 → + (∃ m, pred_at tr1 m is_usr_step) → + ∃ m, pred_at tr2 m is_usr_step. + Proof. have ?:= trimmed_of_pred_at_usr. naive_solver. Qed. + + Lemma trimmed_of_eventually_back tr1 tr2 P : + trimmed_of tr1 tr2 → + (◊ ℓ↓ P) tr2 → + (◊ ℓ↓ P) tr1. + Proof. + intros Htrim. rewrite !trace_eventuallyI. intros (tr2'&Hsuff&Hnow). + eapply trimmed_of_suffix_of in Hsuff as (tr1'&?&Htrim') =>//. + exists tr1'. split=>//. punfold Htrim'. inversion Htrim'; simplify_eq=>//. + Qed. + + Lemma trimmed_of_is_trimmed tr1 tr2: + trimmed_of tr1 tr2 → + trace_is_trimmed tr2. + Proof. + intros Hto n. revert tr1 tr2 Hto. induction n as [|n IH]; intros tr1 tr2 Hto. + - destruct tr1 as [s1 | s1 ℓ1 tr1]. + + punfold Hto. by inversion Hto; simplify_eq. + + punfold Hto. inversion Hto; simplify_eq; simpl=>//. + eapply trimmed_of_pred_at_usr_ex=>//. pfold. done. + - destruct tr1 as [s1 | s1 ℓ1 tr1]. + + punfold Hto. by inversion Hto; simplify_eq. + + punfold Hto. inversion Hto; simplify_eq; simpl=>//. + eapply IH. pclearbot. done. + Qed. + + Lemma trim_trace_is_trimmed tr: + trace_is_trimmed (trim_trace tr). + Proof. eapply trimmed_of_is_trimmed, trim_trace_trimmed_of. Qed. + + Lemma trim_trace_valid tr : + jmtrace_valid tr → + jmtrace_valid (trim_trace tr). + Proof. + intros Hval. by eapply trimmed_of_valid in Hval; last eapply trim_trace_trimmed_of. + Qed. + + Lemma trimmed_of_infinite tr1 tr2: + trimmed_of tr1 tr2 → + infinite_trace tr2 → + trace_equiv tr1 tr2. + Proof. + revert tr1 tr2. cofix CH; intros tr1 tr2 Hto Hinf. + destruct tr1 as [s|s ℓ tr1]. + - punfold Hto. inversion Hto; simplify_eq. done. + - punfold Hto. inversion Hto; simplify_eq. + + constructor=>//. apply CH=>//. + * pclearbot. done. + * eapply infinite_cons. done. + + exfalso. clear CH. specialize (Hinf 1). simpl in Hinf. + inversion Hinf. naive_solver. + Qed. + + Lemma trim_trace_infinite tr: + infinite_trace (trim_trace tr) → + trace_equiv tr (trim_trace tr). + Proof. + intros Hinf. + eapply trimmed_of_infinite=>//. + apply trim_trace_trimmed_of. + Qed. + + Lemma trace_no_roles_no_usr tr: + jmtrace_valid tr → + live_roles _ (trfirst tr) = ∅ → + ∀ n, ¬ pred_at tr n is_usr_step. + Proof. + intros Hval Hnl n; revert tr Hval Hnl. + induction n as [|n IH]; intros tr Hval Hnl. + { destruct tr; first naive_solver. + rewrite pred_at_0. apply trace_always_elim in Hval. + destruct ℓ as [ℓ|]; last naive_solver. + destruct ℓ as [ρ α]. + have : ρ ∈ live_roles _ s; last set_solver. + by eapply (fm_live_spec _ _ _ α (trfirst tr)). } + destruct tr; first naive_solver. + rewrite pred_at_S. apply IH. + { apply (trace_always_suffix_of _ _ tr) in Hval =>//. by exists 1. } + + apply trace_always_elim in Hval. + destruct ℓ as [ℓ|]. + - destruct ℓ as [ρ α]. + have : ρ ∈ live_roles _ s; last set_solver. + by eapply (fm_live_spec _ _ _ α (trfirst tr)). + - rewrite /jm_trans_valid in Hval. destruct (trfirst tr). + inversion Hval; simplify_eq. naive_solver. + Qed. + + Lemma trace_no_usr_cst_live_roles n tr tr': + jmtrace_valid tr → + (∀ n, ¬ pred_at tr n is_usr_step) → + after n tr = Some tr' → + live_roles _ (trfirst tr) = live_roles _ (trfirst tr'). + Proof. + revert tr tr'. induction n as [|n IH]; intros tr tr' Hval Hdead Hafter; first naive_solver. + destruct tr as [s|s ℓ tr]; first naive_solver. + rewrite /= in Hafter. + transitivity (live_roles _ (trfirst tr)). + - apply trace_always_elim in Hval. + destruct ℓ. + { exfalso. by apply (Hdead 0). } + unfold jm_trans_valid in Hval. + destruct (trfirst tr) eqn:Heq; inversion Hval; simplify_eq=>//. + - apply IH=>//. + + eapply trace_always_suffix_of=>//. apply trace_suffix_of_cons_r, trace_suffix_of_refl. + + intros m. specialize (Hdead (1+m)). naive_solver. + Qed. + + Lemma trace_no_roles_no_usr_inv tr: + jmtrace_valid tr → + jm_fair_scheduling tr → + (∀ n, ¬ pred_at tr n is_usr_step) → + live_roles _ (trfirst tr) = ∅. + Proof. + intros Hval Hfair Hdead. + apply NNP_P. intros Hne. + apply finitary.set_choose_L' in Hne as [ρ Hin]. + specialize (Hfair ρ). apply trace_always_elim in Hfair. + rewrite trace_impliesI in Hfair. + ospecialize (Hfair _). + { destruct tr=>//. } + rewrite trace_eventuallyI in Hfair. + destruct Hfair as (tr'&[n Hafter]&Hx). + have Hafter' := Hafter. + apply trace_no_usr_cst_live_roles in Hafter=>//. + destruct tr' eqn:Heq. + - destruct Hx as [Hx|Hx]. set_solver. naive_solver. + - destruct Hx as [Hx|[? Hx]]. set_solver. + apply (Hdead n). rewrite /pred_at Hafter'. naive_solver. + Qed. + + Lemma trimmed_of_None_fair n (tr tr' : jmtrace) tr1: + jmtrace_valid tr → + jm_fair_scheduling tr → + trimmed_of tr tr' → + after n tr = Some tr1 → + after n tr' = None → + ∃ s n', n' < n ∧ after n' tr' = Some ⟨s⟩ ∧ live_roles _ s = ∅. + Proof. + revert tr tr' tr1. induction n as [|n IH]; intros tr tr' tr1 Hval Hfair Htrim HafterS HafterN. + { punfold Htrim. inversion Htrim; simplify_eq. } + destruct tr as [s | s ℓ tr]; punfold Htrim; inversion Htrim; simplify_eq; + simpl in HafterS, HafterN. + - odestruct (IH _ _ _ _ _ _ HafterS HafterN) as (s'&n'&CC&DD&EE)=>//. + { eapply trace_always_suffix_of=>//. apply trace_suffix_of_cons_r, trace_suffix_of_refl. } + { intros ρ. specialize (Hfair ρ). + eapply trace_always_suffix_of=>//. apply trace_suffix_of_cons_r, trace_suffix_of_refl. } + { by pclearbot. } + exists s', (1 + n'). split; first lia. simpl. split=>//. + - exists s, 0. split; first lia. split=>//. + change s with (trfirst (s -[ ℓ ]-> tr)). + eapply trace_no_roles_no_usr_inv=>//. by apply not_ex_all_not. + Qed. + + Definition trace_is_trimmed_alt (tr: jmtrace) := + ∀ n, match after n tr with + | Some (s -[ℓ]-> tr') => + ∃ ρ, ρ ∈ live_roles _ s + | _ => True + end. + + Lemma trace_is_trimmed_equiv tr : + jmtrace_valid tr → + trace_is_trimmed tr → + trace_is_trimmed_alt tr. + Proof. + intros Hval Htr n. + specialize (Htr n). + destruct (after n tr) as [[|s ℓ tr']|] eqn:Heq=>//. + apply NNP_P. intros Hc. + have Hemp: live_roles _ s = ∅. + { set_solver. } + apply (trace_always_suffix_of _ _ (s -[ℓ]-> tr')) in Hval; last first. + { by eexists. } + have ?:= trace_no_roles_no_usr (s -[ℓ]-> tr') Hval Hemp. + naive_solver. + Qed. + + Definition env_proj_st (s: JM) : M := fst s. + Definition env_proj_lab (ℓ: fmlabel JM) : option _ := + match ℓ with + | inl x => Some x + | _ => None + end. + + Notation env_dec_unless := (dec_unless env_proj_st env_proj_lab env_steps_count_total). + + Lemma env_steps_dec_unless tr + (Hval: jmtrace_valid tr) + (Hf: jm_fair_scheduling tr) + (Htrim: trace_is_trimmed tr): + env_dec_unless tr. + Proof. + intros n. + destruct (after n tr) as [[|s ℓ tr']|] eqn:Heq =>//. + destruct ℓ as [|f]. + { left. simpl. by eexists. } + have Hsuff1: trace_suffix_of (s -[ inr f]-> tr') tr by exists n. + have Hsuff2: trace_suffix_of tr' tr. + { by eapply trace_suffix_of_cons_l. } + right. split; last first. + { apply (trace_always_suffix_of _ _ _ Hsuff1), trace_always_elim in Hval. + destruct s as [us ns]. unfold jm_trans_valid in Hval. destruct (trfirst tr'). + by inversion Hval; simplify_eq. } + rewrite /env_steps_count_total. + + have Hlive1: ∃ ρ : fmrole JM, ρ ∈ live_roles JM s. + { apply trace_is_trimmed_equiv in Htrim=>//. + specialize (Htrim n). rewrite Heq // in Htrim. } + + have ? : jmtrace_valid tr' ∧ jm_fair_scheduling tr'. + { apply NNP_P. intros ?. + have ?: jmtrace_valid tr' by apply (trace_always_suffix_of _ _ _ Hsuff2) in Hval. + have ?: jm_fair_scheduling tr'. + { intros ρ. eapply (trace_always_suffix_of _ _ _ Hsuff2) in Hf. apply Hf. } + naive_solver. } + + have ? : jmtrace_valid (s -[ inr f ]-> tr') ∧ jm_fair_scheduling (s -[ inr f ]-> tr'). + { apply NNP_P. intros ?. + have ?: jmtrace_valid (s -[ inr f ]-> tr') by apply (trace_always_suffix_of _ _ _ Hsuff1) in Hval. + have ?: jm_fair_scheduling (s -[ inr f ]-> tr'). + { intros ρ. eapply (trace_always_suffix_of _ _ _ Hsuff1) in Hf. apply Hf. } + naive_solver. } + + destruct (decide _) as [Hin1|]; last first. + { destruct (decide _) as [|]; last done. + destruct (decide _) as [[??]|]; last done. lia. } + + destruct (decide _) as [[Hval1 Hfair1]|]; last done. + destruct (decide _) as [Hin2|]; last done. + destruct (decide _) as [[Hval2 Hfair2]|]; last done. + + rewrite -Nat.succ_lt_mono. + + generalize (choose_correct (λ ρ : fmrole JM, ρ ∈ live_roles JM (trfirst tr')) Hin1) as Hin1'. + intros Hin1'. + set (Hcc := choose_correct _). + generalize (Hcc Hin2). + intros Hin2'. + + set (ρ1 := choose _ _). + set (ρ2 := choose _ _). + + Notation esb := env_steps_bound_get_bound. + Notation esbg := env_steps_count_good. + + have [? _] := env_steps_count_good_correct _ _ Hval1 Hfair1 Hin1'. + have [? _] := env_steps_count_good_correct _ _ Hval2 Hfair2 Hin2'. + + eapply env_steps_count_step_gt=>//. + Qed. + + Definition upto_stutter_env := upto_stutter env_proj_st env_proj_lab. + Definition ltl_se_env := ltl_se env_proj_st env_proj_lab. + + Definition jm_usr_trans_valid (mtr : jmtrace) := + match mtr with + | ⟨s⟩ => True + | (s -[inr _]-> tr) => False + | (s -[inl l]-> tr) => lts_trans _ s.1 l (trfirst tr).1 + end. + + Definition jmtrace_usr_valid (mtr : jmtrace) := + trace_always (trace_until (trace_silent env_proj_lab) jm_usr_trans_valid) mtr. + + Proposition jm_valid_jm_usr_valid (jmtr: jmtrace) : + jm_fair_scheduling jmtr → + jmtrace_valid jmtr → + trace_is_trimmed jmtr → + jmtrace_usr_valid jmtr. + Proof. + rewrite /jmtrace_valid /jmtrace_usr_valid !trace_alwaysI. + + intros Hfair Hval. have Hval' := Hval. revert Hfair Hval. + + intros Hfair Hval Htrim jmtr' Hsuff. + + specialize (Hval _ Hsuff). + revert Hsuff Hval Htrim. + + have [n Hn] : ∃ n, n = env_steps_count_total jmtr' by naive_solver. + revert jmtr' Hn. + + induction (Nat.lt_wf_0_projected id n) as [n ? IH]. + intros jmtr' Hn Hsuff Hval Htrim. + opose proof (env_steps_dec_unless jmtr' _ _ _ 0) as Hdec. + { apply trace_alwaysI. intros ??. apply Hval'. eapply trace_suffix_of_trans=>//. } + { intros ?. eapply trace_always_suffix_of=>//. apply Hfair. } + { intros m. destruct Hsuff as [m' Hm']. specialize (Htrim (m' + m)). + rewrite after_sum' Hm' // in Htrim. } + rewrite /= in Hdec. + rewrite /jm_trans_valid in Hval. + destruct jmtr' as [js|[js1 js2] [jl|jl] jmtr']. + - constructor 1. done. + - constructor 1. simpl. destruct (trfirst jmtr') eqn:Heq. rewrite Heq. + inversion Hval; simplify_eq=>//. + - rewrite /= in Hdec. destruct Hdec as [|[Hdec Hst]]; first naive_solver. + constructor 2=>//. + apply trace_suffix_of_cons_l in Hsuff. + eapply IH=>//=. + + rewrite Hn //. + + by apply Hval'. + Qed. + + Lemma usr_project_valid (jmtr: jmtrace) (utr: lts_trace M) : + trace_is_trimmed jmtr → + jm_fair_scheduling jmtr → + jmtrace_valid jmtr → + upto_stutter_env jmtr utr → + usr_trace_valid utr. + Proof. + intros Htrim Hsched Hval%jm_valid_jm_usr_valid Hupto =>//. + rewrite /jmtrace_usr_valid /usr_trace_valid in Hval *. + rewrite !trace_alwaysI in Hval *. intros utr' Hsuff. + destruct (upto_stutter_suffix_of _ _ _ _ _ Hupto Hsuff) as (jmtr'&Hsuff'&Hupto'). + specialize (Hval _ Hsuff'). clear Htrim Hsched. + clear jmtr utr Hupto Hsuff Hsuff'. revert utr' Hupto'. + induction Hval as [jmtr Hnow|[js1 js2] jl jmtr Hlater Huntil IH]; intros utr Hupto. + - rewrite /jm_usr_trans_valid /usr_trans_valid in Hnow *. + punfold Hupto; last by apply upto_stutter_mono. + destruct jmtr as [js|[??] jl jmtr]; destruct utr as [us|us ul utr]=>//. + + inversion Hupto; simplify_eq=>//. + + destruct jl. + * inversion Hupto as [| |???????? Hupto']; simpl in *; simplify_eq=>//. + destruct (trfirst jmtr) as [js1 ?] eqn:Heq. + have ->//: trfirst utr = js1. + pclearbot. punfold Hupto'; last by apply upto_stutter_mono. + inversion Hupto'; simpl in *; simplify_eq; simpl in *; simplify_eq=>//=. + * inversion Hupto as [| |]; simpl in *; simplify_eq=>//. + - apply IH. destruct jl as [jl|jl]=>//. + punfold Hupto; last by apply upto_stutter_mono. + inversion Hupto; simplify_eq. by pfold. + Qed. + + Lemma usr_project_scheduler_fair (jmtr: jmtrace) (utr: lts_trace M) : + jm_fair_scheduling jmtr → + upto_stutter_env jmtr utr → + usr_fair_scheduling utr. + Proof. + intros Hf Hupto ρ. specialize (Hf ρ). + have Hse //: ltl_se_env (jm_fair_scheduling_mtr ρ) (usr_fair_scheduling_mtr ρ); last by eapply Hse. + apply ltl_se_always, ltl_se_impl. + - clear jmtr Hf utr Hupto. intros jtr utr Hupto. punfold Hupto; last apply upto_stutter_mono. + rewrite /trace_now /pred_at /=. destruct (trfirst jtr) eqn:Heq. + inversion Hupto; simplify_eq; simpl in *; simplify_eq=>//. + destruct utr; simpl in *; simplify_eq=>//. + - eapply (ltl_se_eventually_now_or _ _ _ _ (λ s, ρ ∉ live_roles JM s) (λ s, ρ ∉ usr_live_roles s) + (λ s l, ∃ (α : fmaction JM), l = Some $ inl (ρ, α)) + (λ s l, ∃ (α : option (action Λ)), l = Some $ (ρ, α)) + )=>//. + + intros _ [?|?] ? =>//= ?. simplify_eq. naive_solver. + + naive_solver. + + naive_solver. + + naive_solver. + Qed. +End measure. + +Arguments jm_fair_scheduling {_ _ _ _ _ _ _ _}. +Arguments jm_fair_scheduling_mtr {_ _ _ _ _ _ _ _}. +Arguments trim_trace {_ _ _ _ _ _ _ _}. +Arguments trimmed_of {_ _ _ _ _ _ _ _}. +Arguments trace_is_trimmed {_ _ _ _ _ _ _ _} _. +Arguments jmtrace_valid {_ _ _ _ _ _ _ _}. +Arguments upto_stutter_env {_ _ _ _ _ _ _ _} _ _. +Arguments ltl_se_env {_ _ _ _ _ _ _ _} _ _. + +Section trim_scheduling_fairness. + Context `{GoodLang Λ}. + Context {M: UserModel Λ}. + Context {N: EnvModel Λ}. + + Notation JM := (joint_model M N). + Notation jmlabel := (fmlabel JM). + Notation jmtrace := (trace JM jmlabel). + + Notation ltl_equiv P := (ltl_tme (S1 := JM) (L1 := jmlabel) + eq eq (λ _ _ _, True) (λ _ _ _, True) P P). + + Lemma trimming_preserves_fair_scheduling (tr : jmtrace): + jmtrace_valid tr → + jm_fair_scheduling tr → + jm_fair_scheduling (trim_trace tr). + Proof. + have: trimmed_of tr (trim_trace tr). + { apply trim_trace_trimmed_of. } + generalize (trim_trace tr). intros ttr Htrim. + + rewrite /jm_fair_scheduling /jm_fair_scheduling_mtr /trace_always_eventually_implies_now. + rewrite /trace_always_eventually_implies. intros Hval Hf ρ. + have Hfair := Hf. + specialize (Hf ρ). + rewrite trace_alwaysI. intros ttr' Hsuff. rewrite trace_impliesI. intros Hlive. + + have {}Hlive: ρ ∈ live_roles _ (trfirst ttr'). + { destruct ttr'=>//. } + + destruct (trimmed_of_suffix_of _ _ _ _ _ Htrim Hsuff) as [tr' [Hsuff' Htrim']]. + + have Hfeq: trfirst tr' = trfirst ttr'. + { punfold Htrim'. inversion Htrim'=>//. apply trimmed_of_mono. } + + rewrite trace_alwaysI in Hf. specialize (Hf _ Hsuff'). + rewrite trace_impliesI in Hf. ospecialize (Hf _). + { rewrite /trace_now /pred_at. destruct tr'; simpl; naive_solver. } + rewrite trace_eventuallyI in Hf. destruct Hf as [tr'' [Hsuff'' Hf]]. + + destruct Hsuff'' as [n Hn]. + destruct (after n ttr') as [ttr''|] eqn:Heq. + - rewrite trace_eventuallyI. exists ttr''. split; [by exists n|]. + eapply trimmed_of_after in Heq as [tr''' [Hafter Htrim'']]=>//. + have ?: tr''' = tr'' by congruence. simplify_eq. + revert Hf. rewrite /trace_now /pred_at //=. + destruct tr'', ttr''; + (punfold Htrim''; last apply trimmed_of_mono); inversion Htrim''; simplify_eq=>//. + intros _. left. + have Hsuff0: trace_suffix_of (s0 -[ ℓ ]-> tr'') tr. + { eapply trace_suffix_of_trans=>//. by exists n. } + opose proof (trace_no_roles_no_usr_inv _ _ (s0 -[ ℓ ]-> tr'') _ _ _) as Hnr. + + eapply trace_always_suffix_of=>//. + + intros ρ0. specialize (Hfair ρ0). + eapply trace_always_suffix_of=>//. + + by apply not_ex_all_not. + + simpl in Hnr. rewrite Hnr. set_solver. + - unshelve eapply (trimmed_of_None_fair _ _ _ _ _ _ _ _ Htrim') in Heq=>//. + { eapply trace_always_suffix_of=>//. } + { intros ρ0. specialize (Hfair ρ0). eapply trace_always_suffix_of=>//. } + destruct Heq as (s&n'&Hleq&Hafter&Hnl). + rewrite trace_eventuallyI. exists ⟨s⟩. split; [by exists n'|]. + rewrite /trace_now /pred_at //=. simpl in Hnl. rewrite Hnl. left. set_solver. + Qed. +End trim_scheduling_fairness. diff --git a/fairneris/examples/no_drop_dup_model.v b/fairneris/examples/no_drop_dup_model.v new file mode 100644 index 0000000..d79179d --- /dev/null +++ b/fairneris/examples/no_drop_dup_model.v @@ -0,0 +1,392 @@ +(* From trillium.prelude Require Export finitary quantifiers sigma classical_instances. *) +(* From fairneris Require Import fairness. *) +(* From Paco Require Import pacotac. *) + +(* Import derived_laws_later.bi. *) + +(* (** Initial simple Fairneris example *) *) + +(* (** The simple model states *) *) +(* Inductive simple_state := *) +(* | Start *) +(* | Sent (sent : nat) *) +(* | Delivered (sent : nat) (delivered : nat) *) +(* | Received (sent : nat) (delivered : nat). *) +(* #[global] Instance simple_state_eqdec : EqDecision simple_state. *) +(* Proof. solve_decision. Qed. *) +(* #[global] Instance simple_state_inhabited : Inhabited simple_state. *) +(* Proof. exact (populate Start). Qed. *) + +(* Inductive simple_role := A_role | B_role | Ndup | Ndrop | Ndeliver. *) +(* #[global] Instance simple_role_eqdec : EqDecision simple_role. *) +(* Proof. solve_decision. Qed. *) +(* #[global] Instance simple_role_inhabited : Inhabited simple_role. *) +(* Proof. exact (populate A_role). Qed. *) +(* #[global] Instance simple_role_countable : Countable simple_role. *) +(* Proof. *) +(* refine ({| *) +(* encode s := match s with *) +(* | A_role => 1 *) +(* | B_role => 2 *) +(* | Ndup => 3 *) +(* | Ndrop => 4 *) +(* | Ndeliver => 5 *) +(* end; *) +(* decode n := match n with *) +(* | 1 => Some A_role *) +(* | 2 => Some B_role *) +(* | 3 => Some Ndup *) +(* | 4 => Some Ndrop *) +(* | 5 => Some Ndeliver *) +(* | _ => None *) +(* end; *) +(* |})%positive. *) +(* by intros []. *) +(* Qed. *) + +(* Inductive simple_trans *) +(* : simple_state → simple_role → simple_state → Prop := *) +(* (* Transitions from Start *) *) +(* | Start_B_recv_fail_simple_trans : simple_trans Start B_role Start *) +(* | Start_A_send_simple_trans : simple_trans Start A_role (Sent 1) *) +(* (* Transitions from Sent *) *) +(* | Sent_B_recv_fail_simple_trans n : simple_trans (Sent n) B_role (Sent n) *) +(* | Sent_N_duplicate_simple_trans n : simple_trans (Sent $ S n) Ndup (Sent $ S $ S n) *) +(* | Sent_N_drop_simple_trans n : simple_trans (Sent $ S n) Ndrop (Sent n) *) +(* | Sent_N_deliver_simple_trans n : simple_trans (Sent $ S n) Ndeliver (Delivered n 0) *) +(* (* Transitions from Delivered *) *) +(* | Delivered_N_duplicate_simple_trans n m : simple_trans (Delivered (S n) m) Ndup (Delivered (S $ S n) m) *) +(* | Delivered_N_drop_simple_trans n m : simple_trans (Delivered (S n) m) Ndrop (Delivered n m) *) +(* | Delivered_N_deliver_simple_trans n m : simple_trans (Delivered (S n) m) Ndeliver (Delivered n (S m)) *) +(* | Delivered_B_recv_succ_simple_trans n m : simple_trans (Delivered n m) B_role (Received n m) *) +(* (* Transitions from Received - Are these needed? *) *) +(* | Received_N_duplicate_simple_trans n m : simple_trans (Received (S n) m) Ndup (Received (S $ S n) m) *) +(* | Received_N_drop_simple_trans n m : simple_trans (Received (S n) m) Ndrop (Received n m) *) +(* | Received_N_deliver_simple_trans n m : simple_trans (Received (S n) m) Ndeliver (Received n (S m)) *) +(* . *) + +(* Definition simple_live_roles (s : simple_state) : gset simple_role := *) +(* match s with *) +(* | Start => {[A_role;B_role]} *) +(* | Sent 0 => {[B_role]} *) +(* | Sent n => {[B_role;Ndup;Ndrop;Ndeliver]} *) +(* (* Should Ndeliver etc. be live in Sent 0? *) *) +(* | Delivered 0 m => {[B_role]} *) +(* | Delivered n m => {[B_role;Ndup;Ndrop;Ndeliver]} *) +(* (* Is the network live in the last state? *) *) +(* | Received 0 m => ∅ *) +(* | Received n m => {[Ndup;Ndrop;Ndeliver]} *) +(* end. *) + +(* Lemma simple_live_spec_holds s ρ s' : *) +(* simple_trans s ρ s' -> ρ ∈ simple_live_roles s. *) +(* Proof. destruct s; inversion 1; try set_solver; destruct sent; set_solver. Qed. *) + +(* Definition fair_network_mtr (mtr : trace simple_state simple_role) := *) +(* ∀ n, pred_at mtr n (λ _ ℓ, ℓ ≠ Some Ndup ∧ ℓ ≠ Some Ndrop). *) + +(* Lemma fair_network_mtr_after mtr mtr' k : *) +(* after k mtr = Some mtr' → *) +(* fair_network_mtr mtr → *) +(* fair_network_mtr mtr'. *) +(* Proof. *) +(* rewrite /fair_network_mtr. *) +(* intros Hafter Hfair. *) +(* intros n. *) +(* specialize (Hfair (k+n)). *) +(* rewrite pred_at_sum in Hfair. *) +(* rewrite Hafter in Hfair. *) +(* done. *) +(* Qed. *) + +(* Definition simple_fair_model : FairModel. *) +(* Proof. *) +(* refine({| *) +(* fmstate := simple_state; *) +(* fmrole := simple_role; *) +(* fmtrans := simple_trans; *) +(* fmfairness := fair_network_mtr; *) +(* fmfairness_preserved := fair_network_mtr_after; *) +(* live_roles := simple_live_roles; *) +(* fm_live_spec := simple_live_spec_holds; *) +(* |}). *) +(* Defined. *) + +(* (** Fair Model construction (currently does not work, as the config roles *) +(* do not terminate) *) *) + +(* Definition state_to_nat (s : simple_state) : nat := *) +(* match s with *) +(* | Start => 3 *) +(* | Sent _ => 2 *) +(* | Delivered _ _ => 1 *) +(* | Received _ _ => 0 *) +(* end. *) + +(* Definition simple_state_order (s1 s2 : simple_state) : Prop := *) +(* state_to_nat s1 ≤ state_to_nat s2. *) + +(* Local Instance simple_state_order_preorder : PreOrder simple_state_order. *) +(* Proof. *) +(* split. *) +(* - by intros []; constructor. *) +(* - intros [] [] []; rewrite /simple_state_order. *) +(* all: intros Hc12 Hc23; try by inversion Hc12. *) +(* all: rewrite /simple_state_order; try lia. *) +(* Qed. *) + +(* Definition simple_decreasing_role (s : fmstate simple_fair_model) : *) +(* fmrole simple_fair_model := *) +(* match s with *) +(* | Start => A_role *) +(* | Sent _ => Ndeliver *) +(* | Delivered _ _ => B_role *) +(* | Received _ _ => Ndup (* Why is this needed? *) *) +(* end. *) + +(* (** Included redefinition of FairTerminatingModel here for now *) *) +(* Class FairTerminatingModel (Mdl: FairModel) := { *) +(* ftm_leq: relation (Mdl.(fmstate)); *) +(* ftm_order: PreOrder ftm_leq; *) +(* ftm_wf: wf (strict ftm_leq); *) + +(* ftm_decreasing_role: fmstate Mdl → fmrole Mdl; *) +(* ftm_reachable_state: fmstate Mdl → Prop; *) + +(* ftm_reachable: ∀ mtr, pred_at mtr 0 (λ ρ _, ftm_reachable_state ρ) → *) +(* mtrace_valid mtr → mtrace_fair mtr → *) +(* ∀ n, pred_at mtr n (λ _ _, True) → *) +(* pred_at mtr n (λ δ _, ftm_reachable_state δ); *) +(* ftm_decr: *) +(* ∀ (s: fmstate Mdl), ftm_reachable_state s → *) +(* (∃ ρ' s', fmtrans _ s ρ' s') → *) +(* ftm_decreasing_role s ∈ live_roles _ s ∧ *) +(* ∀ s', (fmtrans _ s (ftm_decreasing_role s) s' → *) +(* (strict ftm_leq) s' s); *) +(* ftm_decreasing_role_preserved: *) +(* ∀ (s s': fmstate Mdl) ρ', *) +(* ftm_reachable_state s → *) +(* fmtrans _ s ρ' s' → ρ' ≠ ftm_decreasing_role s → *) +(* ftm_decreasing_role s = ftm_decreasing_role s'; *) +(* ftm_notinc: *) +(* ∀ (s: fmstate Mdl) ρ s', ftm_reachable_state s → fmtrans _ s ρ s' → ftm_leq s' s; *) +(* }. *) + +(* Arguments ftm_leq {_ _}. *) +(* Arguments ftm_wf {_ _}. *) +(* Arguments ftm_reachable_state {_ _}. *) +(* Arguments ftm_reachable {_ _}. *) +(* Arguments ftm_decr {_ _}. *) +(* Arguments ftm_decreasing_role {_ _}. *) + +(* #[global] Existing Instance ftm_order. *) + +(* Notation ftm_lt := (strict ftm_leq). *) +(* Local Infix "<" := ftm_lt. *) +(* Local Infix "≤" := ftm_leq. *) + +(* Lemma ftm_trans' `{FairTerminatingModel Mdl} a b c: *) +(* a < b → b ≤ c → a < c. *) +(* Proof. *) +(* intros [H1 H1'] H2. *) +(* (* TODO: Why do we need to extract this manually? *) *) +(* (* assert (EqDecision Mdl) by apply Mdl.(fmstate_eqdec). *) *) +(* destruct (decide (b = c)) as [->|Heq]; [done|]. *) +(* split; [by etransitivity|]. *) +(* intros H'. apply H1'. *) +(* by etransitivity. *) +(* Qed. *) + +(* Definition initial_reachable `{FairTerminatingModel M} (mtr : mtrace M) := *) +(* pred_at mtr 0 (λ ρ _, ftm_reachable_state ρ). *) + +(* Lemma fair_terminating_traces_terminate_rec `{FairTerminatingModel Mdl} *) +(* (s0: fmstate Mdl) (mtr: mtrace Mdl): *) +(* (trfirst mtr) ≤ s0 → *) +(* initial_reachable mtr → *) +(* mtrace_valid mtr → *) +(* mtrace_fair mtr → *) +(* terminating_trace mtr. *) +(* Proof. *) +(* revert mtr. induction s0 as [s0 IH] using (well_founded_ind ftm_wf). *) +(* intros mtr Hleq Hinit Hval Hfair. *) +(* pose proof (ftm_reachable mtr Hinit Hval Hfair) as Hexcl. *) +(* destruct mtr as [|s ℓ mtr'] eqn:Heq; first by eexists 1. *) +(* destruct (ftm_decr (trfirst mtr)) as (Hlive & Htrdec). *) +(* { pose proof (Hexcl 0) as Hexcl0%pred_at_0; [|done]. by simplify_eq. } *) +(* { exists ℓ, (trfirst mtr'). punfold Hval. inversion Hval; subst; done. } *) +(* rewrite <- Heq in *. clear s ℓ Heq. *) +(* pose proof Hfair as [Hfair_scheduling _]. *) +(* destruct (Hfair_scheduling (ftm_decreasing_role (trfirst mtr)) 0) as [n Hev]; *) +(* first by rewrite /pred_at /=; destruct mtr. *) +(* clear Hfair_scheduling. *) +(* revert mtr Hexcl Hinit Hval Hleq Hfair Hlive IH Hev Htrdec. induction n as [| n IHn]; *) +(* intros mtr Hexcl Hinit Hval Hleq Hfair Hlive IH Hev Htrdec. *) +(* - simpl in *. rewrite pred_at_or in Hev. rewrite /pred_at /= in Hev. *) +(* destruct Hev as [Hev|Hev]; first by destruct mtr; done. *) +(* destruct mtr; first done. injection Hev => ->. *) +(* apply terminating_trace_cons. *) +(* eapply IH =>//; eauto. *) +(* + eapply ftm_trans' =>//. apply Htrdec. *) +(* punfold Hval. inversion Hval; simplify_eq; simpl in *; simplify_eq; done. *) +(* + apply (Hexcl 1). apply pred_at_S. by destruct mtr. *) +(* + punfold Hval. inversion Hval; simplify_eq. *) +(* destruct H4; done. *) +(* + destruct Hfair as [Hscheduling Hfair]. *) +(* split. *) +(* * intros ρ. by eapply fair_scheduling_mtr_cons. *) +(* * eapply (fmfairness_preserved _ _ _ 1); [|apply Hfair]. done. *) +(* - simpl in *. destruct mtr; first (exists 1; done). *) +(* rewrite -> !pred_at_S in Hev. *) +(* punfold Hval; inversion Hval as [|??? Htrans Hval']; simplify_eq. *) +(* destruct Hval' as [Hval'|]; last done. *) +(* destruct (decide (ℓ = ftm_decreasing_role s)) as [-> | Hnoteq]. *) +(* + apply terminating_trace_cons. eapply IH=>//; eauto. *) +(* eapply ftm_trans' =>//; apply Htrdec. simpl. destruct Hval; done. *) +(* * apply (Hexcl 1). apply pred_at_S. by destruct mtr. *) +(* * destruct Hfair as [Hscheduling Hfair]. *) +(* split. *) +(* -- intros ρ. by eapply fair_scheduling_mtr_cons. *) +(* -- eapply (fmfairness_preserved _ _ _ 1); [|apply Hfair]. done. *) +(* + destruct mtr as [|s' ℓ' mtr''] eqn:Heq; first by eexists 2. *) +(* destruct (ftm_decr (trfirst mtr)) as (Hlive' & Htrdec'). *) +(* { pose proof (Hexcl 1) as Hexcl0%pred_at_0; [|done]. by simplify_eq. } *) +(* { exists ℓ', (trfirst mtr''). punfold Hval'; inversion Hval'; subst; done. } *) +(* apply terminating_trace_cons. eapply IHn=>//; eauto. *) +(* * apply ftm_reachable; [|apply Hval'|]. *) +(* -- apply (Hexcl 1). apply pred_at_S, pred_at_0. done. *) +(* -- split. *) +(* ++ intros ρ. eapply (fair_scheduling_mtr_after _ _ _ 1); [|apply Hfair]. done. *) +(* ++ eapply (fmfairness_preserved _ _ _ 1); [|apply Hfair]. done. *) +(* * apply (Hexcl 1). apply pred_at_S, pred_at_0. done. *) +(* * etransitivity; eauto. eapply ftm_notinc =>//. *) +(* * destruct Hfair as [Hscheduling Hfair]. *) +(* split. *) +(* -- intros ρ. by eapply fair_scheduling_mtr_cons. *) +(* -- eapply (fmfairness_preserved _ _ _ 1); [|apply Hfair]. done. *) +(* * simplify_eq. eapply Hlive'. *) +(* * erewrite <- ftm_decreasing_role_preserved =>//. *) +(* * intros s'' Htrans''. eapply ftm_decr; eauto. *) +(* by pose proof (Hexcl 1) as Hexcl0%pred_at_0. *) +(* Qed. *) + +(* Definition mtrace_fairly_terminating (mtr : mtrace simple_fair_model) := *) +(* mtrace_valid mtr → *) +(* mtrace_fair mtr → *) +(* (* This needs to be strengthened to consider config steps *) *) +(* terminating_trace mtr. *) + +(* Theorem fair_terminating_traces_terminate `{FairTerminatingModel simple_fair_model} : *) +(* ∀ (mtrace : @mtrace simple_fair_model), *) +(* initial_reachable mtrace → *) +(* mtrace_fairly_terminating mtrace. *) +(* Proof. intros ???[??]. eapply fair_terminating_traces_terminate_rec=>//. Qed. *) + +(* Definition simple_reachable_state s := *) +(* match s with *) +(* | Sent 1 => True *) +(* | Sent _ => False *) +(* | Delivered 0 0 => True *) +(* | Delivered _ _ => False *) +(* | Received 0 0 => True *) +(* | Received _ _ => False *) +(* | _ => True *) +(* end. *) + +(* Lemma mtrace_valid_after `{M : FairModel} (mtr mtr' : mtrace M) k : *) +(* after k mtr = Some mtr' → mtrace_valid mtr → mtrace_valid mtr'. *) +(* Proof. *) +(* revert mtr mtr'. *) +(* induction k; intros mtr mtr' Hafter Hvalid. *) +(* { destruct mtr'; simpl in *; by simplify_eq. } *) +(* punfold Hvalid. *) +(* inversion Hvalid as [|??? Htrans Hval']; simplify_eq. *) +(* eapply IHk; [done|]. *) +(* by inversion Hval'. *) +(* Qed. *) + +(* Program Instance simple_model_terminates : *) +(* FairTerminatingModel simple_fair_model := *) +(* {| *) +(* ftm_leq := simple_state_order; *) +(* ftm_decreasing_role := simple_decreasing_role; *) +(* ftm_reachable_state := simple_reachable_state; *) +(* |}. *) +(* Next Obligation. *) +(* rewrite /simple_state_order. *) +(* intros []; repeat (constructor; intros [] []; simpl in *; try lia). *) +(* Qed. *) +(* Next Obligation. *) +(* intros mtr Hinit Hvalid [Hscheduling Hfair] n Hlen. *) +(* rewrite /pred_at in Hlen. rewrite /pred_at. *) +(* induction n; [done|]. *) +(* destruct mtr; [done|]. *) +(* assert (match after n (s -[ ℓ ]-> mtr) with *) +(* | None => False *) +(* | _ => True *) +(* end) as Hn. *) +(* { clear IHn. clear Hinit Hvalid Hscheduling Hfair. revert s mtr ℓ Hlen. *) +(* induction n; [done|]; intros s mtr ℓ Hlen. *) +(* simpl in *. destruct mtr; [done|]. *) +(* simpl in *. apply IHn. done. } *) +(* assert (match after n (s -[ ℓ ]-> mtr) with *) +(* | Some ⟨ s ⟩ | Some (s -[ _ ]-> _) => simple_reachable_state s *) +(* | None => False *) +(* end) as IHn'. *) +(* { apply IHn. destruct (after n (s -[ ℓ ]-> mtr)); [|done]. destruct t; done. } *) +(* clear Hn IHn. *) +(* replace (S n) with (1 + n) by lia. *) +(* replace (S n) with (1 + n) in Hlen by lia. *) +(* rewrite after_sum. *) +(* rewrite after_sum in Hlen. *) +(* destruct (after n (s -[ ℓ ]-> mtr)) as [mtr'|] eqn:Heq; [|done]. *) +(* destruct mtr' as [mtr''|mtr'' ℓ' mtr''']; [done|]. *) +(* simpl in *. *) +(* assert (simple_trans mtr'' ℓ' (trfirst mtr''')). *) +(* { assert (mtrace_valid ((mtr'' -[ℓ']-> mtr'''):mtrace simple_fair_model)) as Hvalid'. *) +(* { by eapply mtrace_valid_after. } *) +(* punfold Hvalid'. *) +(* inversion Hvalid'. *) +(* simplify_eq. *) +(* apply H1. } *) +(* assert (fair_network_mtr ((mtr'' -[ℓ']-> mtr'''):mtrace simple_fair_model)) as *) +(* Hfair'. *) +(* { by eapply fair_network_mtr_after. } *) +(* inversion H; simplify_eq; try by inversion Hinit. *) +(* - rewrite /trfirst in H3. destruct mtr'''; by rewrite -H3. *) +(* - rewrite /trfirst in H3. destruct mtr'''; by rewrite -H3. *) +(* - rewrite /trfirst in H3. destruct mtr'''; by rewrite -H3. *) +(* - rewrite /fair_network_mtr in Hfair. *) +(* specialize (Hfair' 0). by destruct Hfair' as [Hfair' ?]. *) +(* - rewrite /fair_network_mtr in Hfair. *) +(* specialize (Hfair' 0). by destruct Hfair' as [Hfair' ?]. *) +(* - rewrite /trfirst in H3. destruct mtr'''; by rewrite -H3. *) +(* - rewrite /trfirst in H3. destruct mtr'''; by rewrite -H3. *) +(* - rewrite /fair_network_mtr in Hfair. *) +(* specialize (Hfair' 0). by destruct Hfair' as [Hfair' ?]. *) +(* - rewrite /trfirst in H3. destruct mtr'''; by rewrite -H3. *) +(* - rewrite /trfirst in H3. destruct mtr'''; by rewrite -H3. *) +(* - rewrite /trfirst in H3. destruct mtr'''; by rewrite -H3. *) +(* - rewrite /trfirst in H3. destruct mtr'''; by rewrite -H3. *) +(* - rewrite /trfirst in H3. destruct mtr'''; by rewrite -H3. *) +(* Qed. *) +(* Next Obligation. *) +(* rewrite /simple_state_order. *) +(* intros s Hexcl [ρ' [s' Htrans]]=> /=. *) +(* split. *) +(* - destruct s; try set_solver; destruct sent; try set_solver. *) +(* simpl in *. destruct delivered; try set_solver. inversion Htrans. *) +(* - intros s'' Htrans'. simpl in *. *) +(* destruct s. *) +(* + inversion Htrans'. split; simpl; lia. *) +(* + inversion Htrans'. split; simpl; lia. *) +(* + inversion Htrans'. split; simpl; lia. *) +(* + inversion Htrans'. simplify_eq. simpl in *. done. *) +(* Qed. *) +(* Next Obligation. *) +(* intros s s' ρ Hreachable Htrans Hρ. by destruct s; inversion Htrans. *) +(* Qed. *) +(* Next Obligation. *) +(* rewrite /simple_state_order. *) +(* intros s1 ρ s2 Hreachable Htrans. destruct s1; inversion Htrans; simpl; lia. *) +(* Qed. *) diff --git a/fairneris/examples/retransmit_example.v b/fairneris/examples/retransmit_example.v new file mode 100644 index 0000000..5579061 --- /dev/null +++ b/fairneris/examples/retransmit_example.v @@ -0,0 +1,211 @@ +From stdpp Require Import list fin_maps. +From iris.proofmode Require Import proofmode. +From trillium.program_logic Require Import ectx_lifting. +From fairneris Require Import fairness fair_resources fuel. +From fairneris.examples Require Import retransmit_model. +From fairneris.aneris_lang Require Import aneris_lang. +From fairneris.aneris_lang.state_interp Require Import state_interp state_interp_events. +From fairneris.aneris_lang.program_logic Require Import aneris_weakestpre. + +Definition Aprog shA : expr := SendToRepeat #(LitSocket shA) #"Hello" #saB. +Definition Bprog shB : expr := ReceiveFrom #(LitSocket shB). + +Definition model_state_socket_coh + (skts : gmap ip_address sockets) + (bs : gmap socket_address (list message)) := + ∀ ip Sn sh skt sa ms, + skts !! ip = Some Sn → Sn !! sh = Some (skt,ms) → + saddress skt = Some sa → + bs !!! sa = ms. + +Definition config_state_valid (c : cfg aneris_lang) (δ : retransmit_state) := + state_ms c.2 = δ.1.2 ∧ model_state_socket_coh (state_sockets c.2) δ.2. + +Program Definition retransmit_live_model : LiveModel aneris_lang retransmit_fair_model := + {| + lm_cfg_action m1 lab := (((), lab), m1); + lm_cfg_labels_match cl fl := cl = fl.2; + |}. +Next Obligation. Admitted. +Next Obligation. Admitted. +Next Obligation. Admitted. + +Section with_Σ. + Context `{anerisG _ retransmit_live_model Σ}. + + Notation loA := (ip_of_address saA,tidA). + + Lemma wp_A s E shA : + {{{ shA ↪[ip_of_address saA] sA ∗ saA ⤳ (∅,∅) ∗ saB ⤇ (λ _, True) ∗ loA ↦M {[ Arole := 1%nat ]} }}} + (mkExpr (ip_of_address saA) (Aprog shA)) @ s; loA; E + {{{ v, RET v; loA ↦M ∅ }}}. + Proof. + iIntros (Φ) "(Hsh & Hrt & #Hmsg & HA) HΦ". + iAssert (∃ R T, saA ⤳ (R, T) ∗ + [∗ set] m ∈ R, socket_address_group_own {[m_sender m]})%I + with "[Hrt]" as (R T) "[HRT HR]"; [by eauto|]. + iLöb as "IH" forall (R T). + iApply wp_lift_head_step_fupd; [done|]. + iIntros (ex atr K tp1 tp2 σ Hexvalid Hex Hlocale) + "(%Hvalid & Hσ & [Hlive_auth Hlive_owns] & Hauth) /=". + iMod (steps_auth_update_S with "Hauth") as "Hauth". + rewrite (last_eq_trace_ends_in _ _ Hex). + iDestruct (aneris_state_interp_socket_valid with "Hσ Hsh") + as (Sn r) "[%HSn (%Hr & %Hreset)]". + iApply fupd_mask_intro; [set_solver|]. iIntros "Hclose". + iSplitR. + { iPureIntro; do 4 eexists. eapply SocketStepS; eauto. by econstructor. } + iIntros (α ? ? ? Hstep). simpl in *. iModIntro. inv_head_step; iNext. + rewrite (insert_id (state_sockets σ)); last done. + iAssert (socket_address_group_own {[saA]})%I as "#HsaA". + { iDestruct "HRT" as "[(%send & %recv & _ & _ & _ & $ & _) _]". } + iAssert (socket_address_group_own {[saB]})%I as "#HsaB". + { by iDestruct "Hmsg" as (γ) "[H _]". } + iMod (aneris_state_interp_send shA saA {[saA]} saB {[saB]} _ _ sA _ _ _ _ _ + "Hello" + with "[$HsaA] [$HsaB] [$Hsh] [HRT] [$Hmsg] [] [$Hσ]") + as "(%Hmhe & Hσ & Hsh & HRT)"; + [try set_solver..|]. + { apply message_group_equiv_refl; set_solver. } + { iDestruct "HRT" as "[$ _]". } + { by rewrite /from_singleton; eauto. } + iDestruct (live_role_auth_elem_of with "Hlive_auth HA") as %Hrole. + destruct (trace_last atr) as [[st ms] bs] eqn:Heqn. + iExists (st,ms ⊎ {[ (mkMessage saA saB "Hello") ]},bs), + (inl (Arole,Some (mkMessage saA saB "Hello"))). + iMod "Hclose". rewrite -Hmhe. iFrame=> /=. + iSplitR; last first. + { iDestruct "HR" as "#HR". + iApply ("IH" with "Hsh HA HΦ [HRT]"); [by iSplitL|done]. } + iPureIntro. + rewrite /simple_valid_state_evolution in Hvalid. + rewrite /simple_valid_state_evolution=> /=. + destruct Hvalid as (Hsteps & Hmatch & Hlive & Hms & Hskt). + rewrite /trace_ends_in in Hex. + rewrite Hex in Hms. simpl in Hms. rewrite Hms. + split; [econstructor; [done|econstructor|done]|]. + split; [done|]. + split. + { intros ℓ ζ Hlabels Henabled=> /=. rewrite right_id_L. + rewrite Hex in Hlive. eapply Hlive; [done|by rewrite Heqn]. } + split; last first. + { simpl. rewrite Hex in Hskt. simpl in *. by rewrite Heqn in Hskt. } + simpl. rewrite Heqn in Hms. simpl in *. + rewrite Heqn. simpl. multiset_solver. + Qed. + + Lemma wp_B s E shB : + {{{ shB ↪[ip_of_address saB] sB ∗ saB ⤳ (∅,∅) ∗ saB ⤇ (λ _, True) ∗ + live_role_frag_own Brole }}} + (mkExpr (ip_of_address saB) (Bprog shB)) @ s; (ip_of_address saB, tidB); E + {{{ v, RET v; dead_role_frag_own Brole }}}. + Proof. + iIntros (Φ) "(Hsh & Hrt & #HΨ & HB) HΦ". + iLöb as "IH". + iApply wp_lift_head_step; auto. + iIntros (ex atr K tp1 tp2 σ Hexvalid Hex) "(%Hvalid & Hσ & [Hlive_auth Hdead_auth] & Hauth) /=". + iMod (steps_auth_update_S with "Hauth") as "Hauth". + rewrite (last_eq_trace_ends_in _ _ Hex). + iDestruct (aneris_state_interp_network_sockets_coh_valid with "Hσ") as %Hcoh. + iDestruct (aneris_state_interp_socket_valid with "Hσ Hsh") + as (Sn r) "[%HSn (%Hr & %Hreset)]". + iDestruct (live_role_auth_elem_of with "Hlive_auth HB") as %Hrole. + destruct (trace_last atr) as [[[] ms] bs] eqn:Heqn; last first. + { rewrite Heqn in Hrole. set_solver. } + simpl in *. + destruct Hvalid as (Hsteps & Hmatch & Hlive & [Hms Hskts]). + rewrite Hex in Hskts. rewrite Heqn in Hskts. + simpl in *. + subst. + assert (bs !!! saB = r) as Hbs. + { by eapply Hskts. } + destruct (decide (r = [])) as [-> | Hneq]. + - iMod (fupd_mask_intro_subseteq _ ∅ True%I with "[]") as "Hmk"; + first set_solver; auto. + iModIntro. iSplitR. + { by iPureIntro; do 4 eexists; eapply SocketStepS; eauto; econstructor. } + iIntros (v2' ? ? ? Hstep). + inv_head_step. + { assert (length (r ++ [m]) = length ([] : list message)) + as Hdone; [by f_equal|]. + rewrite app_length /= in Hdone. lia. } + rewrite (insert_id (state_sockets σ)); last done. + iNext. + iMod "Hmk" as "_". + iModIntro. + iExists (retransmit_model.Start, ms, bs), (inl (Brole, None)). + rewrite -message_history_evolution_id. + rewrite Heqn. + iFrame. + iSplitR; last first. + { iSplitL; [|done]. by iApply ("IH" with "Hsh Hrt HB HΦ"). } + iPureIntro. + rewrite /trace_ends_in in Hex. + rewrite /trace_ends_in in Hex. + split; [econstructor;[done|by econstructor|done]|]. + rewrite Hex in Hms. rewrite Heqn in Hms. + split; [done|]. + split; [|done]. + intros ℓ ζ Hlabels Henabled. + rewrite right_id_L. + rewrite Hex in Hlive. eapply Hlive; [done|by rewrite Heqn]. + - iMod (fupd_mask_intro_subseteq _ ∅ True%I with "[]") as "Hmk"; + first set_solver; auto. + iModIntro. iSplitR. + { iPureIntro. apply last_is_Some in Hneq as [m Hneq]. + apply last_Some in Hneq as [? ->]. + do 4 eexists; eapply SocketStepS; eauto; econstructor; eauto 2. } + iIntros (v2' ? ? ? Hstep). + inv_head_step. + iNext. + iMod "Hmk" as "_". + iAssert (socket_address_group_own {[saB]})%I as "#HsaB". + { iDestruct "Hrt" as "[(%send & %recv & _ & _ & _ & $ & _) _]". } + rewrite -H1 in Hr. + iPoseProof (aneris_state_interp_receive_some saB {[saB]} _ _ _ _ (Some _) + with "[] [$HΨ] [$Hσ] [$Hsh] [Hrt]") + as (R' sagT) "(%HinT & #HownT & %Hhist & %HR & Hrt & Hrest)"; + [by set_solver..| | |]. + { iFrame "#". iPureIntro. set_solver. } + { iDestruct "Hrt" as "[$ Hrt]". } + iMod "Hrest" as "(Hσ & Hsh & Ha)". + iMod (live_roles_auth_delete with "Hlive_auth HB") as "Hlive_auth". + iMod (dead_role_auth_extend _ (Brole : fmrole retransmit_fair_model) with "Hdead_auth") + as "[Hdead_auth Hdead_own]"; [by set_solver|]. + iModIntro. + iExists (retransmit_model.Received, ms, <[saB:=r]>bs), + (inl (Brole, None)). + rewrite Heqn Hhist=> /=. + rewrite /thread_live_roles_interp /retransmit_live_roles. simpl in *. + replace ({[Arole; Brole]} ∖ {[Brole]}) with ({[Arole]} : gset _) + by set_solver. + replace({[Brole]} ∪ all_roles ∖ {[Arole; Brole]}) with + (all_roles ∖ {[Arole]} : gset _) by set_solver. + rewrite !right_id_L. + iFrame "Hauth Hlive_auth Hdead_auth Hσ". + iSplitR "HΦ Hdead_own"; last first. + { iSplit; [|done]. iApply wp_value. by iApply "HΦ". } + iPureIntro. + split; [econstructor;[done|by econstructor|done]|]. + rewrite Hex in Hms. rewrite Heqn in Hms. + split; [done|]. + split; last first. + { split; [done|]. by eapply state_buffers_delete. } + intros ℓ ζ Hlabels Henabled. + rewrite Hex in Hlive. rewrite Heqn in Hlive. simpl. + assert (ℓ = Arole). + { rewrite /role_enabled_model in Henabled. simpl in *. + rewrite /retransmit_live_roles in Henabled. simpl in *. + set_solver. } + simplify_eq. + eapply from_locale_step; last first. + { eapply Hlive; [done|]. + rewrite /role_enabled_model. + set_solver. } + eapply locale_step_atomic; eauto. + { f_equiv; [|done]. + f_equiv. f_equiv. symmetry. apply app_nil_r. } + repeat econstructor; set_solver. + Qed. + +End with_Σ. diff --git a/fairneris/examples/retransmit_example_adequacy.v b/fairneris/examples/retransmit_example_adequacy.v new file mode 100644 index 0000000..93f9bbd --- /dev/null +++ b/fairneris/examples/retransmit_example_adequacy.v @@ -0,0 +1,194 @@ +From stdpp Require Import list fin_maps. +From iris.proofmode Require Import proofmode. +From trillium.program_logic Require Import ectx_lifting. +From fairneris Require Import fairness. +From fairneris.examples Require Import retransmit_model. +From fairneris.aneris_lang Require Import aneris_lang. +From fairneris.aneris_lang.state_interp Require Import state_interp state_interp_events. +From fairneris.aneris_lang.program_logic Require Import aneris_weakestpre. +From fairneris.aneris_lang Require Import aneris_lang adequacy. +From fairneris Require Import retransmit_example. + +From fairneris.lib Require Import singletons. + +Definition initial_state shA shB := + ([mkExpr ipA (Aprog shA); mkExpr ipB (Bprog shB)], + {| state_heaps := {[ipA:=∅; ipB:=∅]}; + state_sockets := {[ipA := {[shA := (sA, [])]}; + ipB := {[shB := (sB, [])]}]}; + state_ms := ∅; |}). + +Definition initial_model_state : retransmit_state := + (retransmit_model.Start, ∅, ∅). + +Lemma retransmit_continued_simulation shA shB : + fairly_terminating localeB (initial_state shA shB). +Proof. + assert (anerisPreG retransmit_fair_model (anerisΣ retransmit_fair_model)) as HPreG. + { apply _. } + eapply (simulation_adequacy_fair_termination_multiple {[saA;saB]} NotStuck _ _ initial_model_state); + [| |simpl; lia|set_solver|..|done|]=> /=. + { intros ℓ ζ Hmatch Henabled. rewrite /role_enabled_model in Henabled. simpl. + assert (ℓ = Arole ∨ ℓ = Brole) as [Heq|Heq] by set_solver; simplify_eq. + - assert (ζ = ("0.0.0.0", 0%nat)) as ->. + { rewrite /roles_match /locale_retransmit_role in Hmatch. + by repeat case_match; simplify_eq. } + eexists _. simpl. done. + - assert (ζ = ("0.0.0.1", 0%nat)) as ->. + { rewrite /roles_match /locale_retransmit_role in Hmatch. + by repeat case_match; simplify_eq. } + eexists _. simpl. done. } + { rewrite /config_state_valid. simpl. split; [done|]. + rewrite /model_state_socket_coh. + intros. + (* OBS: Might be able to make this simpler with a total lookup *) + rewrite insert_union_singleton_l in H. + apply lookup_union_Some in H; [|apply map_disjoint_dom; set_solver]. + destruct H as [H|H]. + - destruct (decide (ip = ipA)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in H. } + rewrite lookup_insert in H. + simplify_eq. + destruct (decide (sh = shA)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in H0. } + rewrite lookup_insert in H0. + simplify_eq. + assert (sa = saA) as -> by set_solver. + set_solver. + - destruct (decide (ip = ipB)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in H. } + rewrite lookup_insert in H. + simplify_eq. + destruct (decide (sh = shB)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in H0. } + rewrite lookup_insert in H0. + simplify_eq. + assert (sa = saB) as -> by set_solver. + set_solver. } + { intros ip ps HPs Sn Hip p Hps. + intros sh skt a r Hsh Hskt. + intros <-. + assert (ports_in_use {[ipA := {[shA := (sA, [])]}; ipB := {[shB := (sB, [])]}]} = {[saA; saB]}) as Heq. + { rewrite /ports_in_use. + rewrite map_fold_insert_L; [by rewrite !map_fold_singleton| |set_solver]. + intros j1 j2 z1 z2 y Hneq Hz1 Hz2. + rewrite insert_union_singleton_l in Hz1. + apply lookup_union_Some in Hz1; last first. + { apply map_disjoint_dom. clear. set_solver. } + rewrite insert_union_singleton_l in Hz2. + apply lookup_union_Some in Hz2; last first. + { apply map_disjoint_dom. clear. set_solver. } + destruct Hz1 as [Hz1|Hz1], Hz2 as [Hz2|Hz2]. + - apply lookup_singleton_Some in Hz1 as [<- <-]. + apply lookup_singleton_Some in Hz2 as [<- <-]. + done. + - apply lookup_singleton_Some in Hz1 as [<- <-]. + apply lookup_singleton_Some in Hz2 as [<- <-]. + rewrite !map_fold_singleton=> /=. + clear. rewrite !union_empty_r_L !union_assoc_L. set_solver. + - apply lookup_singleton_Some in Hz1 as [<- <-]. + apply lookup_singleton_Some in Hz2 as [<- <-]. + rewrite !map_fold_singleton=> /=. + clear. rewrite !union_empty_r_L !union_assoc_L. set_solver. + - apply lookup_singleton_Some in Hz1 as [<- <-]. + apply lookup_singleton_Some in Hz2 as [<- <-]. + rewrite !map_fold_singleton=> /=. + clear. rewrite !union_empty_r_L !union_assoc_L. set_solver. } + rewrite Heq in HPs. clear Heq. + rewrite difference_diag_L in HPs. done. } + { intros ip Sn Hip. + intros sh [skt bs] Hsh. + rewrite insert_union_singleton_l in Hip. + apply lookup_union_Some in Hip; [|apply map_disjoint_dom; set_solver]. + destruct Hip as [Hip|Hip]. + - destruct (decide (ip = ipA)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hip. } + rewrite lookup_insert in Hip. + simplify_eq. + destruct (decide (sh = shA)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hsh. } + rewrite lookup_insert in Hsh. + simplify_eq. done. + - destruct (decide (ip = ipB)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hip. } + rewrite lookup_insert in Hip. + simplify_eq. + destruct (decide (sh = shB)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hsh. } + rewrite lookup_insert in Hsh. + simplify_eq. done. } + { intros ip Sn Hip sh sh' skt skt' bs bs' Hsh Hsh' Hskt Heq. + rewrite insert_union_singleton_l in Hip. + apply lookup_union_Some in Hip; [|apply map_disjoint_dom; set_solver]. + destruct Hip as [Hip|Hip]. + - destruct (decide (ip = ipA)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hip. } + rewrite lookup_insert in Hip. + simplify_eq. + destruct (decide (sh = shA)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hsh. } + rewrite lookup_insert in Hsh. + destruct (decide (sh' = shA)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hsh'. } + rewrite lookup_insert in Hsh'. + done. + - destruct (decide (ip = ipB)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hip. } + rewrite lookup_insert in Hip. + simplify_eq. + destruct (decide (sh = shB)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hsh. } + rewrite lookup_insert in Hsh. + destruct (decide (sh' = shB)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hsh'. } + rewrite lookup_insert in Hsh'. + simplify_eq. done. } + { intros ip Sn Hip sh skt bs sa Hsh Hskt. + rewrite insert_union_singleton_l in Hip. + apply lookup_union_Some in Hip; [|apply map_disjoint_dom; set_solver]. + destruct Hip as [Hip|Hip]. + - destruct (decide (ip = ipA)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hip. } + rewrite lookup_insert in Hip. + simplify_eq. + destruct (decide (sh = shA)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hsh. } + rewrite lookup_insert in Hsh. simplify_eq. set_solver. + - destruct (decide (ip = ipB)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hip. } + rewrite lookup_insert in Hip. + simplify_eq. + destruct (decide (sh = shB)) as [->|Hneq]; last first. + { by rewrite lookup_insert_ne in Hsh. } + rewrite lookup_insert in Hsh. simplify_eq. set_solver. } + iIntros (Hinv) "!> Hunallocated Hrt Hlive Hdead Hσ _ Hfrag Hnode Hst". + iDestruct (unallocated_split with "Hunallocated") as "[HA HB]"; [set_solver|]. + iMod (aneris_state_interp_socket_interp_allocate_singleton with "Hst [HB]") + as "[$ #HB]". + { rewrite /unallocated to_singletons_singleton. iApply "HB". } + iIntros "!>". + rewrite big_sepS_union; [|set_solver]. + iDestruct "Hrt" as "[HrtA HrtB]". + rewrite !big_sepS_singleton. + rewrite /retransmit_live_roles=> /=. + iDestruct (live_roles_own_split with "Hlive") as "[HliveA HliveB]"; + [set_solver|]. + replace (dom {[ipA := ∅; ipB := ∅]}) with ({[ipA]} ∪ {[ipB]} : gset _) + by set_solver. + rewrite !big_sepS_union; [|set_solver..]. + rewrite !big_sepS_singleton. + rewrite !lookup_total_insert. + rewrite !big_sepM_singleton. + simpl. + iDestruct "Hnode" as "[HnodeA HnodeB]". + iDestruct "Hσ" as "[[_ HshA] [_ HshB]]". + iSplitL "HrtA HnodeA HshA HliveA". + { iApply (wp_A with "[$HrtA $HshA $HliveA //]"). + iIntros "!>" (v) "H". + iExists _. by iFrame. } + iSplitL "HrtB HnodeB HshB HliveB". + { iApply (wp_B with "[$HrtB $HshB $HliveB //]"). + iIntros "!>" (v) "H". + iExists _. by iFrame. } + done. +Qed. diff --git a/fairneris/examples/retransmit_model.v b/fairneris/examples/retransmit_model.v new file mode 100644 index 0000000..171d919 --- /dev/null +++ b/fairneris/examples/retransmit_model.v @@ -0,0 +1,323 @@ +From trillium.prelude Require Export finitary quantifiers sigma classical_instances. +From Paco Require Import paco1 paco2 pacotac. +From fairneris Require Export trace_utils fairness env_model. +From fairneris.aneris_lang Require Import ast network lang aneris_lang. +From fairneris Require Export trace_utils ltl_lite. + +Import derived_laws_later.bi. + +Lemma prefix_trans {A} (l1 l2 l3 : list A) : + l1 `prefix_of` l2 → l2 `prefix_of` l3 → l1 `prefix_of` l3. +Proof. intros [l1' ->] [l2' ->]. by do 2 apply prefix_app_r. Qed. + +Lemma suffix_trans {A} (l1 l2 l3 : list A) : + l1 `suffix_of` l2 → l2 `suffix_of` l3 → l1 `suffix_of` l3. +Proof. intros [l1' ->] [l2' ->]. by do 2 apply suffix_app_r. Qed. + +(** The retransmit model states *) +Inductive retransmit_state := +| Start +| Received. + +#[global] Instance simple_state_eqdec : EqDecision retransmit_state. +Proof. intros ??. apply make_decision. Qed. +#[global] Instance simple_state_inhabited : Inhabited retransmit_state. +Proof. exact (populate Start). Qed. + +Inductive retransmit_role := Arole | Brole. + +Definition retransmit_node_action : Set := option message. +Definition retransmit_network_action : Set := option message. +Definition retransmit_action : Set := + retransmit_node_action + retransmit_network_action. + +#[global] Instance retransmit_role_eqdec : EqDecision retransmit_role. +Proof. intros ??. apply make_decision. Qed. +#[global] Instance retransmit_role_inhabited : Inhabited retransmit_role. +Proof. exact (populate (Arole)). Qed. +#[global] Instance retransmit_role_countable : Countable retransmit_role. +Proof. + refine ({| + encode s := match s with + | Arole => 1 + | Brole => 2 + end; + decode n := match n with + | 1 => Some Arole + | 2 => Some Brole + | _ => None + end; + |})%positive. + by intros [|]. +Qed. + +Definition saA : socket_address := SocketAddressInet "0.0.0.0" 80. +Definition saB : socket_address := SocketAddressInet "0.0.0.1" 80. +Definition mAB : message := mkMessage saA saB "Hello". + +Notation retransmit_label := (retransmit_role * option aneris_action)%type. + +Inductive retransmit_trans : + retransmit_state → retransmit_role * option aneris_action → retransmit_state → Prop := +| A_Send st : + retransmit_trans st (Arole, Some (Send mAB)) st +| B_RecvFail : + retransmit_trans Start (Brole, Some (Recv saB None)) Start +| B_RecvSucc msg : + retransmit_trans Start (Brole, Some (Recv saB (Some msg))) Received +. +Notation mtrace := (trace retransmit_state (retransmit_role * option aneris_action)). + +Definition retransmit_live_roles (s : retransmit_state) : gset retransmit_role := + {[Arole]} ∪ + (match s with Start => {[Brole]} | _ => ∅ end). + +Definition retransmit_role_enabled_model (ρ : retransmit_role) (s : retransmit_state) : Prop := + ρ ∈ retransmit_live_roles s. + +(* TODO: This is likely not needed. *) +Lemma retransmit_live_spec_holds s ρ α s' : + retransmit_trans s (ρ,α) s' → ρ ∈ retransmit_live_roles s. +Proof. inversion 1; set_solver. Qed. + +Definition send_filter msg : retransmit_label → Prop := + λ l, snd l = Some $ Send msg. +Instance send_filter_decision msg l : Decision (send_filter msg l). +Proof. apply make_decision. Qed. + +Definition recv_filter msg : retransmit_label → Prop := + λ l, snd l = Some $ Recv (m_destination msg) (Some msg). +Instance recv_filter_decision msg l : Decision (recv_filter msg l). +Proof. apply make_decision. Qed. + +Definition any_recv_filter sa : retransmit_label → Prop := + λ l, exists rcv, snd l = Some $ Recv sa rcv. +Instance any_recv_filter_decision l sa : Decision (any_recv_filter sa l). +Proof. apply make_decision. Qed. + +Definition retransmit_fair_network_delivery msg : mtrace → Prop := + □ (□◊ℓ↓send_filter msg → □◊ℓ↓ any_recv_filter (m_destination msg) → ◊ℓ↓ recv_filter msg). + +Definition retransmit_fair_network (mtr : mtrace) : Prop := + ∀ msg, retransmit_fair_network_delivery msg mtr. + +(* TODO: This should be generalised, and lifted to multiple roles *) +Definition retransmit_terminating_role (ρ : retransmit_role) (tr : mtrace) : Prop := + (◊↓λ st _, ρ ∉ retransmit_live_roles st) tr ∨ ¬ infinite_trace tr. + +Definition retransmit_fair_scheduling_mtr (ρ : retransmit_role) : mtrace → Prop := + trace_always_eventually_implies_now + (λ δ _, retransmit_role_enabled_model ρ δ) + (λ δ (ℓ: option retransmit_label), ¬ retransmit_role_enabled_model ρ δ ∨ + option_map fst ℓ = Some ρ). + +Definition retransmit_fair_scheduling (mtr : mtrace) : Prop := + ∀ ρ, retransmit_fair_scheduling_mtr ρ mtr. + +Definition mtrace_fair (mtr : mtrace) : Prop := + retransmit_fair_scheduling mtr ∧ retransmit_fair_network mtr. + +Lemma mtrace_fair_always mtr : + mtrace_fair mtr ↔ (□ mtrace_fair) mtr. +Proof. + split. + - rewrite /mtrace_fair. + intros [Hmtr1 Hmtr2]. + rewrite /retransmit_fair_scheduling in Hmtr1. + rewrite /retransmit_fair_network in Hmtr2. + rewrite /retransmit_fair_scheduling_mtr in Hmtr1. + rewrite /retransmit_fair_network_delivery in Hmtr2. + apply trace_always_forall in Hmtr1. + apply trace_always_forall in Hmtr2. + eassert ((□ trace_and _ _) mtr). + { apply trace_always_and. split; [apply Hmtr1|apply Hmtr2]. } + apply trace_always_idemp in H. + revert H. apply trace_always_mono. + intros tr. + apply trace_impliesI. + intros Htr. + apply trace_always_and in Htr as [Htr1 Htr2]. + split. + + intros x. revert Htr1. + apply trace_always_mono. intros tr'. apply trace_impliesI. + intros Htr'. done. + + intros x. revert Htr2. + apply trace_always_mono. intros tr'. apply trace_impliesI. + intros Htr'. done. + - by intros Hfair%trace_always_elim. +Qed. + +Definition trans_valid (mtr : mtrace) := + match mtr with + | ⟨s⟩ => True + | (s -[l]-> tr) => retransmit_trans s l (trfirst tr) + end. + +Definition mtrace_valid (mtr : mtrace) := + trace_always trans_valid mtr. + +Definition option_lift {S L} (P : S → L → Prop) : S → option L → Prop := + λ s ol, ∃ l, ol = Some l ∧ P s l. + +Lemma option_lift_Some {S L} (P : S → L → Prop) s l : + option_lift P s (Some l) → P s l. +Proof. intros (l'&Hl'&HP). by simplify_eq. Qed. + +Lemma A_always_live (mtr : mtrace) : + (□ (trace_now (λ s _, retransmit_role_enabled_model Arole s))) mtr. +Proof. apply trace_always_universal. + rewrite /pred_at /retransmit_role_enabled_model. intros mtr'. + by destruct mtr'; set_solver. +Qed. + +Lemma B_always_live_infinite (mtr : mtrace) : + ¬ retransmit_terminating_role Brole mtr → + (□ (trace_now (λ s _, retransmit_role_enabled_model Brole s))) mtr. +Proof. + intros Hnt. apply trace_alwaysI. intros mtr' Hsuff. + rewrite /trace_now /pred_at /retransmit_role_enabled_model. + have ? : Brole ∈ retransmit_live_roles (trfirst mtr'); last destruct mtr' =>//=. + apply NNP_P => Hin. apply Hnt. + rewrite /retransmit_terminating_role. left. + eapply (trace_eventually_suffix_of _ mtr') =>//. apply trace_eventually_intro. + by destruct mtr'. +Qed. + +Lemma B_always_live_always_eventually_receive (mtr : mtrace) : + mtrace_fair mtr → + mtrace_valid mtr → + (□ (trace_now (λ s _, retransmit_role_enabled_model Brole s))) mtr → + (□◊ℓ↓ any_recv_filter saB) mtr. +Proof. + intros Hf Hval Hae. apply trace_alwaysI. intros mtr' Hsuff. + have Hfs': retransmit_fair_scheduling mtr'. + { by apply mtrace_fair_always, (trace_always_suffix_of _ _ _ Hsuff), trace_always_elim in Hf as [??]. } + rewrite /retransmit_fair_scheduling in Hfs'. + specialize (Hfs' Brole). + rewrite /retransmit_fair_scheduling_mtr in Hfs'. + rewrite /trace_always_eventually_implies_now in Hfs'. + rewrite /trace_always_eventually_implies in Hfs'. + have He: (↓ λ s _, retransmit_role_enabled_model Brole s) mtr'. + { apply trace_always_elim in Hfs'. + apply (trace_always_suffix_of _ _ _ Hsuff) in Hae. + by apply trace_always_elim in Hae. } + apply trace_always_elim in Hfs'. + rewrite trace_impliesI in Hfs'. + specialize (Hfs' He). clear He. + apply trace_eventuallyI in Hfs' as (mtr'' & Hsuff' & Hfs''). + apply (trace_eventually_suffix_of _ mtr'') =>//. + have Hsuff2: trace_suffix_of mtr'' mtr by eapply trace_suffix_of_trans. + have He: retransmit_role_enabled_model Brole (trfirst mtr''). + { apply (trace_always_suffix_of _ _ _ Hsuff2) in Hae. + eapply trace_always_elim in Hae. by destruct mtr''. } + destruct mtr'' as [|s [ρ α]]; destruct Hfs''=>//. + apply trace_eventually_intro=>//=. + rewrite /trace_label /pred_at /any_recv_filter /=. + apply (trace_always_suffix_of _ _ _ Hsuff2), trace_always_elim in Hval. + inversion Hval; simplify_eq; naive_solver. +Qed. + +Lemma B_always_receives (mtr : mtrace) : + mtrace_fair mtr → + mtrace_valid mtr → + ¬ retransmit_terminating_role Brole mtr → + (□◊ℓ↓ any_recv_filter saB) mtr. +Proof. + intros Hf Hval Hnt. + apply B_always_live_infinite in Hnt. + apply B_always_live_always_eventually_receive in Hnt =>//. +Qed. + + +Lemma retransmit_fair_traces_eventually_A mtr : + retransmit_fair_scheduling_mtr Arole mtr → + (◊ (↓ (λ _ ℓ, option_map fst ℓ = Some $ Arole))) mtr. +Proof. + intros Hfair. + pose proof (A_always_live mtr) as HA. + eapply trace_always_eventually_always_implies; [|done]. + eapply trace_always_eventually_always_mono; [| |apply Hfair]. + - intros Htr. apply trace_implies_refl. + - intros tr. + apply trace_impliesI. + apply trace_now_mono. + intros s l. intros [Htr|Htr]; [|done]. + rewrite /retransmit_role_enabled_model in Htr. set_solver. +Qed. + +Lemma retransmit_fair_traces_eventually_mAB mtr : + mtrace_valid mtr → retransmit_fair_scheduling_mtr Arole mtr → + (◊ ℓ↓ send_filter mAB) mtr. +Proof. + intros Hvalid Hfair. + pose proof (retransmit_fair_traces_eventually_A mtr Hfair) as Htr. + eapply trace_eventually_mono_strong; [|done]. + intros tr' Htr'. + eapply trace_always_suffix_of in Hvalid; [|done]. + apply trace_always_elim in Hvalid. + destruct tr' as [s|s l tr']; [done|]. + apply trace_now_mono_strong. + intros ???? HP; simplify_eq. + destruct l. destruct r=>//. simpl in *. + simplify_eq. inversion Hvalid. inversion H1. by simplify_eq. +Qed. + +Lemma retransmit_fair_traces_always_eventually_mAB mtr : + mtrace_valid mtr → retransmit_fair_scheduling_mtr Arole mtr → + (□ ◊ ℓ↓ send_filter mAB) mtr. +Proof. + intros Hvalid Hfair. eapply trace_always_implies_always; + [|apply trace_always_and; split; [apply Hvalid|apply Hfair]]. + intros tr' [Hvalid' Hfair']%trace_always_and. + by apply retransmit_fair_traces_eventually_mAB. +Qed. + + +Lemma B_terminates (mtr : mtrace) : + mtrace_fair mtr → + mtrace_valid mtr → + retransmit_terminating_role Brole mtr. +Proof. + intros Hf Hval. apply NNP_P. intros Hnt. + have Haer := Hnt. + apply B_always_receives in Haer =>//. + have Haes: (□ ◊ ℓ↓ send_filter mAB) mtr. + { apply retransmit_fair_traces_always_eventually_mAB =>//. destruct Hf =>//. } + have Har: (◊ ℓ↓ recv_filter mAB) mtr. + { destruct Hf as [Hsf Hnf]. + specialize (Hnf mAB). + apply trace_always_elim in Hnf. + rewrite !trace_impliesI in Hnf. + naive_solver. } + apply trace_eventuallyI in Har as (mtr' & Hsuff & Hr). + destruct mtr' as [| s [ρ α] mtr'']; first naive_solver. + + apply Hnt. + left. apply trace_eventuallyI. exists mtr''. split. + { eapply trace_suffix_of_trans=>//. exists 1. done. } + + apply (trace_always_suffix_of _ _ _ Hsuff), trace_always_elim in Hval. + have ? : Brole ∉ retransmit_live_roles (trfirst mtr''). + { rewrite /trace_label /pred_at /recv_filter /= in Hr. + inversion Hval; simplify_eq; try set_solver. } + rewrite /trace_now /pred_at /=. destruct mtr''=>//. +Qed. + + +Definition retransmit_lts : Lts (retransmit_role * option (action aneris_lang)). +Proof. + refine({| + lts_state := retransmit_state; + lts_trans := retransmit_trans; + |}). +Defined. +Definition retransmit_fair_model : UserModel aneris_lang. +Proof. + refine({| + usr_role := retransmit_role; + usr_lts := retransmit_lts; + usr_live_roles := retransmit_live_roles; + usr_live_spec := retransmit_live_spec_holds; + usr_fl _ := 10; + |}). +Defined. diff --git a/fairneris/examples/stenning_code.v b/fairneris/examples/stenning_code.v new file mode 100644 index 0000000..fecdb87 --- /dev/null +++ b/fairneris/examples/stenning_code.v @@ -0,0 +1,36 @@ +From fairneris.aneris_lang Require Export lang. + +Definition client (sa_clt sa_srv : socket_address) : val := + λ: <>, + let: "sh_clt" := NewSocket #() in + SocketBind "sh_clt" #sa_clt;; + (rec: "f" "i" := + SendTo "sh_clt" "sa_srv" (i2s "i");; + match: (ReceiveFrom "sh_clt") with + NONE => "f" "i" + | SOME "m" => if: Snd "m" = "sa_srv" + then + let: "j" := s2i (Fst "m") in + if: "i" = "j" + then "f" ("i" + #1) + else "f" "i" + else + "f" "i" + end) #0. + +Definition server (sa_clt sa_srv : socket_address) : val := + λ: <>, + let: "sh_srv" := NewSocket #() in + SocketBind "sh_srv" #sa_srv;; + (rec: "f" "j" := + match: (ReceiveFrom "sh_srv") with + NONE => "f" "j" + | SOME "m" => if: Snd "m" = "sa_clt" + then + let: "i" := s2i (Fst "m") in + if: "j"+#1 = "i" + then SendTo "sh_srv" "sa_clt" "i";; "f" "i" + else SendTo "sh_srv" "sa_clt" "j";; "f" "j" + else + "f" "j" + end) #-1. diff --git a/fairneris/fair_resources.v b/fairneris/fair_resources.v new file mode 100644 index 0000000..217a24a --- /dev/null +++ b/fairneris/fair_resources.v @@ -0,0 +1,2207 @@ +From iris.algebra Require Import auth gmap gset excl. +From iris.proofmode Require Import tactics. +From fairneris Require Import fairness fuel map_included_utils env_model. + +Class LiveModelEq `{GoodLang Λ} `{N: EnvModel Λ} + `(LM: !LiveModel Λ (joint_model Mod N)) := { + cfg_labels_match_is_eq: ∀ x y, lm_cfg_labels_match LM x y ↔ x = y; + actions_match_is_eq: ∀ x y, lm_actions_match LM x y ↔ x = y; +}. +Arguments LiveModelEq {_ _ _ _ _ _ _ _ _ _ _} _. + +Canonical Structure ModelO `{GoodLang Λ} (Mdl : UserModel Λ) := leibnizO Mdl. +Canonical Structure RoleO `{GoodLang Λ} (Mdl : UserModel Λ) := leibnizO (Mdl.(usr_role)). +Canonical Structure localeO (Λ : language) := leibnizO (locale Λ). + +Class fairnessGpreS `{GoodLang Λ} `(LM: LiveModel Λ (joint_model M Net)) Σ := { + fairnessGpreS_model :> inG Σ (authUR (optionUR (exclR (ModelO M)))); + fairnessGpreS_model_fuel_mapping :> + inG Σ (authUR (gmapUR (localeO Λ) + (exclR $ gmapUR (RoleO M) natO))); + fairnessGpreS_model_free_roles :> inG Σ (authUR (gset_disjUR (RoleO M))); +}. + +Class fairnessGS `{GoodLang Λ} `(LM : LiveModel Λ (joint_model M Net)) Σ := FairnessGS { + fairness_inG :> fairnessGpreS LM Σ; + (** Underlying model *) + fairness_model_name : gname; + (** Mapping of threads to roles with fuel *) + fairness_model_fuel_mapping_name : gname; + (** Set of free/availble roles *) + fairness_model_free_roles_name : gname; +}. + +Global Arguments fairnessGS {_ _ _ _ _ _ _ _ _ _ _} LM Σ. +Global Arguments fairness_model_name {_ _ _ _ _ _ _ _ _ _ _ LM Σ} _. +Global Arguments fairness_model_fuel_mapping_name {Λ _ _ _ _ _ _ _ _ M Net LM Σ} _ : assert. +Global Arguments fairness_model_free_roles_name {Λ _ _ _ _ _ _ _ _ M Net LM Σ} _ : assert. + +Definition fairnessΣ Λ `{GoodLang Λ} M : gFunctors := #[ + GFunctor (authUR (optionUR (exclR (ModelO M)))); + GFunctor (authUR (gmapUR (localeO Λ) + (exclR $ gmapUR (RoleO M) natO))); + GFunctor (authUR (gset_disjUR (RoleO M))) +]. + +(* We need more parameters than the iris tactic supports... *) +Ltac solve_inG := + intros; + lazymatch goal with + | H:subG (?xΣ _ _ _ _ _ _ _ _ _ _ _ _) _ |- _ => try unfold xΣ in H + | H:subG (?xΣ _ _ _ _ _ _ _ _ _ _ _) _ |- _ => try unfold xΣ in H + | H:subG (?xΣ _ _ _ _ _ _ _ _ _ _) _ |- _ => try unfold xΣ in H + | H:subG (?xΣ _ _ _ _ _ _ _ _ _) _ |- _ => try unfold xΣ in H + | H:subG (?xΣ _ _ _ _ _ _ _ _) _ |- _ => try unfold xΣ in H + | H:subG (?xΣ _ _ _ _ _ _ _) _ |- _ => try unfold xΣ in H + | H:subG (?xΣ _ _ _ _ _ _) _ |- _ => try unfold xΣ in H + | H:subG (?xΣ _ _ _ _ _) _ |- _ => try unfold xΣ in H + | H:subG (?xΣ _ _ _ _) _ |- _ => try unfold xΣ in H + | H:subG (?xΣ _ _ _) _ |- _ => try unfold xΣ in H + | H:subG (?xΣ _ _) _ |- _ => try unfold xΣ in H + | H:subG (?xΣ _) _ |- _ => try unfold xΣ in H + | H:subG ?xΣ _ |- _ => try unfold xΣ in H + end; + repeat match goal with + | H:subG (gFunctors.app _ _) _ |- _ => apply subG_inv in H; destruct H + end; + repeat match goal with + | H:subG _ _ |- _ => move : (H) ; apply subG_inG in H || clear H + end; + intros; simpl in *; try assumption; split; assumption || by apply _. + + + +Global Instance subG_fairnessGpreS {Σ} `{GoodLang Λ} `{LM : LiveModel Λ (joint_model M Net)} + : + subG (fairnessΣ Λ M) Σ -> fairnessGpreS LM Σ. +Proof. solve_inG. Qed. + +Notation "f ⇂ R" := (filter (λ '(k,v), k ∈ R) f) (at level 30). + +Lemma dom_domain_restrict `{Countable X} {A} (f: gmap X A) (R: gset X): + R ⊆ dom f -> + dom (f ⇂ R) = R. +Proof. + intros ?. apply dom_filter_L. + intros i; split; [|set_solver]. + intros Hin. assert (Hin': i ∈ dom f) by set_solver. + apply elem_of_dom in Hin' as [??]. set_solver. +Qed. + +Lemma dom_domain_restrict_union_l `{Countable X} {A} (f: gmap X A) R1 R2: + R1 ∪ R2 ⊆ dom f -> + dom (f ⇂ R1) = R1. +Proof. + intros ?. apply dom_domain_restrict. set_solver. +Qed. +Lemma dom_domain_restrict_union_r `{Countable X} {A} (f: gmap X A) R1 R2: + R1 ∪ R2 ⊆ dom f -> + dom (f ⇂ R2) = R2. +Proof. + intros ?. apply dom_domain_restrict. set_solver. +Qed. + +Section bigop_utils. + Context `{Monoid M o}. + Context `{Countable K}. + + Lemma big_opMS (g: gset K) (P: K -> M): + ([^ o set] x ∈ g, P x) ≡ [^ o map] x ↦ y ∈ (mapset_car g), P x. + Proof. + rewrite big_opS_elements /elements /gset_elements /mapset_elements. + rewrite big_opM_map_to_list. + destruct g as [g]. simpl. rewrite big_opL_fmap. + f_equiv. + Qed. +End bigop_utils. + +Section bigop_utils. + Context `{Countable K} {A : cmra}. + Implicit Types m : gmap K A. + Implicit Types i : K. + + Lemma gset_to_gmap_singletons (a : A) (g : gset K): + ([^op set] x ∈ g, {[x := a]}) ≡ gset_to_gmap a g. + Proof. + rewrite big_opMS. + rewrite -(big_opM_singletons (gset_to_gmap a g)). + rewrite /gset_to_gmap big_opM_fmap //. + Qed. +End bigop_utils. + +Section map_utils. + Context `{Countable K, Countable V, EqDecision K}. + + Definition maps_inverse_match (m: gmap K V) (m': gmap V (gset K)) := + ∀ (k: K) (v: V), m !! k = Some v <-> ∃ (ks: gset K), m' !! v = Some ks ∧ k ∈ ks. + + Lemma no_locale_empty M M' ρ ζ: + maps_inverse_match M M' -> + M' !! ζ = Some ∅ -> + M !! ρ ≠ Some ζ. + Proof. + intros Hinv Hem contra. + destruct (Hinv ρ ζ) as [Hc _]. destruct (Hc contra) as (?&?&?). + by simplify_eq. + Qed. + + Lemma maps_inverse_bij M M' ρ X1 X2 ζ ζ': + maps_inverse_match M M' -> + M' !! ζ = Some X1 -> ρ ∈ X1 -> + M' !! ζ' = Some X2 -> ρ ∈ X2 -> + ζ = ζ'. + Proof. + intros Hinv Hζ Hρ Hζ' Hρ'. + assert (M !! ρ = Some ζ); first by apply Hinv; eexists; done. + assert (M !! ρ = Some ζ'); first by apply Hinv; eexists; done. + congruence. + Qed. + +End map_utils. + +Section fin_map_dom. +Context `{FinMapDom K M D}. +Lemma dom_empty_iff {A} (m : M A) : dom m ≡ ∅ ↔ m = ∅. +Proof. + split; [|intros ->; by rewrite dom_empty]. + intros E. apply map_empty. intros. apply not_elem_of_dom. + rewrite E. set_solver. +Qed. + +Section leibniz. + Context `{!LeibnizEquiv D}. + Lemma dom_empty_iff_L {A} (m : M A) : dom m = ∅ ↔ m = ∅. + Proof. unfold_leibniz. apply dom_empty_iff. Qed. +End leibniz. +End fin_map_dom. + +Section map_imap. + Context `{Countable K}. + Lemma map_imap_dom_inclusion {A B} (f : K → A → option B) (m : gmap K A) : + dom (map_imap f m) ⊆ dom m. + Proof. + intros i [k Hk]%elem_of_dom. rewrite map_lookup_imap in Hk. + destruct (m !! i) eqn:?; last done. + rewrite elem_of_dom. by eexists. + Qed. + Lemma map_imap_dom_eq {A B} (f : K → A → option B) (m : gmap K A) : + (forall k a, k ∈ dom m -> is_Some (f k a)) -> + dom (map_imap f m) = dom m. + Proof. + rewrite -leibniz_equiv_iff. intros HisSome i. split. + - intros [x Hx]%elem_of_dom. rewrite map_lookup_imap in Hx. + apply elem_of_dom. destruct (m !! i) eqn:Heq; eauto. + by simpl in Hx. + - intros [x Hx]%elem_of_dom. + rewrite elem_of_dom map_lookup_imap Hx /=. apply HisSome, elem_of_dom. eauto. + Qed. +End map_imap. + +Section model_state_interp. + Context `{GoodLang Λ}. + Context `{LM: LiveModel Λ (joint_model M Net)}. + Context {Σ : gFunctors}. + Context {fG: fairnessGS LM Σ}. + Context `{!invGS_gen HasNoLc Σ}. + + Notation Role := (usr_role M). + + Definition auth_fuel_mapping_is + (m: gmap (locale Λ) (gmap Role nat)) : iProp Σ := + own (fairness_model_fuel_mapping_name fG) + (● (fmap Excl m : + ucmra_car (gmapUR _ (exclR $ gmapUR (RoleO M) natO) + ))). + + Definition frag_fuel_mapping_is + (m: gmap (locale Λ) (gmap Role nat)) : iProp Σ := + own (fairness_model_fuel_mapping_name fG) + (◯ (fmap Excl m: + ucmra_car (gmapUR _ (exclR $ gmapUR (RoleO M) natO) + ))). + + Definition auth_model_is (fm: M): iProp Σ := + own (fairness_model_name fG) (● Excl' fm). + + Definition frag_model_is (fm: M): iProp Σ := + own (fairness_model_name fG) (◯ Excl' fm). + + Definition auth_free_roles_are (FR: gset Role): iProp Σ := + own (fairness_model_free_roles_name fG) (● (GSet FR)). + + Definition frag_free_roles_are (FR: gset Role): iProp Σ := + own (fairness_model_free_roles_name fG) (◯ (GSet FR)). + + Definition fuel_map_le_inner (m1 m2 : gmap (locale Λ) (gmap Role nat)) := + map_included (λ (fs1 fs2 : gmap Role nat), + map_included (≤) fs1 fs2) m1 m2. + + Definition fuel_map_le (m1 m2 : gmap (locale Λ) (gmap Role nat)) := + fuel_map_le_inner m1 m2 ∧ + (* OBS: This is a bit hacky, should instead change definition. *) + dom m1 = dom m2. + + Definition fuel_map_preserve_dead + (m : gmap (locale Λ) (gmap Role nat)) + (ρs : gset Role) := + ∀ ρ, ρ ∈ ρs → ∃ ζ fs, m !! ζ = Some fs ∧ ρ ∈ dom fs. + + Definition fuel_map_preserve_threadpool (tp: list $ expr Λ) + (fuel_map : gmap (locale Λ) (gmap Role nat)) := + ∀ ζ, ζ ∉ locales_of_list tp → fuel_map !! ζ = None. + + Definition usr_state (δ : LiveStateData Λ (joint_model M Net)) : M := δ.(ls_under).1. + Definition env_state (δ : LiveStateData Λ (joint_model M Net)) : Net := δ.(ls_under).2. + + Definition model_state_interp (c: cfg Λ) (δ: LiveStateData Λ (joint_model M Net)): iProp Σ := + ∃ fuel_map, + ⌜ fuel_map_le fuel_map δ.(ls_map) ⌝ ∗ + ⌜ fuel_map_preserve_dead fuel_map (M.(usr_live_roles) (usr_state δ)) ⌝ ∗ + ⌜ fuel_map_preserve_threadpool c.1 fuel_map ⌝ ∗ + auth_model_is (usr_state δ) ∗ auth_fuel_mapping_is fuel_map ∗ + ⌜ env_states_match c (ls_under δ).2 ⌝. + + Lemma model_state_interp_tids_smaller (δ : LiveState _ _) c : + model_state_interp c δ -∗ ⌜ tids_smaller c.1 δ ⌝. + Proof. + iIntros "(%m&[_ %Heq]&%&%Hbig&_)". + iPureIntro. + intros ζ Hin. + assert (¬ (ζ ∉ locales_of_list c.1)). + - intros contra. + specialize (Hbig _ contra). + rewrite -Heq elem_of_dom Hbig in Hin. + inversion Hin. naive_solver. + - destruct (decide (ζ ∈ locales_of_list c.1)) as [Hin'|] =>//. + apply elem_of_list_fmap in Hin' as [[tp' e'] [-> Hin']]. + unfold from_locale. exists e'. by apply from_locale_from_Some. + Qed. + +End model_state_interp. + +Lemma own_proper `{inG Σ X} γ (x y: X): + x ≡ y -> + own γ x -∗ own γ y. +Proof. intros ->. naive_solver. Qed. + +Section model_state_lemmas. + Context `{GoodLang Λ}. + Context `{LM: LiveModel Λ (joint_model M Net)}. + Context {Σ : gFunctors}. + Context `{EqDecision (expr Λ)}. + Context {fG: fairnessGS LM Σ}. + + Notation Role := (M.(usr_role)). + + Definition has_fuels (ζ: locale Λ) (fs: gmap Role nat) : iProp Σ := + frag_fuel_mapping_is {[ ζ := fs ]}. + + #[global] Instance has_fuels_proper : + Proper ((≡) ==> (≡) ==> (≡)) (has_fuels). + Proof. solve_proper. Qed. + + #[global] Instance has_fuels_timeless (ζ: locale Λ) (fs: gmap Role nat): + Timeless (has_fuels ζ fs). + Proof. rewrite /has_fuels. apply _. Qed. + + Definition has_fuels_S (ζ: locale Λ) (fs: gmap Role nat): iProp Σ := + has_fuels ζ (S <$> fs). + + Definition has_fuels_plus (n: nat) (ζ: locale Λ) (fs: gmap Role nat): iProp Σ := + has_fuels ζ (fmap (fun m => n+m) fs). + + Lemma has_fuel_fuels_plus_1 (ζ: locale Λ) fs: + has_fuels_plus 1 ζ fs ⊣⊢ has_fuels_S ζ fs. + Proof. + rewrite /has_fuels_plus /has_fuels_S. do 2 f_equiv. + intros m m' ->. apply leibniz_equiv_iff. lia. + Qed. + + Lemma has_fuel_fuels_plus_0 (ζ: locale Λ) fs: + has_fuels_plus 0 ζ fs ⊣⊢ has_fuels ζ fs. + Proof. + rewrite /has_fuels_plus /=. f_equiv. intros ?. + rewrite lookup_fmap. apply leibniz_equiv_iff. + destruct (fs !! i) eqn:Heq; rewrite Heq //. + Qed. + + Lemma has_fuels_plus_split_S n (ζ: locale Λ) fs: + has_fuels_plus (S n) ζ fs ⊣⊢ has_fuels_S ζ ((λ m, n + m) <$> fs). + Proof. + rewrite /has_fuels_plus /has_fuels_S. f_equiv. + rewrite -map_fmap_compose /= => ρ. + rewrite !lookup_fmap //. + Qed. + +End model_state_lemmas. + +Notation "tid ↦M R" := (has_fuels tid R) (at level 20, format "tid ↦M R") : bi_scope. +Notation "tid ↦M++ R" := (has_fuels_S tid R) (at level 20, format "tid ↦M++ R") : bi_scope. + +Section adequacy. + Context `{GoodLang Λ}. + Context `{LM: LiveModel Λ (joint_model M Net)}. + Context {Σ : gFunctors}. + Context {fG: fairnessGpreS LM Σ}. + + Lemma model_state_init (s0: M) : + ⊢ |==> ∃ γ, + own (A := authUR (optionUR (exclR (ModelO M)))) γ + (● (Excl' s0) ⋅ ◯ (Excl' s0)). + Proof. + iMod (own_alloc (● Excl' s0 ⋅ ◯ Excl' s0)) as (γ) "[Hfl Hfr]". + { by apply auth_both_valid_2. } + iExists _. by iSplitL "Hfl". + Qed. + + Definition init_fuel_map (s0: M) (ζ0: locale Λ) : + gmap (locale Λ) (exclR $ gmap (usr_role M) nat) := + {[ ζ0 := Excl (gset_to_gmap (usr_fl s0) (usr_live_roles s0)) ]}. + + Lemma model_fuel_mapping_init_gen (fss: gmap (locale Λ) (gmap M.(usr_role) nat)) : + let fss' := fmap Excl fss: ucmra_car (gmapUR _ (exclR $ gmapUR (RoleO M) natO)) in + ⊢ |==> ∃ γ, own γ (● fss') ∗ own γ (◯ fss'). + Proof. + intros fss'. + iMod (own_alloc (● fss' ⋅ ◯ fss')) as (γ) "[Hfl Hfr]". + { apply auth_both_valid_2; eauto. + intros i. rewrite /fss'. rewrite lookup_fmap. + destruct (fss !! i) as [fs|] eqn:Heq; rewrite Heq //. } + iExists _. by iSplitL "Hfl". + Qed. + + Lemma model_fuel_mapping_init (s0: M) (ζ0: locale Λ) : + ⊢ |==> ∃ γ, + own γ (● (init_fuel_map s0 ζ0)) ∗ + own γ (◯ (init_fuel_map s0 ζ0)). + Proof. + iMod (own_alloc (● (init_fuel_map s0 ζ0) ⋅ + ◯ (init_fuel_map s0 ζ0))) as (γ) "[Hfl Hfr]". + { apply auth_both_valid_2; eauto. by apply singleton_valid. } + iExists _. by iSplitL "Hfl". + Qed. + + Lemma model_free_roles_init (s0: M) (FR: gset _): + ⊢ |==> ∃ γ, + own (A := authUR (gset_disjUR (RoleO M))) γ (● GSet FR ⋅ ◯ GSet FR). + Proof. + iMod (own_alloc (● GSet FR ⋅ ◯ GSet FR)) as (γ) "[H1 H2]". + { apply auth_both_valid_2 =>//. } + iExists _. by iSplitL "H1". + Qed. +End adequacy. + +Section model_state_lemmas. + Context `{GoodLang Λ}. + Context `{LM: LiveModel Λ (joint_model M Net)}. + Context {Σ : gFunctors}. + Context {fG: fairnessGS LM Σ}. + Context `{!invGS_gen HasNoLc Σ}. + Context `{EqDecision (expr Λ)}. + + Lemma update_model δ δ1 δ2: + auth_model_is δ1 -∗ frag_model_is δ2 ==∗ auth_model_is δ ∗ frag_model_is δ. + Proof. + iIntros "H1 H2". iCombine "H1 H2" as "H". + iMod (own_update with "H") as "[??]" ; eauto. + - by apply auth_update, option_local_update, (exclusive_local_update _ (Excl δ)). + - iModIntro. iFrame. + Qed. + + Lemma model_agree s1 s2: + auth_model_is s1 -∗ frag_model_is s2 -∗ ⌜ s1 = s2 ⌝. + Proof. + iIntros "Ha Hf". + by iDestruct (own_valid_2 with "Ha Hf") as + %[Heq%Excl_included%leibniz_equiv ?]%auth_both_valid_discrete. + Qed. + + Lemma model_agree' δ1 s2 n: + model_state_interp n δ1 -∗ frag_model_is s2 -∗ ⌜ (ls_under δ1).1 = s2 ⌝. + Proof. + iIntros "Hsi Hs2". iDestruct "Hsi" as "(%fm&?&_&_&Hs1&_)". + iApply (model_agree with "Hs1 Hs2"). + Qed. + + Lemma has_fuels_agree (ζ : locale Λ) (fs : gmap (usr_role M) nat) + (m : gmap (locale Λ) (gmap (usr_role M) nat)) : + auth_fuel_mapping_is m -∗ has_fuels ζ fs -∗ ⌜m !! ζ = Some fs⌝. + Proof. + iIntros "Hauth Hfrag". + iDestruct (own_valid_2 with "Hauth Hfrag") as %Hvalid. + iPureIntro. + apply auth_both_valid_discrete in Hvalid as [Hincl Hvalid]. + rewrite fmap_insert fmap_empty in Hincl. + rewrite lookup_included in Hincl. + specialize (Hincl ζ). + rewrite lookup_insert in Hincl. + apply option_included in Hincl. + destruct Hincl as [|Hincl]; [done|]. + destruct Hincl as (a&b&Ha&Hb&Hincl). + simplify_eq. + rewrite lookup_fmap_Some in Hb. + destruct Hb as (b'&Heq&HSome). + simplify_eq. + rewrite HSome. f_equiv. + destruct Hincl as [Hincl|Hincl]. + - naive_solver. + - apply Some_included_mono in Hincl. + rewrite Excl_included in Hincl. + naive_solver. + Qed. + + Lemma has_fuels_update fm ζ fs fs' : + auth_fuel_mapping_is fm -∗ has_fuels ζ fs ==∗ + auth_fuel_mapping_is (<[ζ := fs']>fm) ∗ has_fuels ζ fs'. + Proof. + iIntros "Hfm Hfs". + iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. + iMod (own_update_2 with "Hfm Hfs") as "[$ $]"; [|done]. + apply auth_update. + rewrite !fmap_insert. + rewrite !fmap_empty. + rewrite <-(insert_insert ∅ ζ (Excl fs') (Excl fs)). + (* BUG in ssrelfect rewrite here? *) + (* rewrite -(insert_insert ∅ ζ (Excl fs') (Excl fs)). *) + eapply insert_local_update; [| |]. + - rewrite lookup_fmap. rewrite Hagree. simpl. done. + - simpl. rewrite lookup_insert. done. + - eapply exclusive_local_update. done. + Qed. + + Lemma has_fuels_decr (ζ : locale Λ) (fs : gmap (usr_role M) nat) + (m : gmap (locale Λ) (gmap (usr_role M) nat)) : + auth_fuel_mapping_is m -∗ has_fuels_S ζ fs ==∗ + auth_fuel_mapping_is (<[ζ := fs]>m) ∗ has_fuels ζ fs. + Proof. + iIntros "Hfm Hfs". + iMod (has_fuels_update with "Hfm Hfs") as "[Hfm Hfs]". + by iFrame. + Qed. + + Lemma has_fuels_delete fs ζ ρs ρ : + auth_fuel_mapping_is fs -∗ has_fuels ζ ρs ==∗ + auth_fuel_mapping_is (<[ζ := delete ρ ρs]>fs) ∗ + has_fuels ζ (delete ρ ρs). + Proof. + iIntros "Hfm Hfs". + iMod (has_fuels_update with "Hfm Hfs") as "[Hfm Hfs]". + by iFrame. + Qed. + + Lemma model_state_interp_has_fuels_decr tp δ tid fs : + model_state_interp tp δ -∗ has_fuels_S tid fs ==∗ + model_state_interp tp δ ∗ has_fuels tid fs. + Proof. + iDestruct 1 as "(%fm&[%Hfmle%Hdom]&%Hfmdead&%Htp&Hδ&Hfm&%Hsm)". + iIntros "Hfs". + iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. + iMod (has_fuels_decr with "Hfm Hfs") as "[Hfm Hfs]". + iModIntro. iFrame "Hfs". + iExists _. iFrame. + iPureIntro. repeat split. + - eapply map_included_transitivity; [|done]. + rewrite -{2}(insert_id fm tid (S <$> fs)); [|done]. + apply map_included_insert; [|apply map_included_refl]. + apply map_included_fmap. lia. + - rewrite -Hdom. rewrite -{2}(insert_id fm tid (S <$> fs)); [set_solver|]. + done. + - intros ρ Hin. apply Hfmdead in Hin as (ζ'&ρs&HSome&Hρ). + destruct (decide (tid = ζ')) as [->|Hneq]. + + exists ζ', fs. rewrite lookup_insert. + split; [done|]. set_solver. + + exists ζ', ρs. rewrite lookup_insert_ne; [|done]. done. + - intros ζ Hζ. + specialize (Htp ζ Hζ). + rewrite -(insert_id fm tid (S <$> fs)) in Htp; [|done]. + rewrite -not_elem_of_dom. + rewrite -not_elem_of_dom in Htp. + set_solver. + - done. + Qed. + + Lemma model_state_interp_has_fuels_dealloc tid fs ρ tp δ δ' : + ρ ∉ usr_live_roles δ → + model_state_interp tp δ' -∗ + frag_model_is δ -∗ + has_fuels tid fs ==∗ + model_state_interp tp δ' ∗ frag_model_is δ ∗ has_fuels tid (delete ρ fs). + Proof. + intros Hρ. + destruct (decide (ρ ∈ dom fs)) as [Hin|Hnin]; last first. + { assert (delete ρ fs = fs) as ->. + { apply delete_notin. by rewrite -not_elem_of_dom. } + by iIntros "$$$". } + iDestruct 1 as "(%fm&[%Hfmle%Hdom]&%Hfmdead&%Htp&Hm&Hfm&%Hsm)". + iIntros "Hst Hfs". + iDestruct (model_agree with "Hm Hst") as %Heq. rewrite !Heq. + assert (is_Some (fs !! ρ)) as [f HSome]. + { by rewrite -elem_of_dom. } + iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. + iMod (has_fuels_delete with "Hfm Hfs") as "[Hfm Hfs]". + iModIntro. + iFrame "Hst". iFrame "Hfs". + iExists _. iFrame. rewrite Heq. iFrame. + iPureIntro. + repeat split; try done. + - rewrite /fuel_map_le. + eapply map_included_transitivity; [|done]. + rewrite -{2}(insert_id fm tid fs); [|done]. + apply map_included_insert; [|apply map_included_refl]. + eapply map_included_subseteq; [|done]. + apply delete_subseteq. + - rewrite dom_insert_L. + assert (tid ∈ dom fm). + { by apply elem_of_dom. } + set_solver. + - rewrite /fuel_map_preserve_dead. + intros ρ' Hρ'. + assert (ρ ≠ ρ') by set_solver. + rewrite /fuel_map_preserve_dead in Hfmdead. + rewrite Heq in Hfmdead. + apply Hfmdead in Hρ' as (ζ&ρs&HSome'&Hρs). + destruct (decide (tid = ζ)) as [->|Hneq]. + + exists ζ, (delete ρ fs). + rewrite lookup_insert. set_solver. + + exists ζ, ρs. rewrite lookup_insert_ne; [|done]. + set_solver. + - intros ζ Hζ. specialize (Htp ζ Hζ). + rewrite -not_elem_of_dom. + rewrite -not_elem_of_dom in Htp. + assert (ζ ≠ tid). + { intros ->. + assert (tid ∈ dom fm). + { rewrite elem_of_dom. by set_solver. } + set_solver. } + set_solver. + Qed. + + (* TODO: Move this *) + Lemma silent_step_suff_data_weak act fl `(δ: LiveState Λ (joint_model M Net)) + (fs fs' : gmap _ nat) ζ: + δ.(ls_map) !! ζ = Some fs → + fs ≠ ∅ → + map_included (<) fs' fs → + (dom fs ∖ dom fs') ∩ usr_live_roles (usr_state δ) = ∅ → + ∃ δ', δ'.(ls_data) = + {| ls_under := δ; + ls_map := <[ζ := fs']> δ.(ls_map) |} ∧ + ls_trans fl δ (Silent_step ζ act) δ'. + Proof. + intros. + apply (silent_step_suff_data fl δ fs fs' ∅ ζ None); try done. + - rewrite -> map_included_spec in *. done. + - set_solver. + - set_solver. + Qed. + + (* TODO: Change original lemma to not existentially quantify new state *) + Lemma silent_step_suff_data_weak_alt act fl (δ δ' : LiveState Λ (joint_model M Net)) + (fs fs' : gmap _ nat) ζ : + δ.(ls_under) = δ'.(ls_under) → + δ.(ls_map) !! ζ = Some fs → + δ'.(ls_map) = <[ζ := fs']>δ.(ls_map) → + fs ≠ ∅ → + map_included (<) fs' fs → + (dom fs ∖ dom fs') ∩ usr_live_roles (usr_state δ) = ∅ → + ls_trans fl δ (Silent_step ζ act) δ'. + Proof. + rewrite map_included_spec. intros Hδ Hfs Hfs' Hne Hle Hlive. + assert (∃ δ', δ'.(ls_data) = + {| ls_under := δ; + ls_map := <[ζ := fs']> δ.(ls_map) |} ∧ + ls_trans fl δ (Silent_step ζ act) δ') as (δ''&Heq&Htrans). + { apply (silent_step_suff_data fl δ fs fs' ∅ ζ None); try set_solver. } + rewrite Heq Hδ -Hfs' in Htrans. by destruct δ', ls_data. + Qed. + + Definition model_can_fuel_step (δ1 : LM) (ζ : locale Λ) (δ2 : LM) : Prop := + ∃ fs1 fs2, + δ1.(ls_under) = δ2.(ls_under) ∧ + δ1.(ls_map) !! ζ = Some fs1 ∧ + δ2.(ls_map) = <[ζ := fs2]>δ1.(ls_map) ∧ + fs1 ≠ ∅ ∧ + map_included (<) fs2 fs1 ∧ + (dom fs1 ∖ dom fs2) ∩ usr_live_roles (usr_state δ1) = ∅. + + Lemma model_can_fuel_step_trans act fl ζ (δ δ' : LiveState Λ _) : + model_can_fuel_step δ ζ δ' → ls_trans fl δ (Silent_step ζ act) δ'. + Proof. + destruct 1 as (?&?&?&?&?&?&?&?). by eapply silent_step_suff_data_weak_alt. + Qed. + + Definition decr_fuel_map (fs : gmap (usr_role M) nat) : gmap (usr_role M) nat := + (λ f, f - 1) <$> fs. + + Lemma decr_fuel_map_included fs : map_included (≤) (decr_fuel_map fs) fs. + Proof. + apply map_included_spec. intros k v1 Hm. + apply lookup_fmap_Some in Hm as [v2 [Hv2 Hm]]. + exists v2. split; [done|lia]. + Qed. + + Definition filter_fuel_map + (δ: LiveState Λ (joint_model M Net)) (ρs : gset (usr_role M)) (fs : gmap (usr_role M) nat) : + gmap (usr_role M) nat := + (filter (λ ρf, ρf.1 ∈ usr_live_roles (usr_state δ) ∨ ρf.1 ∈ ρs)) fs. + + Lemma filter_fuel_map_included δ ρs fs : + map_included (≤) (filter_fuel_map δ ρs fs) fs. + Proof. + apply map_included_spec. + intros k v1 Hm. + exists v1. split; [|lia]. + pose proof (map_filter_subseteq + (λ ρf : usr_role M * nat, ρf.1 ∈ usr_live_roles (usr_state δ) ∨ ρf.1 ∈ ρs) fs) + as Hle. + rewrite map_subseteq_spec in Hle. + by apply Hle. + Qed. + + Definition model_update_locale_role_map + δ (ρs : gset (usr_role M)) : gmap (usr_role M) nat → gmap (usr_role M) nat := + decr_fuel_map ∘ filter_fuel_map δ ρs. + + Lemma model_update_locale_role_map_map_included δ ρs fs : + map_included (≤) (model_update_locale_role_map δ ρs fs) fs. + Proof. + rewrite /model_update_locale_role_map. + eapply map_included_transitivity; + [eapply decr_fuel_map_included|eapply filter_fuel_map_included]. + Qed. + + Definition model_update_locale_fuel_map + δ (ζ : locale Λ) (ρs : gset (usr_role M)) + (fm : gmap (locale Λ) (gmap (usr_role M) nat)) : + gmap (locale Λ) (gmap (usr_role M) nat) := + <[ζ:= model_update_locale_role_map δ ρs (fm !!! ζ)]>fm. + + Program Definition model_update_decr (ζ : locale Λ) (δ : LM) : LM := + {| + ls_data := + {| ls_under := δ.(ls_under); + ls_map := alter (fmap (λ f, f - 1)) ζ δ.(ls_map); |}; + |}. + Next Obligation. + intros ζ δ ζ1 ζ2 fs1 fs2 Hneq HSome1 HSome2. + simpl in *. + pose proof δ.(ls_map_disj) as Hdisj. + assert (∃ fs1', map_included (≤) fs1 fs1' ∧ ls_map δ !!! ζ1 = fs1') + as (fs1' & Hle1 & Hfs1'). + { destruct (decide (ζ = ζ1)) as [<-|Hneq']. + + rewrite lookup_alter in HSome1. + rewrite -lookup_fmap in HSome1. + apply lookup_fmap_Some in HSome1 as (fs1'&Hfs1'&HSome1'). + simplify_eq. + exists fs1'. rewrite lookup_total_alt. simpl. rewrite HSome1'. + split; [apply decr_fuel_map_included|done]. + + rewrite lookup_alter_ne in HSome1; [|done]. + rewrite lookup_total_alt. eexists _. + split; [done|by rewrite HSome1]. } + assert (∃ fs2', map_included (≤) fs2 fs2' ∧ ls_map δ !!! ζ2 = fs2') + as (fs2' & Hle2 & Hfs2'). + { destruct (decide (ζ = ζ2)) as [<-|Hneq']. + + rewrite lookup_alter in HSome2. + rewrite -lookup_fmap in HSome2. + apply lookup_fmap_Some in HSome2 as (fs2'&Hfs2'&HSome2'). + simplify_eq. + exists fs2'. rewrite lookup_total_alt. simpl. rewrite HSome2'. + split; [apply decr_fuel_map_included|done]. + + rewrite lookup_alter_ne in HSome2; [|done]. + rewrite lookup_total_alt. eexists _. + split; [done|by rewrite HSome2]. } + rewrite lookup_total_alt in Hfs1'. + rewrite lookup_total_alt in Hfs2'. + destruct (ls_map δ !! ζ1) as [fs1''|] eqn:Hfs1''; last first. + { apply map_included_subseteq_inv in Hle1. + apply map_disjoint_dom. + rewrite Hfs1'' /= in Hfs1'. simplify_eq. set_solver. } + destruct (ls_map δ !! ζ2) as [fs2''|] eqn:Hfs2''; last first. + { apply map_included_subseteq_inv in Hle2. + apply map_disjoint_dom. rewrite Hfs2'' in Hfs2'. set_solver. } + simplify_eq; simpl in *. + specialize (Hdisj ζ1 ζ2 fs1'' fs2'' Hneq Hfs1'' Hfs2''). + apply map_disjoint_spec. + rewrite map_disjoint_spec in Hdisj. + intros i x y HSome1' HSome2'. + rewrite map_included_spec in Hle1. + apply Hle1 in HSome1' as (?&?&?). + rewrite map_included_spec in Hle2. + apply Hle2 in HSome2' as (?&?&?). + rewrite -> Hfs1'', Hfs2'' in *. + by eapply Hdisj. + Qed. + Next Obligation. + intros ζ δ ρ Hlive. + simpl in *. + pose proof Hlive as Hlive'. + apply (ls_map_live δ) in Hlive as (ζ' & fs & HSome & Hdom). + destruct (decide (ζ = ζ')) as [<-|Hneq]. + - eexists ζ, _. + rewrite lookup_alter. rewrite HSome. simpl. + split; [done|]. + rewrite dom_fmap. done. + - eexists ζ', fs. by rewrite lookup_alter_ne. + Qed. + + Program Definition model_update_filter + (ζ : locale Λ) (ρs : gset (usr_role M)) (δ : LM) : LM := + {| + ls_data := + {| ls_under := δ.(ls_under); + ls_map := + alter (filter + (λ ρf, ρf.1 ∈ usr_live_roles (usr_state δ) ∨ ρf.1 ∈ ρs)) + ζ δ.(ls_map); |}; + |}. + Next Obligation. + intros ζ ρs δ ζ1 ζ2 fs1 fs2 Hneq HSome1 HSome2. + simpl in *. + pose proof δ.(ls_map_disj) as Hdisj. + assert (∃ fs1', map_included (≤) fs1 fs1' ∧ ls_map δ !!! ζ1 = fs1') + as (fs1' & Hle1 & Hfs1'). + { destruct (decide (ζ = ζ1)) as [<-|Hneq']. + + rewrite lookup_alter in HSome1. + rewrite -lookup_fmap in HSome1. + apply lookup_fmap_Some in HSome1 as (fs1'&Hfs1'&HSome1'). + simplify_eq. + exists fs1'. rewrite lookup_total_alt. simpl. rewrite HSome1'. + split; [apply filter_fuel_map_included|done]. + + rewrite lookup_alter_ne in HSome1; [|done]. + rewrite lookup_total_alt. eexists _. + split; [done|by rewrite HSome1]. } + assert (∃ fs2', map_included (≤) fs2 fs2' ∧ ls_map δ !!! ζ2 = fs2') + as (fs2' & Hle2 & Hfs2'). + { destruct (decide (ζ = ζ2)) as [<-|Hneq']. + + rewrite lookup_alter in HSome2. + rewrite -lookup_fmap in HSome2. + apply lookup_fmap_Some in HSome2 as (fs2'&Hfs2'&HSome2'). + simplify_eq. + exists fs2'. rewrite lookup_total_alt. simpl. rewrite HSome2'. + split; [apply filter_fuel_map_included|done]. + + rewrite lookup_alter_ne in HSome2; [|done]. + rewrite lookup_total_alt. eexists _. + split; [done|by rewrite HSome2]. } + rewrite lookup_total_alt in Hfs1'. + rewrite lookup_total_alt in Hfs2'. + destruct (ls_map δ !! ζ1) as [fs1''|] eqn:Hfs1''; last first. + { apply map_included_subseteq_inv in Hle1. + apply map_disjoint_dom. rewrite Hfs1'' in Hfs1'. set_solver. } + destruct (ls_map δ !! ζ2) as [fs2''|] eqn:Hfs2''; last first. + { apply map_included_subseteq_inv in Hle2. + apply map_disjoint_dom. rewrite Hfs2'' in Hfs2'. set_solver. } + simplify_eq; simpl in *. + specialize (Hdisj ζ1 ζ2 fs1'' fs2'' Hneq Hfs1'' Hfs2''). + apply map_disjoint_spec. + rewrite map_disjoint_spec in Hdisj. + intros i x y HSome1' HSome2'. + rewrite map_included_spec in Hle1. + apply Hle1 in HSome1' as (?&?&?). + rewrite map_included_spec in Hle2. + apply Hle2 in HSome2' as (?&?&?). + rewrite -> Hfs1'', Hfs2'' in *. + by eapply Hdisj. + Qed. + Next Obligation. + intros ζ ρs δ ρ Hlive. + simpl in *. + pose proof Hlive as Hlive'. + apply (ls_map_live δ) in Hlive as (ζ' & fs & HSome & Hdom). + destruct (decide (ζ = ζ')) as [<-|Hneq]. + - eexists ζ, _. + rewrite lookup_alter. rewrite HSome. simpl. + split; [done|]. + rewrite map_filter_or. + rewrite dom_union_L. + apply elem_of_union. left. + apply elem_of_dom. + apply elem_of_dom in Hdom as [f Heq]. exists f. + by apply map_lookup_filter_Some_2. + - eexists ζ', fs. by rewrite lookup_alter_ne. + Qed. + + Definition model_update_locale_fuel + (δ : LM) (ζ : locale Λ) (ρs : gset (usr_role M)) : LM := + model_update_decr ζ $ model_update_filter ζ ρs δ. + + Lemma model_update_locale_spec extr (auxtr : auxiliary_trace LM) ζ c2 ρs: + valid_state_evolution_fairness extr auxtr → + model_can_fuel_step (trace_last auxtr) ζ ((model_update_locale_fuel (trace_last auxtr) ζ) ρs) → + tids_smaller c2.1 (model_update_locale_fuel (trace_last auxtr) ζ ρs) → + locale_step (trace_last extr) (inl (ζ, None)) c2 → + valid_state_evolution_fairness + (extr :tr[inl (ζ, None)]: c2) + (auxtr :tr[Silent_step ζ None]: + (model_update_locale_fuel (trace_last auxtr) ζ) ρs). + Proof. + intros Hvse Hstep Htids Hexstep. destruct c2 as [tp σ]. + destruct Hvse as (?&?&?). + split; [| split]=>//. + econstructor=>//; first by apply model_can_fuel_step_trans. + Qed. + + Definition map_disj (m : gmap (locale Λ) (gmap (usr_role M) nat)) := + ∀ ζ ζ' fs fs', ζ ≠ ζ' → m !! ζ = Some fs → m !! ζ' = Some fs' → fs ##ₘ fs'. + + Lemma decr_succ_compose_id : (λ f : nat, f - 1) ∘ S = id. + Proof. apply FunExt. intros x. simpl. lia. Qed. + + Definition map_inner_disj `{Countable K1} `{Countable K2} {V} + (m : gmap K1 (gmap K2 V)) := + ∀ (k1 k2 : K1) (vs1 vs2 : gmap K2 V), + k1 ≠ k2 → m !! k1 = Some vs1 → m !! k2 = Some vs2 → vs1 ##ₘ vs2. + + Lemma fuel_map_le_disj ζ1 ζ2 fm fs1 fs2 ρ + (fuel_map : gmap (locale Λ) (gmap (usr_role M) nat)) : + fuel_map_le_inner fm fuel_map → map_inner_disj fuel_map → + fm !! ζ1 = Some fs1 → fm !! ζ2 = Some fs2 → + ρ ∈ dom fs1 → ρ ∈ dom fs2 → + ζ1 = ζ2 ∧ fs1 = fs2. + Proof. + intros Hle Hdisj HSome1 HSome2 [f1 Hf1]%elem_of_dom [f2 Hf2]%elem_of_dom. + destruct (decide (ζ1 = ζ2)) as [->|Hneq]. + { simplify_eq. set_solver. } + rewrite /fuel_map_le_inner map_included_spec in Hle. + apply Hle in HSome1 as (fs1'&Hfs1'&Hle1). + apply Hle in HSome2 as (fs2'&Hfs2'&Hle2). + assert (ρ ∈ dom fs1') as [??]%elem_of_dom. + { apply elem_of_dom. rewrite map_included_spec in Hle1. + by apply Hle1 in Hf1 as (?&?&?). } + assert (ρ ∈ dom fs2') as [??]%elem_of_dom. + { apply elem_of_dom. rewrite map_included_spec in Hle2. + by apply Hle2 in Hf2 as (?&?&?). } + exfalso. rewrite /map_inner_disj in Hdisj. + specialize (Hdisj ζ1 ζ2 fs1' fs2' Hneq Hfs1' Hfs2'). + rewrite map_disjoint_spec in Hdisj. by eapply Hdisj. + Qed. + + Lemma fuel_map_le_disj' ζ1 ζ2 fm fs1 fs2 fs1' fs2' ρ + (fuel_map : gmap (locale Λ) (gmap (usr_role M) nat)) : + fuel_map_le_inner fm fuel_map → map_inner_disj fuel_map → + fm !! ζ1 = Some fs1 → fm !! ζ2 = Some fs2 → + fuel_map !! ζ1 = Some fs1' → fuel_map !! ζ2 = Some fs2' → + ρ ∈ dom fs1' → ρ ∈ dom fs2' → + ζ1 = ζ2 ∧ fs1 = fs2. + Proof. + intros Hle Hdisj HSome1 HSome2 HSome1' HSome2' + [f1 Hf1]%elem_of_dom [f2 Hf2]%elem_of_dom. + destruct (decide (ζ1 = ζ2)) as [->|Hneq]. + { simplify_eq. set_solver. } + rewrite /fuel_map_le_inner map_included_spec in Hle. + exfalso. rewrite /map_inner_disj in Hdisj. + specialize (Hdisj ζ1 ζ2 fs1' fs2' Hneq HSome1' HSome2'). + rewrite map_disjoint_spec in Hdisj. by eapply Hdisj. + Qed. + + (* TODO: Clean up *) + Lemma fuel_map_le_live_roles fm fm' (lρs : gset (usr_role M)) ζ ρs ρs' ρ : + map_inner_disj fm' → fuel_map_le_inner fm fm' → + fuel_map_preserve_dead fm lρs → + fm !! ζ = Some ρs → fm' !! ζ = Some ρs' → + ρ ∈ lρs → ρ ∈ dom ρs' → + ρ ∈ dom ρs. + Proof. + intros Hdisj Hfmle Hfmdead Hρ Hρs' Hlive [f Hf]%elem_of_dom. + rewrite /fuel_map_le_inner map_included_spec in Hfmle. + apply Hfmdead in Hlive as (ζ'&fs'&Hfs'&Hv2'). + assert (dom ρs = dom fs') as Heq. + { f_equiv. pose proof Hfs' as Hfs''. apply Hfmle in Hfs'' as (fs''&?&Hfs''). + eapply (fuel_map_le_disj' ζ ζ' fm ρs fs' ρs' fs'' ρ + fm'); try done. + - rewrite /fuel_map_le_inner map_included_spec. apply Hfmle. + - by apply elem_of_dom. + - rewrite map_included_spec in Hfs''. + apply elem_of_dom in Hv2' as [? Hsome]. + apply Hfs'' in Hsome. destruct Hsome as (?&?&?). + by apply elem_of_dom. } + set_solver. + Qed. + + Lemma model_state_interp_can_fuel_step es (δ : LiveState _ _) ζ fs : + fs ≠ ∅ → model_state_interp es δ -∗ has_fuels_S ζ fs -∗ + ⌜model_can_fuel_step δ ζ ((model_update_locale_fuel δ ζ) (dom fs))⌝. + Proof. + iIntros (Hfs) "Hm Hfs". + iDestruct "Hm" as "(%fm&[%Hfmle%Hdom]&%Hfmdead&%Htp&Hm&Hfm&%Hsm)". + rewrite /model_can_fuel_step. + iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. + rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. + pose proof Hagree as Hagree'. + apply Hfmle in Hagree as [v2 [HSome Hle]]. + iPureIntro. + exists v2. exists (model_update_locale_role_map δ (dom fs) v2). + repeat split; try done. + - simpl. rewrite -alter_compose. + rewrite -alter_insert. f_equiv; [done|by rewrite insert_id]. + - assert (dom fs ⊆ dom v2). + { erewrite <-dom_fmap_L. by eapply map_included_subseteq_inv. } + rewrite -dom_empty_iff_L. + rewrite -dom_empty_iff_L in Hfs. + set_solver. + - clear Htp Hfs. pose proof δ.(ls_map_disj) as Hdisj. + apply map_included_spec. + rewrite map_included_spec in Hle. + intros k v1 Hv2. + rewrite /model_update_locale_role_map lookup_fmap in Hv2. + apply fmap_Some in Hv2 as [? [Hv2 ->]]. + pose proof Hv2 as Hv2'%map_lookup_filter_Some_1_2. simpl in *. + apply map_lookup_filter_Some_1_1 in Hv2. + assert (k ∈ dom fs) as Hv2''. + { destruct Hv2' as [Hv2'|Hv2']; [|done]. + rewrite -(dom_fmap_L S fs). + eapply (fuel_map_le_live_roles _ δ.(ls_map)); [| |done..|]. + - intros ???????. eapply Hdisj; try done. + - rewrite /fuel_map_le_inner map_included_spec. apply Hfmle. + - by apply elem_of_dom. } + rewrite -(dom_fmap_L S) in Hv2''. + apply elem_of_dom in Hv2'' as [f Heq]. + pose proof Heq as Heq'. + apply lookup_fmap_Some in Heq' as [f' [<- ?]]. + apply Hle in Heq as [f'' [Heq Hle']]. + exists f''. split; [done|]. + destruct f''; [lia|]. + simplify_eq. lia. + - rewrite /model_update_locale_role_map. + simpl. + rewrite dom_fmap_L. + clear. + induction v2 using map_ind. + { set_solver. } + rewrite /filter_fuel_map. + rewrite map_filter_insert. simpl. + case_decide. + + set_solver. + + rewrite -dom_difference_L. + rewrite map_filter_delete. + rewrite -insert_difference. + set_solver. + Qed. + + Lemma fuel_map_le_fuel_step fm ζ fs (δ:LM) : + fm !! ζ = Some (S <$> fs) → + fuel_map_le fm (ls_map δ) → + fuel_map_le (<[ζ:=fs]> fm) (ls_map (model_update_locale_fuel δ ζ (dom fs))). + Proof. + intros Hagree [Hfmle Hfmdom]. + split; [|by apply elem_of_dom_2 in Hagree; set_solver]. + rewrite /model_update_locale_fuel=> /=. + pose proof Hfmle as Hfmle'. rewrite /fuel_map_le_inner map_included_spec in Hfmle'. + apply Hfmle' in Hagree as [ρs [HSome Hρs]]. + rewrite -(insert_id (ls_map δ) ζ ρs); [|done]. + rewrite -alter_compose alter_insert=> /=. + apply map_included_insert; [|done]. + (* OBS: The remaining proof can likely be decomposed into library lemmas *) + clear Hfmle Hfmle' HSome Hfmdom. + apply map_included_spec. + intros ρ f1 Hρ. + rewrite map_included_spec in Hρs. + assert ((S <$> fs) !! ρ = Some (S f1)) as Hρ'; [by rewrite lookup_fmap Hρ|]. + specialize (Hρs ρ (S f1) Hρ') as [v2 [Hv2 Hle]]. + destruct v2; [lia|]. exists v2. split; [|lia]. + rewrite !lookup_fmap map_lookup_filter Hv2=> /=. + destruct (decide (ρ ∈ usr_live_roles (usr_state δ) ∨ ρ ∈ dom fs)) as [Hin|Hnin]. + + rewrite option_guard_True; [|done]. simpl. f_equiv. lia. + + apply Decidable.not_or in Hnin. destruct Hnin as [Hnin1 Hnin2]. + apply not_elem_of_dom in Hnin2. set_solver. + Qed. + + Lemma fuel_map_preserve_dead_fuel_step fm ζ fs (δ:LM) : + fm !! ζ = Some (S <$> fs) → + fuel_map_preserve_dead fm + (usr_live_roles $ usr_state $ model_update_locale_fuel δ ζ (dom fs)) → + fuel_map_preserve_dead (<[ζ:=fs]> fm) + (usr_live_roles $ usr_state $ (model_update_locale_fuel δ ζ (dom fs))). + Proof. + intros Hagree Hfmdead ρ Hin. apply Hfmdead in Hin as (ζ'&ρs&HSome&Hρ). + destruct (decide (ζ = ζ')) as [<-|Hneq]. + + exists ζ, fs. rewrite lookup_insert. by set_solver. + + exists ζ', ρs. rewrite lookup_insert_ne; [by set_solver|done]. + Qed. + + Lemma fuel_map_preserve_threadpool_fuel_step + act c1 ζ c2 (fm1 fm2 : gmap _ (gmap (usr_role M) nat)) : + dom fm1 = dom fm2 → locale_step c1 (inl (ζ, act)) c2 → + fuel_map_preserve_threadpool c1.1 fm1 → + fuel_map_preserve_threadpool c2.1 fm2. + Proof. + rewrite /fuel_map_preserve_threadpool. + intros Hdom Hstep Htp. intros ζ' Hζ'. destruct c1, c2. + apply locales_of_list_step_incl in Hstep. + assert (ζ' ∉ locales_of_list l) as Hζ'' by set_solver. + apply Htp in Hζ''. + rewrite -not_elem_of_dom. rewrite -not_elem_of_dom in Hζ''. + set_solver. + Qed. + + Lemma model_state_interp_fuel_update act c1 c2 (δ : LiveState _ (joint_model M Net)) ζ fs : + locale_step c1 (inl (ζ, act)) c2 → + env_states_match c2 (ls_under δ).2 → + model_state_interp c1 δ -∗ + has_fuels_S ζ fs ==∗ + model_state_interp c2 (model_update_locale_fuel δ ζ (dom fs)) ∗ + has_fuels ζ fs. + Proof. + iIntros (Hstep Hm) "Hm Hfs". + iDestruct "Hm" as "(%fm&[%Hfmle%Hdom]&%Hfmdead&%Htp&Hm&Hfm&%Hsm)". + iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. + iMod (has_fuels_decr with "Hfm Hfs") as "[Hfm $]". + iModIntro. iExists _. iFrame. iPureIntro. + split; [|split; [|split; [|done]]]. + - by apply fuel_map_le_fuel_step. + - by apply fuel_map_preserve_dead_fuel_step. + - eapply fuel_map_preserve_threadpool_fuel_step; [|done..]. + apply elem_of_dom_2 in Hagree. by set_solver. + Qed. + + Lemma model_interp_states_match c (δ : LiveState _ (joint_model M Net)) : + model_state_interp c δ -∗ ⌜ env_states_match c (ls_under δ).2 ⌝. + Proof. + by iIntros "(%fm&[%Hfmle%Hdom]&%Hfmdead&%Htp&Hm&Hfm&%Hsm)"; iPureIntro. + Qed. + + Lemma update_fuel_step extr (auxtr : auxiliary_trace LM) c2 fs ζ : + fs ≠ ∅ → + locale_step (trace_last extr) (inl (ζ, None)) c2 → + has_fuels_S ζ fs -∗ + ⌜ valid_state_evolution_fairness extr auxtr ⌝ -∗ + model_state_interp (trace_last extr) (trace_last auxtr) ==∗ + ∃ δ2, + ⌜ valid_state_evolution_fairness + (extr :tr[inl (ζ, None)]: c2) (auxtr :tr[Silent_step ζ None]: δ2) ⌝ ∗ + has_fuels ζ fs ∗ model_state_interp c2 δ2. + Proof. + iIntros (Hdom Hstep) "Hfuel %Hvse Hm". + iExists (model_update_locale_fuel (trace_last auxtr) ζ (dom fs)). + iDestruct (model_state_interp_can_fuel_step with "Hm Hfuel") as %Hcan_step; + [done|]. + iDestruct (model_interp_states_match _ _ with "Hm") as %?. + iMod (model_state_interp_fuel_update with "Hm Hfuel") as "[Hm Hfuel]"; + [done.. | by eapply env_match_internal_step|]. + iDestruct (model_state_interp_tids_smaller with "Hm") as %Htids. + iModIntro. + iFrame "Hm Hfuel". + iPureIntro. apply model_update_locale_spec=>//. + Qed. + + (** Model step *) + + (* OBS: Maybe use fuel limit instead of generic [f] *) + Program Definition model_update_set (ζ : locale Λ) (ρ : usr_role M) (f : nat) (δ : LM) : LM := + {| + ls_data := + {| ls_under := δ.(ls_under); + ls_map := alter (alter (λ _, f) ρ) ζ δ.(ls_map); |}; + |}. + Next Obligation. + intros ζ ρ f δ ζ1 ζ2 fs1 fs2 Hneq HSome1 HSome2. simpl in *. + pose proof (δ.(ls_map_disj)) as Hdisj. + apply lookup_alter_Some in HSome1. + apply lookup_alter_Some in HSome2. + destruct HSome1 as [[-> [fs1' [HSome1 ->]]]|[_ HSome1]], + HSome2 as [[-> [fs2' [HSome2 ->]]]|[_ HSome2]]; + [done| | |]. + - specialize (Hdisj ζ1 ζ2 _ _ Hneq HSome1 HSome2). + rewrite map_disjoint_dom dom_alter_L. + rewrite map_disjoint_dom in Hdisj. set_solver. + - specialize (Hdisj ζ1 ζ2 _ _ Hneq HSome1 HSome2). + rewrite map_disjoint_dom dom_alter_L. + rewrite map_disjoint_dom in Hdisj. set_solver. + - by eapply Hdisj. + Qed. + Next Obligation. + intros ζ ρ f δ ρ' Hρ'. simpl in *. + pose proof (δ.(ls_map_live)) as Hlive. + apply Hlive in Hρ' as (ζ'&fs'&HSome&Hρ'). + destruct (decide (ζ = ζ')) as [<-|Hneq]. + - eexists ζ, _. rewrite lookup_alter HSome. split; [done|]. + by rewrite dom_alter_L. + - eexists ζ', _. by rewrite lookup_alter_ne. + Qed. + + Definition model_update_state (δ2 : joint_model M Net) (δ1 : LiveStateData Λ (joint_model M Net)) : + LiveStateData Λ _ := + {| ls_under := δ2; + ls_map := δ1.(ls_map); |}. + + Lemma model_update_state_valid (δ2 : joint_model M Net) (δ1 : LM) : + usr_live_roles δ2.1 ⊆ usr_live_roles (usr_state δ1) → + ∃ δ, (ls_data δ) = model_update_state δ2 δ1. + Proof. + intros Hle. + assert (∀ ζ ζ' fs fs', + ζ ≠ ζ' → (model_update_state δ2 δ1).(ls_map) !! ζ = Some fs → + (model_update_state δ2 δ1).(ls_map) !! ζ' = Some fs' → fs ##ₘ fs') as Hdisj'. + { intros. by eapply (δ1.(ls_map_disj)). } + assert (∀ ρ, ρ ∈ usr_live_roles $ usr_state (model_update_state δ2 δ1) → + ∃ ζ fs, (model_update_state δ2 δ1).(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs) as Hlive'. + { pose proof (δ1.(ls_map_live)) as Hlive. + intros. + assert (ρ ∈ usr_live_roles (usr_state δ1)) as Hin by set_solver. + apply Hlive in Hin as (?&?&?&?). eexists _, _. done. } + exists + {| ls_data := model_update_state δ2 δ1; + ls_map_disj := Hdisj'; + ls_map_live := Hlive' |}. + done. + Qed. + + Definition model_update_model_step + (ζ : locale Λ) (ρs : gset (usr_role M)) ρ δ2 (δ : LM) := + model_update_state δ2 $ model_update_set ζ ρ (fm_fl δ2) $ model_update_decr ζ $ model_update_filter ζ ρs δ. + + Lemma model_update_model_step_valid (ζ : locale Λ) (ρs : gset (usr_role M)) ρ s2 (δ1:LM) : + usr_live_roles s2.1 ⊆ usr_live_roles (usr_state δ1) → + ∃ δ, (ls_data δ) = model_update_model_step ζ ρs ρ s2 δ1. + Proof. intros. by apply model_update_state_valid. Qed. + + Lemma model_update s1 s2 s3 : + auth_model_is s1 -∗ frag_model_is s2 ==∗ + auth_model_is s3 ∗ frag_model_is s3. + Proof. + iIntros "Hauth Hfrag". + iMod (own_update_2 with "Hauth Hfrag") as "[$ $]"; [|done]. + apply auth_update. apply option_local_update. + by eapply exclusive_local_update. + Qed. + + Lemma alter_insert_alt `{Countable K} {A} (m : gmap K A) i f x : + m !! i = Some x → alter f i m = <[i := f x]> m. + Proof. + intros. rewrite -{1}(insert_id m i x); [|done]. apply alter_insert. + Qed. + + (* OBS: Need to make frag model abstract *) + Lemma model_state_interp_model_step_update (ρ : usr_role M) + fmact act + (fs : gmap (usr_role M) nat) tp1 tp2 + (δ δ2 : LM) ζ σ1 σ2 (f1 : nat) (s1 s2 : joint_model M Net) : + ρ ∉ dom fs → + usr_live_roles s2.1 ⊆ usr_live_roles s1.1 → + locale_step (tp1, σ1) (inl (ζ, act)) (tp2, σ2) → + env_states_match (tp2, σ2) (ls_under δ2).2 → + fmtrans _ s1 (inl (ρ, fmact)) s2 → + (ls_data δ2) = model_update_model_step ζ ({[ρ]} ∪ dom fs) ρ s2 δ → + model_state_interp (tp1, σ1) δ -∗ + has_fuels ζ ({[ρ := f1]} ∪ (S <$> fs)) -∗ + frag_model_is s1.1 ==∗ + model_state_interp (tp2, σ2) δ2 ∗ + has_fuels ζ ({[ρ := fm_fl s2]} ∪ fs) ∗ + frag_model_is s2.1. + Proof. + iIntros (Hfs Hlive Hstep Hsm2 Hmstep Hδ2) "Hm Hf Hs". + iDestruct "Hm" as "(%fm&%Hfmle&%Hfmdead&%Htp&Hm&Hfm&%Hsm1)". + iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. + iMod (has_fuels_update _ _ _ ({[ρ := fm_fl s2]} ∪ fs) with "Hfm Hf") + as "[Hfm Hf]". + iDestruct (model_agree with "Hm Hs") as %Heq. + iMod (model_update _ _ s2.1 with "Hm Hs") as "[Hm Hs]". + iModIntro. iFrame. iExists _. iFrame. + rewrite Hδ2. iFrame. + iPureIntro. + split; [|split; [|split]]. + - split; last first. + { simpl. + destruct Hfmle as [Hfmle Hdom]. + pose proof Hfmle as Hfmle'. + rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. + pose proof Hagree as Hagree'. + apply Hfmle in Hagree' as (fs'&HSome&Hfs'). + rewrite -(insert_id (ls_map δ) ζ fs'); [|done]. + rewrite !alter_insert. + set_solver. } + simpl. + destruct Hfmle as [Hfmle Hdom]. + pose proof Hfmle as Hfmle'. + rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. + pose proof Hagree as Hagree'. + apply Hfmle in Hagree' as (fs'&HSome&Hfs'). + rewrite -(insert_id (ls_map δ) ζ fs'); [|done]. + rewrite !alter_insert. + apply map_included_insert; [|done]. + assert ({[ρ := usr_fl s2.1]} ∪ fs = + (alter (λ _ : nat, fm_fl s2) ρ + ((λ f : nat, f - 1) <$> + (filter + (λ ρf : usr_role M * nat, ρf.1 ∈ usr_live_roles (usr_state δ) ∨ ρf.1 ∈ {[ρ]} ∪ dom fs) + ({[ρ := f1]} ∪ (S <$> fs)))))) as ->. + { rewrite -!insert_union_singleton_l. + rewrite map_filter_insert. simpl. + case_decide; [|set_solver]. + rewrite fmap_insert. rewrite alter_insert. f_equiv. + rewrite map_filter_fmap. + rewrite -map_fmap_compose. + rewrite decr_succ_compose_id. + rewrite map_fmap_id. + rewrite map_filter_id; [done|]. + intros i x Hin. apply elem_of_dom_2 in Hin. set_solver. } + apply map_included_mono_strong; [set_solver..| |]. + { intros k x1 x2 y1 y2 Hx1 Hx2 Hy1 Hy2 HR. + destruct (decide (k = ρ)) as [->|Hneq]. + - erewrite alter_insert_alt in Hy1; [|done]. + erewrite alter_insert_alt in Hy2; [|done]. + rewrite lookup_insert in Hy1. + rewrite lookup_insert in Hy2. by simplify_eq. + - rewrite lookup_alter_ne in Hy1; [|done]. + rewrite lookup_alter_ne in Hy2; [|done]. + by simplify_eq. } + apply map_included_mono_strong; [set_solver..| |]. + { intros k x1 x2 y1 y2 Hx1 Hx2 Hy1 Hy2 HR. + apply lookup_fmap_Some in Hy1 as (y1'&Hy1'&Hy1). + apply lookup_fmap_Some in Hy2 as (y2'&Hy2'&Hy2). + simplify_eq. lia. } + apply map_included_filter; [set_solver..|]. + done. + - apply elem_of_subseteq in Hlive. + intros ρ' Hin. + apply Hlive in Hin. + rewrite Heq in Hfmdead. + apply Hfmdead in Hin as (ζ'&ρs&HSome&Hρ). + destruct (decide (ζ = ζ')) as [<-|Hneq]. + + eexists ζ, _. rewrite lookup_insert. split; [done|]. by set_solver. + + eexists ζ', _. rewrite lookup_insert_ne; [|done]. + split; [done|]. by set_solver. + - rewrite /fuel_map_preserve_threadpool. + intros ζ' Hζ'. + apply locales_of_list_step_incl in Hstep. + assert (ζ' ∉ locales_of_list tp1) as Hζ'' by set_solver. + apply Htp in Hζ''. + rewrite -not_elem_of_dom. rewrite -not_elem_of_dom in Hζ''. + rewrite dom_insert_L. + rewrite -(insert_id fm ζ ({[ρ := f1]} ∪ (S <$> fs))) in Hζ''; [|done]. + rewrite dom_insert_L in Hζ''. + set_solver. + - rewrite Hδ2 // in Hsm2. + Qed. + + Lemma model_step_suff_data_weak_alt (δ1 δ2 : LiveState Λ (joint_model M Net)) ρ fmact act + (fs fs': gmap _ nat) ζ : + fmtrans _ δ1 (inl (ρ, fmact)) δ2 → + usr_live_roles (usr_state δ2) ⊆ usr_live_roles (usr_state δ1) → + δ1.(ls_map) !! ζ = Some fs → + δ2.(ls_map) = <[ζ := fs']> δ1.(ls_map) → + ρ ∈ dom fs → + fs' !! ρ = Some (fm_fl (ls_under δ2)) → + map_included (<) (delete ρ fs') fs → + (dom fs ∖ dom fs' ∩ usr_live_roles (usr_state δ1) = ∅) → + ls_trans fm_fl δ1 (Take_step ρ fmact ζ act) δ2. + Proof. + intros Hstep Hlive Hfs Hfs' Hρ Hρ' Hlt Hlive'. + assert (∃ (δ'': LiveState Λ _), δ''.(ls_data) = + {| ls_under := ls_under δ2; + ls_map := <[ζ := fs']> δ1.(ls_map) |} ∧ + ls_trans fm_fl δ1 (Take_step ρ fmact ζ act) δ'') as (δ''&Heq&Htrans). + { eapply (model_step_suff_data); try done. + - rewrite map_included_spec in Hlt. + intros ρ' f f' Hf' Hneq Hf. + rewrite -(lookup_delete_ne _ ρ ρ') in Hf'; [|done]. + apply Hlt in Hf' as (?&?&?). by simplify_eq. + - set_solver. + - apply map_included_subseteq_inv in Hlt. set_solver. + - apply map_included_subseteq_inv in Hlt. set_solver. + - set_solver. } + rewrite Heq -Hfs' in Htrans. by destruct δ2, ls_data. + Qed. + + Definition model_can_model_step (δ1 : LM) (ζ : locale Λ) (ρ : usr_role M) (δ2 : LM) fmact : Prop := + ∃ (fs fs' : gmap (usr_role M) nat), + fmtrans _ δ1 (inl (ρ, fmact)) δ2 ∧ + usr_live_roles (usr_state δ2) ⊆ usr_live_roles (usr_state δ1) ∧ + δ1.(ls_map) !! ζ = Some fs ∧ + δ2.(ls_map) = <[ζ := fs']> δ1.(ls_map) ∧ + ρ ∈ dom fs ∧ + fs' !! ρ = Some (fm_fl (ls_under δ2)) ∧ + map_included (<) (delete ρ fs') fs ∧ + (dom fs ∖ dom fs' ∩ usr_live_roles (usr_state δ1) = ∅). + + Lemma model_can_model_step_trans ζ (ρ : fmrole (joint_model M Net)) + (δ δ' : LiveState Λ (joint_model M Net)) fmact act: + model_can_model_step δ ζ ρ δ' fmact → ls_trans fm_fl δ (Take_step ρ fmact ζ act) δ'. + Proof. + destruct 1 as (?&?&?&?&?&?&?&?&?&?). + by eapply model_step_suff_data_weak_alt. + Qed. + + Lemma model_state_interp_can_model_step es (δ δ2 : LM) ζ ρ f fmact + (fs : gmap (usr_role M) nat) (s1 s2 : joint_model M Net) : + fmtrans _ s1 (inl (ρ, fmact)) s2 → + usr_live_roles s2.1 ⊆ usr_live_roles s1.1 → + ρ ∉ dom fs → + env_state δ = s1.2 → + (ls_data δ2) = model_update_model_step ζ ({[ρ]} ∪ dom fs) ρ s2 δ → + model_state_interp es δ -∗ + has_fuels ζ ({[ρ := f]} ∪ (S <$> fs)) -∗ + frag_model_is s1.1 -∗ + ⌜model_can_model_step δ ζ ρ δ2 fmact⌝. + Proof. + iIntros (Hstep Hle Hρ Henv Hδ2) "Hm Hf Hδ". + iDestruct "Hm" as "(%fm&%Hfmle&%Hfmdead&%Htp&Hm&Hfm&%Hsm)". + iDestruct (model_agree with "Hm Hδ") as %Heq. + have Heq': δ.(ls_under) = s1. + { destruct δ as [[[??] ?] ]. simpl in *. + rewrite /usr_state /= in Heq. rewrite /env_state /= in Henv. + rewrite Henv Heq. by destruct s1. } + iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. + iPureIntro. + rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. + pose proof Hagree as Hagree'. + apply Hfmle in Hagree as (fs'&Hζ&Hfs'). + assert (ρ ∈ dom fs') as Hρ'. + { apply map_included_subseteq_inv in Hfs'. set_solver. } + eexists _, _. repeat split; try done. + - rewrite Hδ2 Heq' //. + - rewrite !Heq Hδ2 //. + - rewrite Hδ2. simpl. rewrite -!alter_compose. + rewrite -{1}(insert_id (ls_map δ) ζ fs'); [|done]. + rewrite alter_insert. + f_equiv. + done. + - rewrite Hδ2. simpl. rewrite lookup_alter. rewrite lookup_fmap. + apply elem_of_dom in Hρ' as [f' Hlk]. + rewrite map_lookup_filter. + rewrite Hlk. simpl. + rewrite option_guard_True; [done|]. + set_solver. + - rewrite map_included_spec. + intros ρ' f' HSome. + assert (ρ ≠ ρ'). + { intros Heqρ. rewrite Heqρ in HSome. + by rewrite lookup_delete in HSome. } + rewrite lookup_delete_ne in HSome; [|done]. + exists (f' + 1). + split; [|lia]. + simpl in *. + rewrite lookup_alter_ne in HSome; [|done]. + rewrite lookup_fmap in HSome. + rewrite map_lookup_filter in HSome. simpl in *. + destruct (fs' !! ρ') eqn:Heqn; [|done]. + simpl in *. + destruct (decide (ρ' ∈ usr_live_roles (usr_state δ) ∨ ρ' ∈ {[ρ]} ∪ dom fs)) as [Hin|Hnin]. + + rewrite option_guard_True in HSome; [|done]. + simpl in *. simplify_eq. f_equiv. + assert (ρ' ∈ dom ({[ρ := f]} ∪ (S <$> fs))) as Hin'. + { destruct Hin as [Hin|Hin]; [|set_solver]. + eapply (fuel_map_le_live_roles _ δ.(ls_map)); [| |done..|]. + - intros ???????. by eapply δ.(ls_map_disj). + - rewrite /fuel_map_le_inner map_included_spec. apply Hfmle. + - by apply elem_of_dom. } + rewrite dom_union_L in Hin'. + apply elem_of_union in Hin' as [Hin'|Hin']; [set_solver|]. + apply elem_of_dom in Hin' as [v2 Hv2]. + rewrite map_included_spec in Hfs'. + specialize (Hfs' ρ' v2). + rewrite lookup_union_r in Hfs'; [|by rewrite lookup_insert_ne]. + destruct v2. + { apply lookup_fmap_Some in Hv2 as (?&?&?). lia. } + apply Hfs' in Hv2 as (n'&Hn'&Hn''). + simplify_eq. + lia. + + by rewrite option_guard_False in HSome. + - (* TODO: Make a lemma for this *) + simpl. + rewrite dom_alter_L. + rewrite dom_fmap_L. + clear. + induction fs' using map_ind. + { set_solver. } + rewrite /filter_fuel_map. + rewrite map_filter_insert. simpl. + case_decide. + + set_solver. + + rewrite -dom_difference_L. + rewrite map_filter_delete. + rewrite -insert_difference. + set_solver. + Qed. + + Lemma model_update_locale_spec_model_step `{!LiveModelEq LM} + extr + (auxtr : auxiliary_trace LM) ζ c2 ρs (ρ : fmrole (joint_model M Net)) δ2 s2 act : + (ls_data δ2) = model_update_model_step ζ ({[ρ]} ∪ ρs) ρ s2 + (trace_last auxtr) → + model_can_model_step (trace_last auxtr) ζ ρ δ2 act → + valid_state_evolution_fairness extr auxtr → + tids_smaller c2.1 δ2 → + valid_state_evolution_fairness + (extr :tr[inl (ζ, act)]: c2) + (auxtr :tr[Take_step ρ act ζ act]: δ2). + Proof. + intros Hstep Htids Hvse ?. destruct c2. + destruct Hvse as (?&?&?). + split; [| split]=>//. + econstructor=>//; first by apply model_can_model_step_trans. + rewrite /trace_labels_match /labels_match. + do 2 split=>//. by apply actions_match_is_eq. + Qed. + + Lemma update_model_step `{!LiveModelEq LM} + (extr : execution_trace Λ) + (auxtr: auxiliary_trace LM) c2 (s1 s2 : joint_model M Net) fs ρ (δ1 : LM) ζ f act : + usr_live_roles s2.1 ⊆ usr_live_roles s1.1 → + ρ ∉ dom fs → + trace_last auxtr = δ1 → + locale_step (trace_last extr) (inl (ζ, act)) c2 → + env_states_match c2 s2.2 → + fmtrans _ s1 (inl (ρ, act)) s2 → + env_state δ1 = s1.2 → + has_fuels ζ ({[ρ := f]} ∪ (S <$> fs)) -∗ frag_model_is s1.1 -∗ + ⌜valid_state_evolution_fairness extr auxtr⌝ -∗ + model_state_interp (trace_last extr) δ1 ==∗ + ∃ (δ2: LM), + ⌜valid_state_evolution_fairness + (extr :tr[inl (ζ, act)]: c2) (auxtr :tr[Take_step ρ act ζ act]: δ2)⌝ ∗ + has_fuels ζ ({[ρ := fm_fl s2]} ∪ fs) ∗ + frag_model_is s2.1 ∗ model_state_interp c2 δ2. + Proof. + iIntros (Hlive Hdom Hlast Hstep Hcfg Htrans Henv) "Hfuel Hfrag %Hvse Hm". + iDestruct (model_agree' with "Hm Hfrag") as %Heq. + pose proof (model_update_model_step_valid + ζ ({[ρ]} ∪ dom fs) ρ s2 δ1) as [δ2 Hδ2]. + { rewrite /usr_state Heq //. } + iExists δ2. + iDestruct (model_state_interp_can_model_step with "Hm Hfuel Hfrag") + as %Hcan_step; [try done..|]. + destruct (trace_last extr), c2. + iMod (model_state_interp_model_step_update with "Hm Hfuel Hfrag") + as "(Hm&Hf&Hfrag)"; [try done..|]. + { rewrite Hδ2 //=. } + iDestruct (model_state_interp_tids_smaller with "Hm") as %Htids. + iModIntro. + iFrame "Hm Hf Hfrag". + iPureIntro. subst. + eapply model_update_locale_spec_model_step=>//. + Qed. + + (** Fork step *) + + Definition has_forked (tp1 tp2 : list (expr Λ)) e : Prop := + ∃ tp1', tp2 = tp1' ++ [e] ∧ locales_equiv tp1 tp1'. + + Definition model_update_split + (ζ ζf : locale Λ) (ρs : gset (usr_role M)) + (δ : LiveStateData Λ (joint_model M Net)) : LiveStateData Λ _ := + {| ls_under := δ.(ls_under); + ls_map := <[ζf := (filter (λ ρf, ρf.1 ∈ ρs)) (δ.(ls_map) !!! ζ)]> + (alter (filter (λ ρf, ρf.1 ∉ ρs)) ζ δ.(ls_map)); |}. + + Definition map_live (ρs : gset (usr_role M)) + (m : gmap (locale Λ) (gmap (usr_role M) nat)) : Prop := + ∀ ρ, ρ ∈ ρs → ∃ ζ fs, m !! ζ = Some fs ∧ ρ ∈ dom fs. + + Lemma disjoint_subseteq `{Countable A} (xs1 xs2 ys1 ys2 : gset A) : + xs1 ⊆ xs2 → ys1 ⊆ ys2 → xs2 ## ys2 → xs1 ## ys1. + Proof. + intros Hle1 Hle2 Hdisj x Hxs Hys. + eapply Hdisj; [by apply Hle1|by apply Hle2]. + Qed. + + Lemma disjoint_subseteq_l `{Countable A} (xs ys zs : gset A) : + xs ⊆ ys → ys ## zs → xs ## zs. + Proof. intros Hle Hdisj x Hxs Hzs. eapply Hdisj; [by apply Hle|done]. Qed. + + Lemma disjoint_subseteq_r `{Countable A} (xs ys zs : gset A) : + zs ⊆ ys → xs ## ys → xs ## zs. + Proof. intros Hle Hdisj x Hxs Hzs. eapply Hdisj; [done|by apply Hle]. Qed. + + Lemma model_update_split_valid ζ ζf ρs (δ1 : LM) : + ζ ∈ dom δ1.(ls_map) → ζf ∉ dom δ1.(ls_map) → + ∃ δ2, (ls_data δ2) = model_update_split ζ ζf ρs δ1. + Proof. + intros [ρs' HSome]%elem_of_dom Hnin. + set δ2 := model_update_split ζ ζf ρs δ1. + assert (ζ ≠ ζf) as Hneq. + { intros ->. apply not_elem_of_dom in Hnin. set_solver. } + assert (map_inner_disj δ2.(ls_map)) as Hdisj. + { simpl. + pose proof δ1.(ls_map_disj) as Hdisj. + intros ζ1 ζ2 ρs1 ρs2 Hneq' HSome1 HSome2. + destruct (decide (ζf = ζ1)) as [<-|Hneqf1]. + { rewrite lookup_insert in HSome1. + rewrite lookup_insert_ne in HSome2; [|done]. + rewrite lookup_total_alt in HSome1. + rewrite HSome in HSome1. + simpl in *. + destruct (decide (ζ = ζ2)) as [<-|Hneq2]. + { rewrite lookup_alter in HSome2. + rewrite HSome in HSome2. simpl in *. simplify_eq. + apply map_disjoint_dom. + pose proof (disjoint_filter_complement + (λ ρ : usr_role M, ρ ∈ ρs) (dom ρs')) as Hcomp. + by rewrite !filter_dom_L in Hcomp. } + rewrite lookup_alter_ne in HSome2; [|done]. + simplify_eq. + apply map_disjoint_dom. + pose proof (Hdisj ζ ζ2 _ _ Hneq2 HSome HSome2) as Hdisj. + apply map_disjoint_dom in Hdisj. + eapply disjoint_subseteq_l; [|done]. + apply dom_filter_subseteq. } + rewrite lookup_insert_ne in HSome1; [|done]. + destruct (decide (ζf = ζ2)) as [<-|Hneqf2]. + { rewrite lookup_insert in HSome2. + destruct (decide (ζ = ζ1)) as [<-|Hneq2]. + { rewrite lookup_alter in HSome1. + rewrite lookup_total_alt in HSome2. + rewrite HSome in HSome1. + rewrite HSome in HSome2. + simpl in *. simplify_eq. + apply map_disjoint_dom. + pose proof (disjoint_filter_complement + (λ ρ : usr_role M, ρ ∈ ρs) (dom ρs')) as Hcomp. + by rewrite !filter_dom_L in Hcomp. } + rewrite lookup_alter_ne in HSome1; [|done]. + rewrite lookup_total_alt in HSome2. + rewrite HSome in HSome2. + simpl in *. simplify_eq. + pose proof (Hdisj ζ ζ1 _ _ Hneq2 HSome HSome1) as Hdisj. + apply map_disjoint_dom. + apply map_disjoint_dom in Hdisj. + eapply disjoint_subseteq_r; [|done]. + apply dom_filter_subseteq. } + destruct (decide (ζ = ζ1)) as [<-|Hneq1]. + { rewrite lookup_alter in HSome1. + rewrite lookup_insert_ne in HSome2; [|done]. + rewrite lookup_alter_ne in HSome2; [|done]. + rewrite HSome in HSome1. + simpl in *. simplify_eq. + pose proof (Hdisj ζ ζ2 _ _ Hneq' HSome HSome2) as Hdisj. + apply map_disjoint_dom. + apply map_disjoint_dom in Hdisj. + eapply disjoint_subseteq_l; [|done]. + apply dom_filter_subseteq. } + destruct (decide (ζ = ζ2)) as [<-|Hneq2]. + { rewrite lookup_alter_ne in HSome1; [|done]. + rewrite lookup_insert_ne in HSome2; [|done]. + rewrite lookup_alter in HSome2. + rewrite HSome in HSome2. + simpl in *. simplify_eq. + pose proof (Hdisj ζ ζ1 _ _ Hneq1 HSome HSome1) as Hdisj. + apply map_disjoint_dom. + apply map_disjoint_dom in Hdisj. + eapply disjoint_subseteq_r; [|done]. + apply dom_filter_subseteq. } + rewrite lookup_alter_ne in HSome1; [|done]. + rewrite lookup_insert_ne in HSome2; [|done]. + rewrite lookup_alter_ne in HSome2; [|done]. + pose proof (Hdisj ζ1 ζ2 _ _ Hneq' HSome1 HSome2). + done. } + assert (map_live (usr_live_roles (usr_state δ2)) δ2.(ls_map)) as Hlive. + { intros ρ Hin. + pose proof (δ1.(ls_map_live)) as Hlive. + apply Hlive in Hin as (ζ'&fs&HSome'&Hin'). + destruct (decide (ζ' = ζf)) as [->|Hneqf]. + { apply not_elem_of_dom in Hnin. set_solver. } + destruct (decide (ζ' = ζ)) as [->|Hneq']. + { rewrite HSome in HSome'. simplify_eq. + simpl. + destruct (decide (ρ ∈ ρs)) as [Hin|Hnin']. + - exists ζf, (filter (λ ρf : usr_role M * nat, ρf.1 ∈ ρs) fs). + rewrite lookup_insert. rewrite lookup_total_alt. rewrite HSome. simpl. + split; [done|]. + apply elem_of_dom. rewrite /is_Some. + apply elem_of_dom in Hin' as [??]. + eexists _. by apply map_lookup_filter_Some_2. + - exists ζ, (filter (λ ρf : usr_role M * nat, ρf.1 ∉ ρs) fs). + rewrite lookup_insert_ne; [|done]. + rewrite lookup_alter. rewrite HSome. simpl. + split; [done|]. + apply elem_of_dom. rewrite /is_Some. + apply elem_of_dom in Hin' as [??]. + eexists _. by apply map_lookup_filter_Some_2. } + exists ζ', fs. split; [|done]. + simpl. rewrite !lookup_insert_ne; [|done]. + rewrite lookup_alter_ne; [|done]. + done. } + by exists + {| ls_data := δ2; + ls_map_disj := Hdisj; + ls_map_live := Hlive |}. + Qed. + + Definition model_update_fork + (ζ : locale Λ) (ζf : locale Λ) + (ρs1 ρs2 : gset (usr_role M)) (δ : LM) : + LiveStateData Λ _ := + model_update_split ζ ζf ρs2 $ + model_update_decr ζ $ + model_update_filter ζ ρs1 δ. + + Lemma model_update_fork_valid + ζ ζf (ρs1 ρs2 : gset (usr_role M)) (δ1 : LM) : + ζ ∈ dom δ1.(ls_map) → ζf ∉ dom δ1.(ls_map) → + ∃ δ2, (ls_data δ2) = model_update_fork ζ ζf ρs1 ρs2 δ1. + Proof. intros ??. by apply model_update_split_valid; set_solver. Qed. + + Lemma has_fuels_alloc fm ζ fs : + ζ ∉ dom fm → + auth_fuel_mapping_is fm ==∗ + auth_fuel_mapping_is (<[ζ := fs]>fm) ∗ has_fuels ζ fs. + Proof. + iIntros (Hnin) "Hfm". + rewrite /has_fuels_S. + iMod (own_update with "Hfm") as "[$ $]"; [|done]. + apply auth_update_alloc. + rewrite !fmap_insert. + rewrite !fmap_empty. + eapply alloc_local_update; [|done]. + apply not_elem_of_dom in Hnin. by rewrite lookup_fmap Hnin. + Qed. + + Lemma has_fuels_split fm ζ ζf fs1 fs2 : + ζf ∉ dom fm → fs1 ##ₘ fs2 → + auth_fuel_mapping_is fm -∗ has_fuels ζ (fs1 ∪ fs2) ==∗ + auth_fuel_mapping_is (<[ζf := fs2]>(<[ζ := fs1]>fm)) ∗ + has_fuels ζ fs1 ∗ has_fuels ζf fs2. + Proof. + iIntros (Hnin Hdisj) "Hfm Hfs". + iDestruct (has_fuels_agree with "Hfm Hfs") as %HSome. + assert (ζ ≠ ζf) as Hneq. + { rewrite not_elem_of_dom in Hnin. set_solver. } + iMod (has_fuels_update with "Hfm Hfs") as "[Hfm $]". + iMod (has_fuels_alloc with "Hfm") as "[$$]"; set_solver. + Qed. + + Lemma not_elem_of_locale_of_from_list (tp : list $ expr Λ) e : + locale_of tp e ∉ locales_of_list tp. + Proof. + unfold locales_of_list_from. + intros Habs. + apply elem_of_list_fmap in Habs as ((tp1&e1) & Hlo & Hpf). + apply (prefixes_from_spec [] tp e1 tp1) in Hpf as (tp2&tp3&He1&He2). + simplify_eq. + list_simplifier. + + have Hdone: (tp2 ++ e1 :: tp3, e) ∈ prefixes_from (tp2++[e1]) (tp3 ++ [e]). + { apply prefixes_from_spec. eexists _, _. list_simplifier. naive_solver. } + by apply locale_injective in Hdone. + Qed. + + Lemma elem_of_locale_of_from_list (tp1 tp2 : list $ expr Λ) e : + locales_equiv tp1 tp2 → + locale_of tp1 e ∈ locales_of_list (tp2++[e]). + Proof. + intros Heq. rewrite (locale_equiv _ _ _ Heq) /locales_of_list_from. + apply elem_of_list_fmap. exists (tp2, e). split=>//. + apply prefixes_from_spec. eexists _, _. list_simplifier. naive_solver. + Qed. + + Lemma model_state_interp_fork_update fs1 fs2 tp1 tp2 + (δ1 δ2 : LM) ζ efork σ1 σ2 : + (ls_data δ2) = model_update_fork ζ (locale_of tp1 efork) (dom fs1 ∪ dom fs2) (dom fs2) δ1 → + fs1 ∪ fs2 ≠ ∅ → fs1 ##ₘ fs2 → + has_forked tp1 tp2 efork → + locale_step (tp1, σ1) (inl (ζ, None)) (tp2, σ2) → + model_state_interp (tp1, σ1) δ1 -∗ + has_fuels_S ζ (fs1 ∪ fs2) ==∗ + model_state_interp (tp2, σ2) δ2 ∗ + has_fuels ζ fs1 ∗ + has_fuels (locale_of tp1 efork) fs2. + Proof. + iIntros (Hδ2 Hfs Hdisj Hforked Hstep) "Hm Hf". + iDestruct "Hm" as "(%fm&%Hfmle&%Hfmdead&%Htp&Hm&Hfm&%Hsm1)". + iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. + assert (locale_of tp1 efork ∉ dom fm) as Hnin. + { pose proof (not_elem_of_locale_of_from_list tp1 efork) as Hes%Htp. + apply not_elem_of_dom in Hes. set_solver. } + assert (ζ ≠ locale_of tp1 efork) as Hneq. + { rewrite not_elem_of_dom in Hnin. set_solver. } + iMod (has_fuels_decr with "Hfm Hf") as "[Hfm Hf]". + iMod (has_fuels_split _ _ (locale_of tp1 efork) with "Hfm Hf") + as "[Hfm [Hf1 Hf2]]"; [|done|]. + { set_solver. } + iModIntro. iFrame. iExists _. iFrame. rewrite Hδ2. iFrame. + iPureIntro. + split; [|split; [| split]]. + - split; last first. + { simpl. + destruct Hfmle as [Hfmle Hdom]. + pose proof Hfmle as Hfmle'. + rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. + pose proof Hagree as Hagree'. + apply Hfmle in Hagree' as (fs'&HSome&Hfs'). + rewrite -(insert_id (ls_map δ1) ζ fs'); [|done]. + rewrite !alter_insert. + set_solver. } + simpl. + destruct Hfmle as [Hfmle Hdom]. + pose proof Hfmle as Hfmle'. + rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. + pose proof Hagree as Hagree'. + apply Hfmle in Hagree' as (fs'&HSome&Hfs'). + rewrite -(insert_id (ls_map δ1) ζ fs'); [|done]. + rewrite !alter_insert. + rewrite insert_insert. + + apply map_included_map_agree_R in Hfs' + as (fs12'&fsf'&->&Hdisj'&Hfs'). + pose proof Hfs' as Hfs''. + apply map_agree_R_fmap_inv in Hfs'' as [fs1'' ->]; last first. + { intros ?[]?; [lia|by eauto]. } + apply map_agree_R_fmap in Hfs'; last first. + { intros. lia. } + apply map_agree_R_union_inv in Hfs' + as (fs1'&fs2'&->&Hfs1'&Hfs2'); [|done]. + + apply map_included_insert. + { rewrite lookup_total_alt. + rewrite lookup_insert. + rewrite map_filter_fmap. + rewrite map_filter_filter. + rewrite map_fmap_union. + rewrite map_filter_union; last first. + { apply map_disjoint_dom. apply map_disjoint_dom in Hdisj'. + set_solver. } + rewrite map_filter_union; last first. + { apply map_disjoint_dom. apply map_disjoint_dom in Hdisj. + apply map_agree_R_dom in Hfs1'. + apply map_agree_R_dom in Hfs2'. + set_solver. } + rewrite !map_fmap_union. + eapply map_included_subseteq_r. + { apply map_union_subseteq_l. } + eapply map_included_subseteq_r. + { apply map_union_subseteq_r. + apply map_disjoint_dom. + rewrite !map_filter_fmap. rewrite !dom_fmap_L. + apply map_disjoint_dom in Hdisj. + apply map_agree_R_dom in Hfs1'. + apply map_agree_R_dom in Hfs2'. + eapply disjoint_subseteq_l; [apply dom_filter_subseteq|]. + eapply disjoint_subseteq_r; [apply dom_filter_subseteq|]. + set_solver. } + rewrite map_filter_id; last first. + { simpl. intros ? ? Hlk. apply elem_of_dom_2 in Hlk. + apply map_agree_R_dom in Hfs1'. + apply map_agree_R_dom in Hfs2'. + split; [set_solver|]. + set_solver. } + rewrite -map_fmap_compose. + rewrite decr_succ_compose_id. rewrite map_fmap_id. + by apply map_agree_R_map_included. } + + apply map_included_insert; [|done]. + rewrite map_filter_fmap. + rewrite map_filter_filter. + + rewrite !map_fmap_union. + rewrite map_filter_union; last first. + { apply map_disjoint_dom. apply map_disjoint_dom in Hdisj'. + set_solver. } + rewrite map_filter_union; last first. + { apply map_disjoint_dom. apply map_disjoint_dom in Hdisj. + apply map_agree_R_dom in Hfs1'. + apply map_agree_R_dom in Hfs2'. + set_solver. } + rewrite !map_fmap_union. + eapply map_included_subseteq_r. + { apply map_union_subseteq_l. } + eapply map_included_subseteq_r. + { apply map_union_subseteq_l. } + + rewrite map_filter_id; last first. + { simpl. intros ?? Hlk. apply elem_of_dom_2 in Hlk. + apply map_agree_R_dom in Hfs1'. + apply map_agree_R_dom in Hfs2'. + rewrite dom_fmap in Hlk. + apply map_disjoint_dom in Hdisj. + split; [set_solver|]. + set_solver. } + rewrite -map_fmap_compose. + rewrite decr_succ_compose_id. rewrite map_fmap_id. + by apply map_agree_R_map_included. + - intros ρ' Hin. + apply Hfmdead in Hin as (ζ'&ρs&HSome&Hρ). + destruct (decide (ζ = ζ')) as [<-|Hneq']. + + rewrite Hagree in HSome. + simplify_eq. + rewrite dom_fmap_L in Hρ. + rewrite dom_union_L in Hρ. + apply elem_of_union in Hρ. + destruct Hρ as [Hρ|Hρ]. + * eexists ζ, _. rewrite insert_insert. + rewrite insert_commute; [|done]. + rewrite lookup_insert. done. + * eexists (locale_of tp1 efork), _. rewrite insert_insert. + rewrite lookup_insert. done. + + assert (ζ' ≠ locale_of tp1 efork) as Hneq''. + { intros ->. apply not_elem_of_dom in Hnin. set_solver. } + eexists ζ', _. + rewrite lookup_insert_ne; [|done]. + rewrite insert_insert. + rewrite lookup_insert_ne; [|done]. + split; [done|]. by set_solver. + - rewrite /fuel_map_preserve_threadpool. + intros ζ' Hζ'. + apply locales_of_list_step_incl in Hstep. + assert (ζ' ∉ locales_of_list tp1) as Hζ'' by set_solver. + apply Htp in Hζ''. + rewrite insert_insert. + assert (ζ ≠ ζ') as Hneq'. + { set_solver. } + assert (locale_of tp1 efork ≠ ζ') as Hneq''. + { assert (locale_of tp1 efork ∈ locales_of_list tp2). + { destruct Hforked as [tp2' [-> Hequiv]]. + by apply elem_of_locale_of_from_list. } + set_solver. } + rewrite lookup_insert_ne; [|done]. + rewrite lookup_insert_ne; [|done]. + done. + - simpl. by eapply env_match_internal_step. + Qed. + + Definition model_can_fork_step (δ1 : LM) (ζ ζf : locale Λ) (δ2 : LM) : Prop := + ∃ fs fs1 fs2, + δ1.(ls_under) = δ2.(ls_under) ∧ + δ1.(ls_map) !! ζ = Some fs ∧ fs ≠ ∅ ∧ + δ2.(ls_map) = <[ζ := fs1]>(<[ζf := fs2]> δ1.(ls_map)) ∧ + map_included (<) fs1 fs ∧ + map_included (<) fs2 fs ∧ + (dom fs ∖ (dom fs1 ∪ dom fs2) ∩ usr_live_roles (usr_state δ1) = ∅) ∧ + (dom fs1 ∩ dom fs2 = ∅) ∧ + ζf ∉ dom δ1.(ls_map). + + Lemma silent_step_suff_data_fork_weak act fl `(δ: LiveState Λ (joint_model M Net)) + (fs fs1 fs2 : gmap _ nat) ζ ζf : + δ.(ls_map) !! ζ = Some fs → + fs ≠ ∅ → + map_included (<) fs1 fs → + map_included (<) fs2 fs → + (dom fs ∖ (dom fs1 ∪ dom fs2)) ∩ usr_live_roles (usr_state δ) = ∅ → + (dom fs1 ∩ dom fs2 = ∅) → + ζf ∉ dom δ.(ls_map) → + ∃ δ', δ'.(ls_data) = + {| ls_under := δ; + ls_map := <[ζ := fs1]>(<[ζf := fs2]> δ.(ls_map)) |} ∧ + ls_trans fl δ (Silent_step ζ act) δ'. + Proof. + intros ?? Hincl1 Hincl2 **. + apply (silent_step_suff_data fl δ fs fs1 fs2 ζ (Some ζf)); try done. + - rewrite map_included_spec in Hincl1. done. + - rewrite map_included_spec in Hincl2. done. + - set_solver. + Qed. + + (* TODO: Change original lemma to not existentially quantify new state *) + Lemma silent_step_suff_data_fork_weak_alt act fl (δ δ': LiveState Λ (joint_model M Net)) + (fs fs1 fs2 : gmap _ nat) ζ ζf : + δ.(ls_under) = δ'.(ls_under) → + δ.(ls_map) !! ζ = Some fs → + δ'.(ls_map) = <[ζ := fs1]>(<[ζf := fs2]> δ.(ls_map)) → + fs ≠ ∅ → + map_included (<) fs1 fs → + map_included (<) fs2 fs → + (dom fs ∖ (dom fs1 ∪ dom fs2)) ∩ usr_live_roles (usr_state δ) = ∅ → + (dom fs1 ∩ dom fs2 = ∅) → + ζf ∉ dom δ.(ls_map) → + ls_trans fl δ (Silent_step ζ act) δ'. + Proof. + rewrite !map_included_spec. + intros Hδ Hfs Hfs12 Hne Hle1 Hle2 Hlive Hdisj Hnin. + assert (∃ δ', δ'.(ls_data) = + {| ls_under := δ; + ls_map := <[ζ := fs1]> (<[ζf := fs2]>δ.(ls_map)) |} ∧ + ls_trans fl δ (Silent_step ζ act) δ') as (δ''&Heq&Htrans). + { apply (silent_step_suff_data fl δ fs fs1 fs2 ζ (Some ζf)); + try set_solver. } + rewrite Heq Hδ -Hfs12 in Htrans. by destruct δ', ls_data. + Qed. + + Lemma model_can_fork_step_trans act fl ζ ζf (δ δ' : LiveState Λ (joint_model M Net)) : + model_can_fork_step δ ζ ζf δ' → ls_trans fl δ (Silent_step ζ act) δ'. + Proof. + destruct 1 as (?&?&?&?&?&?&?&?&?&?&?&?). + by eapply silent_step_suff_data_fork_weak_alt. + Qed. + + Lemma model_state_interp_can_fork_step σ es (δ1 δ2 : LM) ζ + (fs1 fs2 : gmap (usr_role M) nat) e : + (ls_data δ2) = model_update_fork ζ (locale_of es e) (dom fs1 ∪ dom fs2) (dom fs2) δ1 → + (fs1 ∪ fs2) ≠ ∅ → fs1 ##ₘ fs2 → + model_state_interp (es, σ) δ1 -∗ has_fuels_S ζ (fs1 ∪ fs2) -∗ + ⌜model_can_fork_step δ1 ζ (locale_of es e) δ2⌝. + Proof. + iIntros (Hδ2 Hne Hdisj) "Hm Hf". + iDestruct "Hm" as "(%fm&[%Hfmle %Hdom]&%Hfmdead&%Htp&Hm&Hfm&%Hsm)". + iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. + pose proof Hagree as Hagree'. + rewrite /fuel_map_le_inner map_included_spec in Hfmle. + apply Hfmle in Hagree as (fs'&HSome&Hle). + iPureIntro. + apply map_included_map_agree_R in Hle as (fs12'&fsf'&->&Hdisj'&Hle). + pose proof Hle as Hle'. + apply map_agree_R_fmap_inv in Hle' as (fs12''&->); last first. + { intros. destruct v2; [lia|by eauto]. } + apply map_agree_R_fmap in Hle; last first. + { intros. lia. } + apply map_agree_R_union_inv in Hle as (fs1'&fs2'&->&Hle1&Hle2); + [|done]. + eexists _, fs1', fs2'. + repeat split. + - rewrite Hδ2. done. + - done. + - apply map_agree_R_dom in Hle1. + apply map_agree_R_dom in Hle2. + intros Heq. apply Hne. + apply dom_empty_iff_L in Heq. + apply dom_empty_iff_L. + set_solver. + - rewrite Hδ2. simpl. + rewrite insert_commute; last first. + { assert (locale_of es e ∉ locales_of_list es) as Hes%Htp. + apply not_elem_of_locale_of_from_list. + set_solver. } + f_equiv. + { rewrite lookup_total_alt. simpl. + rewrite !lookup_alter. rewrite HSome. + simpl. + rewrite map_filter_fmap. simpl. + rewrite map_filter_filter. simpl. + rewrite !map_fmap_union. + apply map_agree_R_dom in Hle1. + apply map_agree_R_dom in Hle2. + apply map_disjoint_dom in Hdisj. + apply map_disjoint_dom in Hdisj'. + rewrite map_filter_union; [|apply map_disjoint_dom; set_solver]. + rewrite map_filter_union; [|apply map_disjoint_dom; set_solver]. + assert (filter + (λ '(i, _), + i ∈ dom fs2 ∧ (i ∈ usr_live_roles (usr_state δ1) ∨ i ∈ dom fs1 ∪ dom fs2)) + (S <$> fs1') = ∅) as Hfs1'. + { apply map_filter_empty_iff. + intros ρ f Hρ [HP1 HP2]. + apply elem_of_dom_2 in Hρ. + rewrite dom_fmap_L in Hρ. set_solver. } + assert (filter + (λ '(i, _), + i ∈ dom fs2 ∧ (i ∈ usr_live_roles (usr_state δ1) ∨ i ∈ dom fs1 ∪ dom fs2)) + fsf' = ∅) as Hfsf'. + { apply map_filter_empty_iff. + intros ρ f Hρ [HP1 HP2]. + apply elem_of_dom_2 in Hρ. set_solver. } + rewrite Hfs1' Hfsf'. + rewrite left_id right_id. + rewrite map_filter_id; last first. + { intros ?? Hlk. split. + - apply elem_of_dom_2 in Hlk. set_solver. + - right. + apply elem_of_dom_2 in Hlk. set_solver. } + rewrite -map_fmap_compose. + rewrite decr_succ_compose_id. + rewrite map_fmap_id. + done. } + rewrite -!alter_compose. + erewrite alter_insert_alt; [|done]. + f_equiv. + simpl. + rewrite map_filter_fmap. simpl. + rewrite map_filter_filter. simpl. + apply map_agree_R_dom in Hle1. + apply map_agree_R_dom in Hle2. + apply map_disjoint_dom in Hdisj. + apply map_disjoint_dom in Hdisj'. + rewrite !map_fmap_union. + rewrite map_filter_union; [|apply map_disjoint_dom; set_solver]. + rewrite map_filter_union; [|apply map_disjoint_dom; set_solver]. + assert (filter + (λ '(i, _), + (i ∉ dom fs2) ∧ (i ∈ usr_live_roles (usr_state δ1) ∨ i ∈ dom fs1 ∪ dom fs2)) + (S <$> fs2') = ∅) as Hfs2'. + { apply map_filter_empty_iff. + intros ρ f Hρ [HP1 HP2]. + apply elem_of_dom_2 in Hρ. + rewrite dom_fmap_L in Hρ. set_solver. } + assert (filter + (λ '(i, _), + (i ∉ dom fs2) ∧ (i ∈ usr_live_roles (usr_state δ1) ∨ i ∈ dom fs1 ∪ dom fs2)) + fsf' = ∅) as Hfsf'. + { apply map_filter_empty_iff. + intros ρ f Hρ [HP1 HP2]. + apply elem_of_dom_2 in Hρ. + rewrite Hle2 in HP1. + clear HP1. + assert (ρ ∈ (dom fs1 ∪ dom fs2)). + { destruct HP2 as [HP2|?]; [|done]. + rewrite -dom_union_L. + rewrite -(dom_fmap_L S). + eapply fuel_map_le_live_roles; [| | |apply Hagree'|..]. + - intros ????. by apply δ1.(ls_map_disj). + (* TODO: Fix this by unifying defs *) + - rewrite /fuel_map_le_inner map_included_spec. + eapply Hfmle. + - done. + - done. + - done. + - set_solver. } + set_solver. } + rewrite Hfs2' Hfsf'. + rewrite right_id right_id. + rewrite map_filter_id; last first. + { intros ?? Hlk. split. + - apply elem_of_dom_2 in Hlk. set_solver. + - right. + apply elem_of_dom_2 in Hlk. set_solver. } + rewrite -map_fmap_compose. + rewrite decr_succ_compose_id. + rewrite map_fmap_id. + done. + - eapply (map_included_subseteq_r _ _ (S <$> fs1')). + { rewrite map_fmap_union. + etransitivity; apply map_union_subseteq_l. } + apply map_included_spec. + intros k v1 Hv1. exists (S v1). split; [|lia]. + by rewrite lookup_fmap Hv1. + - eapply (map_included_subseteq_r _ _ (S <$> fs2')). + { rewrite map_fmap_union. + rewrite (map_union_comm (S <$> fs1') (S <$> fs2')). + - etransitivity; apply map_union_subseteq_l. + - apply map_disjoint_dom. rewrite !dom_fmap_L. + apply map_disjoint_dom in Hdisj. + apply map_agree_R_dom in Hle1. + apply map_agree_R_dom in Hle2. + set_solver. } + apply map_included_spec. + intros k v1 Hv1. exists (S v1). split; [|lia]. + by rewrite lookup_fmap Hv1. + - rewrite -dom_empty_iff_L in Hne. + apply map_agree_R_dom in Hle1. + apply map_agree_R_dom in Hle2. + apply disjoint_intersection_L. + apply map_disjoint_dom in Hdisj. + apply map_disjoint_dom in Hdisj'. + rewrite dom_union_L. + rewrite dom_fmap_L. + rewrite -dom_union_L. + replace (dom (fs1' ∪ fs2' ∪ fsf') ∖ (dom fs1' ∪ dom fs2')) + with (dom fsf') by set_solver. + intros ρ Hin1 Hin2. + assert (ρ ∈ (dom fs1 ∪ dom fs2)). + { rewrite -dom_union_L. + rewrite -(dom_fmap_L S). + eapply fuel_map_le_live_roles; [| | |apply Hagree'|..]. + - intros ????. by apply δ1.(ls_map_disj). + - rewrite /fuel_map_le_inner map_included_spec. + eapply Hfmle. + - done. + - done. + - done. + - set_solver. } + set_solver. + - apply map_agree_R_dom in Hle1. + apply map_agree_R_dom in Hle2. + apply disjoint_intersection_L. + apply map_disjoint_dom in Hdisj. + set_solver. + - pose proof (not_elem_of_locale_of_from_list es e) + as Hes%Htp. + apply not_elem_of_dom in Hes. set_solver. + Qed. + + Lemma model_update_locale_spec_fork extr + (auxtr : auxiliary_trace LM) ζ ζf c2 ρs1 ρs2 δ2 : + valid_state_evolution_fairness extr auxtr → + δ2.(ls_data) = model_update_fork ζ ζf ρs1 ρs2 (trace_last auxtr) → + model_can_fork_step (trace_last auxtr) ζ ζf δ2 → + tids_smaller c2.1 δ2 → + valid_state_evolution_fairness + (extr :tr[inl (ζ, None)]: c2) + (auxtr :tr[Silent_step ζ None]: δ2). + Proof. + intros Hvse Hstep Htids. destruct c2. + destruct Hvse as (?&?&?). + split; [| split]=>//. + econstructor=>//; first by eapply model_can_fork_step_trans. + Qed. + + Lemma model_state_interp_has_fuels_agree es δ ζ (fs : gmap (usr_role M) nat) : + model_state_interp es δ -∗ has_fuels ζ fs -∗ + ⌜∃ fs', δ.(ls_map) !! ζ = Some fs' ∧ map_included (≤) fs fs'⌝. + Proof. + iIntros "Hm Hf". + iDestruct "Hm" as "(%fm&[%Hfmle %Hdom]&%Hfmdead&%Htp&Hm&Hfm&%Hsm)". + iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. + rewrite /fuel_map_le_inner map_included_spec in Hfmle. + apply Hfmle in Hagree as (fs'&HSome&Hfs'). + iPureIntro. by eexists _. + Qed. + + Lemma update_fork_step fs1 fs2 tp1 tp2 (extr : execution_trace Λ) + (auxtr: auxiliary_trace LM) ζ efork σ1 σ2 : + fs1 ∪ fs2 ≠ ∅ → fs1 ##ₘ fs2 → + trace_last extr = (tp1, σ1) → + locale_step (tp1, σ1) (inl (ζ, None)) (tp2, σ2) → + valid_state_evolution_fairness extr auxtr → + has_forked tp1 tp2 efork → + has_fuels_S ζ (fs1 ∪ fs2) -∗ + model_state_interp (tp1, σ1) (trace_last auxtr) ==∗ + ∃ δ2, + ⌜valid_state_evolution_fairness + (extr :tr[inl (ζ, None)]: (tp2, σ2)) (auxtr :tr[Silent_step ζ None]: δ2)⌝ ∗ + has_fuels ζ fs1 ∗ has_fuels (locale_of tp1 efork) fs2 ∗ + model_state_interp (tp2, σ2) δ2. + Proof. + iIntros (Hdom Hdisj Hlast Hstep Hvse Hforked) "Hfuel Hm". + iDestruct (model_state_interp_has_fuels_agree with "Hm Hfuel") + as %(fs'&HSome&Hfs'). + iAssert (⌜(locale_of tp1 efork) ∉ dom (ls_map (trace_last auxtr))⌝)%I as %Hnin. + { destruct Hforked as (?&?&?). + iDestruct "Hm" as "(%fm&[%Hfmle %Hdom']&%Hfmdead&%Htp&Hm&Hfm)". + rewrite -Hdom'. + iPureIntro. apply not_elem_of_dom. apply Htp. + apply locale_step_equiv in Hstep. simpl in *. + apply not_elem_of_locale_of_from_list. } + opose proof (model_update_fork_valid _ _ _ _ _) as [δ2 Hδ]; + [by apply elem_of_dom|done|]. + iDestruct (model_state_interp_can_fork_step with "Hm Hfuel") as %Hcan_step; + [done..|]. + iMod (model_state_interp_fork_update with "Hm Hfuel") as "(Hm&Hf1&Hf2)"; + [done..|]. + iDestruct (model_state_interp_tids_smaller with "Hm") as %Htids. + iModIntro. + iExists δ2. + iFrame "Hm Hf1 Hf2". + iPureIntro. + by eapply model_update_locale_spec_fork. + Qed. + + Lemma free_roles_inclusion FR fr: + auth_free_roles_are FR -∗ + frag_free_roles_are fr -∗ + ⌜fr ⊆ FR⌝. + Proof. + iIntros "HFR Hfr". + iDestruct (own_valid_2 with "HFR Hfr") as %Hval. iPureIntro. + apply auth_both_valid_discrete in Hval as [??]. + by apply gset_disj_included. + Qed. + + Lemma update_free_roles rem FR fr1: + rem ⊆ fr1 -> + auth_free_roles_are FR -∗ + frag_free_roles_are fr1 ==∗ + auth_free_roles_are (FR ∖ rem) ∗ + frag_free_roles_are (fr1 ∖ rem). + Proof. + iIntros (?) "HFR Hfr1". + iDestruct (free_roles_inclusion with "HFR Hfr1") as %Hincl. + replace FR with ((FR ∖ rem) ∪ rem); last first. + { rewrite difference_union_L. set_solver. } + replace fr1 with ((fr1 ∖ rem) ∪ rem); last first. + { rewrite difference_union_L. set_solver. } + iAssert (frag_free_roles_are (fr1 ∖ rem) ∗ frag_free_roles_are rem)%I with "[Hfr1]" as "[Hfr2 Hrem]". + { rewrite /frag_free_roles_are -own_op -auth_frag_op gset_disj_union //. set_solver. } + iCombine "HFR Hrem" as "H". + iMod (own_update with "H") as "[??]" ; eauto. + - apply auth_update, gset_disj_dealloc_local_update. + - iModIntro. iFrame. iApply (own_proper with "Hfr2"). + do 2 f_equiv. set_solver. + Qed. + + (* Lemma update_model_state_interp_config (δ : LiveState _ _) cl fl tp m2 : *) + (* LM.(lm_cfg_action) δ cl = (fl, m2) → *) + (* ⊢ model_state_interp tp δ ==∗ model_state_interp tp {| ls_under := m2; ls_map := ls_map δ |}. *) + (* Proof. *) + (* iIntros (Heq) "Hmod". unfold model_state_interp. *) + (* iDestruct "Hmod" as (fm) "(#? & #? & #? & Hmod & Hfuel)". *) + (* erewrite (lm_cfg_spec_live_roles) =>//. *) + (* iExists fm. simpl. iFrame "Hfuel #". *) + (* iMod (model_update _ _ m2 with "Hmod") as "[? ?]". *) + +End model_state_lemmas. diff --git a/fairneris/fairness.v b/fairneris/fairness.v new file mode 100644 index 0000000..b1a208f --- /dev/null +++ b/fairneris/fairness.v @@ -0,0 +1,194 @@ +From stdpp Require Import option. +From Paco Require Import paco1 paco2 pacotac. +From fairneris Require Export inftraces ltl_lite trace_utils . + +Record FairModel : Type := { + fmstate:> Type; + fmstate_eqdec: EqDecision fmstate; + fmstate_inhabited: Inhabited fmstate; + + fmrole: Type; + fmaction: Type; + fmconfig: Type; + fmrole_eqdec: EqDecision fmrole; + fmrole_countable: Countable fmrole; + fmrole_inhabited: Inhabited fmrole; + + fmtrans: fmstate → ((fmrole * fmaction) + fmconfig) → fmstate → Prop; + fmfairness : trace fmstate ((fmrole * fmaction) + fmconfig) → Prop; + live_roles: fmstate → gset fmrole; + fm_live_spec: ∀ s ρ α s', fmtrans s (inl (ρ,α)) s' → ρ ∈ live_roles s; + fm_fl : fmstate → nat; +}. + +Arguments fm_fl {_}. + +#[global] Existing Instance fmstate_eqdec. +#[global] Existing Instance fmstate_inhabited. +#[global] Existing Instance fmrole_eqdec. +#[global] Existing Instance fmrole_countable. +#[global] Existing Instance fmrole_inhabited. + +Definition fmlabel (FM :FairModel) : Type := + (fmrole FM * fmaction FM) + fmconfig FM. + +Definition fair_model_to_model (FM : FairModel) : Model := + {| + mstate := fmstate FM; + mlabel := fmlabel FM; + mtrans := fmtrans FM; + |}. + +(* Basically, soundness of the logic and the lemmas above tell us that we have a program + trace and a model trace which are related by traces_match labels_math! + + We now prove that this relation transports the properties we care about; the first + place of which is fairness. + *) + +(* Definition of fairness for both kinds of traces *) + +Definition mtrace (M:FairModel) := + trace (M.(fmstate)) (fmlabel M). + +Section model_traces. + Context `{M: FairModel}. + + Definition role_enabled_model ρ (s: M.(fmstate)) := ρ ∈ M.(live_roles) s. + + Definition live_mdl_role (ρ : fmlabel M) (δ : fmstate M) : Prop := + match ρ with + | inl (ρ,_) => role_enabled_model ρ δ + (* | inr ζ => config_enabled ζ c.2 *) + | inr _ => False + end. + + Definition fair_scheduling_mtr ρ : mtrace M → Prop := + trace_implies (λ δ _, role_enabled_model ρ δ) + (λ δ ℓ, ¬role_enabled_model ρ δ ∨ ∃ act, ℓ = Some $ inl (ρ, act)). + + Lemma fair_scheduling_mtr_after ℓ tr tr' k: + after k tr = Some tr' → + fair_scheduling_mtr ℓ tr → fair_scheduling_mtr ℓ tr'. + Proof. apply trace_implies_after. Qed. + + Lemma fair_scheduling_mtr_cons ℓ δ ℓ' r: + fair_scheduling_mtr ℓ (δ -[ℓ']-> r) → fair_scheduling_mtr ℓ r. + Proof. apply trace_implies_cons. Qed. + + Lemma fair_scheduling_mtr_cons_forall δ ℓ' r: + (∀ ℓ, fair_scheduling_mtr ℓ (δ -[ℓ']-> r)) → (∀ ℓ, fair_scheduling_mtr ℓ r). + Proof. intros Hℓ ℓ. eapply trace_implies_cons. apply Hℓ. Qed. + + Definition fair_scheduling mtr := ∀ ρ, fair_scheduling_mtr ρ mtr. + Definition mtrace_fair mtr := fair_scheduling mtr ∧ M.(fmfairness) mtr. + + Definition mtrace_trans_valid (mtr : mtrace M) := + match mtr with + | ⟨s⟩ => True + | (s -[l]-> tr) => fmtrans _ s l (trfirst tr) + end. + + Definition mtrace_valid := □ mtrace_trans_valid. + + Inductive mtrace_valid_ind (mtrace_valid_coind: mtrace M → Prop) : + mtrace M → Prop := + | mtrace_valid_singleton δ: mtrace_valid_ind _ ⟨δ⟩ + | mtrace_valid_cons δ ℓ tr: + fmtrans _ δ ℓ (trfirst tr) → + mtrace_valid_coind tr → + mtrace_valid_ind _ (δ -[ℓ]-> tr). + Definition mtrace_valid_coind := paco1 mtrace_valid_ind bot1. + + Lemma mtrace_valid_mono : + monotone1 mtrace_valid_ind. + Proof. + unfold monotone1. intros x0 r r' IN LE. + induction IN; try (econstructor; eauto; done). + Qed. + Hint Resolve mtrace_valid_mono : paco. + + Lemma mtrace_valid_coind_ltl mtr : + mtrace_valid_coind mtr → mtrace_valid mtr. + Proof. + rewrite /mtrace_valid trace_alwaysI /trace_suffix_of. + intros Hval mtr' [n Hsome]. revert mtr Hval mtr' Hsome. + induction n as [|n IH]; intros mtr Hval mtr' Hsome. + { rewrite /= in Hsome. simplify_eq. punfold Hval. inversion Hval=>//. } + destruct mtr as [|?? mtr]=>//. simpl in Hsome. + eapply (IH mtr)=>//. punfold Hval. inversion Hval; simplify_eq. by pclearbot. + Qed. +End model_traces. + +Global Hint Resolve mtrace_valid_mono : paco. + +Definition extrace Λ := trace (cfg Λ) (ex_label Λ). + +Section exec_trace. + Context {Λ : language}. + Context `{EqDecision (locale Λ)}. + + Definition locale_enabled (ζ : locale Λ) (c: cfg Λ) := + ∃ e, from_locale c.1 ζ = Some e ∧ to_val e = None. + + (* Definition live_ex_label (ζ : ex_label Λ) (c : cfg Λ) : Prop := *) + (* match ζ with *) + (* | inl (ζ,_) => locale_enabled ζ c *) + (* (* | inr ζ => config_enabled ζ c.2 *) *) + (* | inr _ => False *) + (* end. *) + + Definition fair_scheduling_ex ζ : extrace Λ → Prop := + trace_implies (λ c _, locale_enabled ζ c) + (λ c otid, ¬ locale_enabled ζ c ∨ ∃ act, otid = Some (inl (ζ, act))). + + Lemma fair_scheduling_ex_after ζ tr tr' k: + after k tr = Some tr' → + fair_scheduling_ex ζ tr → fair_scheduling_ex ζ tr'. + Proof. apply trace_implies_after. Qed. + + Lemma fair_scheduling_ex_cons ζ c ζ' r: + fair_scheduling_ex ζ (c -[ζ']-> r) → fair_scheduling_ex ζ r. + Proof. apply trace_implies_cons. Qed. + + CoInductive extrace_valid: extrace Λ → Prop := + | extrace_valid_singleton c: extrace_valid ⟨c⟩ + | extrace_valid_cons c oζ tr: + locale_step c oζ (trfirst tr) → + extrace_valid tr → + extrace_valid (c -[oζ]-> tr). + + Lemma to_trace_preserves_validity ex iex: + extrace_valid (to_trace (trace_last ex) iex) → valid_exec ex → + valid_inf_exec ex iex. + Proof. + revert ex iex. cofix CH. intros ex iex Hexval Hval. + rewrite (trace_unfold_fold (to_trace _ _)) in Hexval. + destruct iex as [|[??] iex]; first by econstructor. cbn in Hexval. + inversion Hexval. simplify_eq. + econstructor; try done. + - by destruct iex as [|[??]?]. + - apply CH; eauto. econstructor; try done. by destruct iex as [|[??]?]. + Qed. + + Lemma from_trace_preserves_validity (extr: extrace Λ) ex: + extrace_valid extr → + valid_exec ex → + trace_last ex = trfirst extr → + valid_inf_exec ex (from_trace extr). + Proof. + revert ex extr. cofix CH. intros ex extr Hexval Hval Heq. + rewrite (inflist_unfold_fold (from_trace extr)). destruct extr as [c|c tid tr]; cbn; + first by econstructor. + inversion Hexval; simplify_eq; econstructor; eauto. apply CH; eauto. + by econstructor. + Qed. + + Lemma from_trace_preserves_validity_singleton (extr: extrace Λ): + extrace_valid extr → + valid_inf_exec (trace_singleton (trfirst extr)) (from_trace extr). + Proof. + intros ?. eapply from_trace_preserves_validity; eauto. econstructor. + Qed. + +End exec_trace. diff --git a/fairneris/from_locale_utils.v b/fairneris/from_locale_utils.v new file mode 100644 index 0000000..4931b30 --- /dev/null +++ b/fairneris/from_locale_utils.v @@ -0,0 +1,77 @@ +(* TODO: Clean up imports *) +From Paco Require Import pacotac. +From stdpp Require Import finite. +From iris.proofmode Require Import proofmode. +From trillium.program_logic Require Import adequacy. +From fairneris.aneris_lang.state_interp Require Import state_interp_def. +From fairneris.aneris_lang.state_interp Require Import state_interp_config_wp. +From fairneris.aneris_lang.state_interp Require Import state_interp. +From fairneris.aneris_lang.program_logic Require Import aneris_weakestpre. + +(* TODO: Should likely move this to [lang.v] *) +Definition locale_of' (ips : list ip_address) ip := + (ip, length $ (filter (λ ip', ip' = ip)) ips). + +Lemma locale_of_locale_of' es e : + locale_of es e = locale_of' (map expr_n es) (expr_n e). +Proof. + induction es; [done|]. + rewrite /locale_of /locale_of'. simpl. + rewrite !filter_cons. case_decide; [|done]=> /=. + f_equiv. rewrite /locale_of /locale_of' in IHes. simplify_eq. by rewrite IHes. +Qed. + +Lemma prefixes_map_from_locale_of_locale_of' tp0 tp1 : + map (λ '(t,e), locale_of t e) (prefixes_from tp0 tp1) = + map (λ '(t,e), locale_of' t e) (prefixes_from (map expr_n tp0) (map expr_n tp1)). +Proof. + revert tp0. + induction tp1; [done|]; intros tp0=> /=. + rewrite locale_of_locale_of'. f_equiv. + replace ([expr_n a]) with (map expr_n [a]) by done. + rewrite -(map_app _ tp0 [a]). + apply IHtp1. +Qed. + +(* This is almost identical to above lemma, but differs in [map] vs [list_fmap] *) +Lemma prefixes_list_fmap_from_locale_of_locale_of' tp0 tp1 : + (λ '(t,e), locale_of t e) <$> prefixes_from tp0 tp1 = + (λ '(t,e), locale_of' t e) <$> prefixes_from (map (expr_n) tp0) (map expr_n tp1). +Proof. + revert tp0. + induction tp1; [done|]; intros tp0=> /=. + rewrite locale_of_locale_of'. f_equiv. + replace ([expr_n a]) with (map expr_n [a]) by done. + rewrite -(map_app _ tp0 [a]). + apply IHtp1. +Qed. + +Lemma prefixes_from_take {A} n (xs ys : list A) : + prefixes_from xs (take n ys) = take n (prefixes_from xs ys). +Proof. + revert n xs. + induction ys as [|y ys IHys]; intros n xs. + { by rewrite !take_nil. } + destruct n; [done|]=> /=. by f_equiv. +Qed. + +Lemma locales_of_list_from_drop + `{LM: LiveModel aneris_lang (joint_model Mod Net)} `{!LiveModelEq LM} `{aG : !anerisG LM Σ} es es' tp : + locales_equiv_prefix_from es' es tp → + (λ '(t,e) v, fork_post (locale_of t e) v) <$> + (prefixes_from es' tp) = + (λ '(t,e) v, fork_post (locale_of t e) v) <$> + (prefixes_from es' (es ++ drop (length es) tp)). +Proof. + intros Hζ. apply locales_of_list_from_fork_post. + by apply locales_of_list_equiv, locales_equiv_prefix_from_drop. +Qed. + +Lemma posts_of_length_drop + `{LM: LiveModel aneris_lang (joint_model Mod Net)} `{!LiveModelEq LM} `{aG : !anerisG LM Σ} es es' tp : + locales_equiv_prefix_from es' es tp → + posts_of tp ((λ '(t,e) v, fork_post (locale_of t e) v) <$> + (prefixes_from es' (es ++ drop (length es) tp))) -∗ + posts_of tp ((λ '(t,e) v, fork_post (locale_of t e) v) <$> + (prefixes_from es' tp)). +Proof. iIntros (Hζ) "H". by erewrite <-locales_of_list_from_drop. Qed. diff --git a/fairneris/fuel.v b/fairneris/fuel.v new file mode 100644 index 0000000..7b6bd7d --- /dev/null +++ b/fairneris/fuel.v @@ -0,0 +1,1301 @@ +From stdpp Require Import option. +From Paco Require Import paco1 paco2 pacotac. +From trillium.program_logic Require Export adequacy. +From fairneris Require Export inftraces fairness ltl_lite. + +Section fairness. + Context {Λ : language}. + Context {M: FairModel}. + Context `{Countable (locale Λ)}. + + Record LiveStateData := MkLiveStateData { + ls_under:> M.(fmstate); + ls_map: gmap (locale Λ) (gmap M.(fmrole) nat); + }. + Record LiveState := MkLiveState { + ls_data :> LiveStateData; + + ls_map_disj: ∀ ζ ζ' fs fs', ζ ≠ ζ' → ls_data.(ls_map) !! ζ = Some fs → ls_data.(ls_map) !! ζ' = Some fs' → fs ##ₘ fs'; + ls_map_live: ∀ ρ, ρ ∈ M.(live_roles) ls_data.(ls_under) → ∃ ζ fs, ls_data.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs; + }. + + Implicit Type δ : LiveState. + + Definition ls_fuel (δ: LiveStateData) : gmap M.(fmrole) nat := + map_fold (λ _ m fs, m ∪ fs) ∅ δ.(ls_map). + Definition add_stuff ζ (m: gmap M.(fmrole) (locale Λ)) (rs: gset M.(fmrole)) := + gset_to_gmap ζ rs ∪ m. + Definition ls_mapping (δ: LiveStateData) : gmap M.(fmrole) (locale Λ) := + map_fold (λ ζ fs m, add_stuff ζ m (dom fs)) (∅: gmap M.(fmrole) (locale Λ)) δ.(ls_map). + + (* Lemma ls_fuel_dom δ ρ: ρ ∈ dom $ ls_mapping δ = dom $ ls_fuel δ. *) + Lemma dom_add_stuff ζ m rs : dom $ add_stuff ζ m rs = rs ∪ dom m. + Proof. + rewrite /add_stuff. + revert m. induction rs using set_ind_L; first set_solver; intros m. + rewrite gset_to_gmap_union_singleton !dom_union_L dom_insert_L. set_solver. + Qed. + + Lemma add_stuff_commute ζ1 ζ2 m s1 s2 : + s1 ## s2 → + add_stuff ζ2 (add_stuff ζ1 m s1) s2 = add_stuff ζ1 (add_stuff ζ2 m s2) s1. + Proof. + rewrite /add_stuff. intros Hdisj. rewrite !assoc. f_equal. + rewrite map_union_comm //. + apply map_disjoint_dom_2. rewrite !dom_gset_to_gmap //. + Qed. + (*TODO: why commute above and comm below? *) + + Lemma ls_same_doms δ: dom $ ls_mapping δ = dom $ ls_fuel δ. + Proof. + rewrite /ls_mapping /ls_fuel. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ fs m Hnotin IH] using map_ind ; first set_solver. + intros Hdisj. + rewrite map_fold_insert_L //; last first. + { intros. apply add_stuff_commute. eapply map_disjoint_dom. rewrite comm in H0. eapply Hdisj; eauto. } + rewrite map_fold_insert_L //; last first. + { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } + rewrite dom_add_stuff !dom_union_L. + rewrite IH //. intros. eapply Hdisj; eauto; rewrite lookup_insert_ne //; naive_solver. + Qed. + + Lemma ls_fuel_data ρ δ ζ fs f: δ.(ls_map) !! ζ = Some fs → fs !! ρ = Some f → ls_fuel δ !! ρ = Some f. + Proof. + rewrite /ls_fuel. revert ρ ζ fs f. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind ; first set_solver. + intros Hdisj ρ ζ fs f Hsome Hin. + rewrite map_fold_insert_L //; last first. + { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } + rewrite lookup_union_Some_raw. destruct (decide (ζ = ζ')) as [->|Hneq]. + - left. rewrite lookup_insert in Hsome. naive_solver. + - right. rewrite lookup_insert_ne // in Hsome. split. + + assert (fs ##ₘ fs'). + { eapply Hdisj; eauto; [rewrite lookup_insert_ne // | rewrite lookup_insert //]. } + by eapply map_disjoint_Some_l. + + eapply IH; eauto. intros. + eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. + Qed. + + Lemma ls_mapping_data ρ δ ζ fs: δ.(ls_map) !! ζ = Some fs → ρ ∈ dom fs → ls_mapping δ !! ρ = Some ζ. + Proof. + rewrite /ls_mapping. revert ρ ζ fs. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind ; first set_solver. + intros Hdisj ρ ζ fs Hsome Hin. + rewrite map_fold_insert_L //; last first. + { intros. apply add_stuff_commute. eapply map_disjoint_dom. rewrite comm in H0. eapply Hdisj; eauto. } + rewrite /add_stuff. + rewrite lookup_union_Some_raw. destruct (decide (ζ = ζ')) as [->|Hneq]. + - left. rewrite lookup_insert in Hsome. rewrite lookup_gset_to_gmap_Some. naive_solver. + - right. rewrite lookup_insert_ne // in Hsome. split. + + assert (fs ##ₘ fs'). + { eapply Hdisj; eauto; [rewrite lookup_insert_ne // | rewrite lookup_insert //]. } + rewrite lookup_gset_to_gmap_None not_elem_of_dom. apply elem_of_dom in Hin as [??]. + by eapply map_disjoint_Some_l. + + eapply IH; eauto. intros. + eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. + Qed. + Lemma ls_mapping_data_inv ρ δ ζ: ls_mapping δ !! ρ = Some ζ → ∃ fs, δ.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs. + Proof. + rewrite /ls_mapping. revert ρ ζ. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind ; first set_solver. + intros Hdisj ρ ζ Hsome. + rewrite map_fold_insert_L // in Hsome; last first. + { intros. apply add_stuff_commute. eapply map_disjoint_dom. rewrite comm in H0. eapply Hdisj; eauto. } + rewrite /add_stuff in Hsome. + rewrite lookup_union_Some_raw in Hsome. destruct Hsome as [Hsome|[Hnone Hsome]]. + - rewrite lookup_gset_to_gmap_Some in Hsome. destruct Hsome as [? ->]. + rewrite lookup_insert. naive_solver. + - assert (∃ fs : gmap (fmrole M) nat, m !! ζ = Some fs ∧ ρ ∈ dom fs) as (fs&?&?). + { eapply IH; eauto. intros. eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. } + exists fs; split; eauto. + rewrite lookup_insert_ne //. naive_solver. + Qed. + + Lemma ls_fuel_dom_data ρ δ ζ fs: δ.(ls_map) !! ζ = Some fs → ρ ∈ dom fs → ρ ∈ dom $ ls_fuel δ. + Proof. + rewrite /ls_fuel. revert ρ ζ fs. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind ; first set_solver. + intros Hdisj ρ ζ fs Hsome Hin. + rewrite map_fold_insert_L //; last first. + { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } + rewrite dom_union. apply elem_of_union. destruct (decide (ζ = ζ')) as [->|Hneq]. + - left. rewrite lookup_insert in Hsome. naive_solver. + - right. rewrite lookup_insert_ne // in Hsome. eapply IH; eauto. intros. + eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. + Qed. + + Lemma ls_fuel_data_inv ρ δ f: ls_fuel δ !! ρ = Some f → ∃ ζ fs, δ.(ls_map) !! ζ = Some fs ∧ fs !! ρ = Some f. + Proof. + rewrite /ls_fuel. revert ρ f. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind. + { intros ??. rewrite map_fold_empty. set_solver. } + intros Hdisj ρ f Hin. + rewrite map_fold_insert_L // in Hin; last first. + { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } + rewrite lookup_union_Some_raw in Hin. destruct Hin as [Hin|[? Hin]]. + - exists ζ', fs'. rewrite lookup_insert. naive_solver. + - assert (∃ ζ fs, m !! ζ = Some fs ∧ fs !! ρ = Some f) as [ζ [fs Hζ]]. + { apply IH; eauto. + intros ???????. eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. } + exists ζ, fs. rewrite lookup_insert_ne //. naive_solver. + Qed. + + Lemma ls_fuel_dom_data_inv ρ δ: ρ ∈ dom $ ls_fuel δ → ∃ ζ fs, δ.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs. + Proof. + rewrite /ls_fuel. revert ρ. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind. + { intros ??. rewrite map_fold_empty. set_solver. } + intros Hdisj ρ Hin. + rewrite map_fold_insert_L // in Hin; last first. + { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } + rewrite dom_union in Hin. apply elem_of_union in Hin as [Hin|Hin]. + - exists ζ', fs'. rewrite lookup_insert. naive_solver. + - assert (∃ ζ fs, m !! ζ = Some fs ∧ ρ ∈ dom fs) as [ζ [fs Hζ]]. + { apply IH; eauto. + intros ???????. eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. } + exists ζ, fs. rewrite lookup_insert_ne //. naive_solver. + Qed. + + Lemma ls_fuel_suff δ ρ: ρ ∈ dom $ ls_fuel δ → ∃ ζ fs, δ.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs. + Proof. + rewrite /ls_fuel. revert ρ. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind. + { intros ??. rewrite map_fold_empty. set_solver. } + intros Hdisj ρ Hin. + rewrite map_fold_insert_L // in Hin; last first. + { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } + rewrite dom_union in Hin. apply elem_of_union in Hin as [Hin|Hin]. + - exists ζ', fs'. rewrite lookup_insert. naive_solver. + - assert (∃ ζ fs, m !! ζ = Some fs ∧ ρ ∈ dom fs) as [ζ [fs Hζ]]. + { apply IH; eauto. + intros ???????. eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. } + exists ζ, fs. rewrite lookup_insert_ne //. naive_solver. + Qed. + + + Lemma ls_fuel_dom δ: M.(live_roles) δ.(ls_under) ⊆ dom $ ls_fuel δ. + Proof. + generalize (ls_map_live δ). + induction (live_roles M δ) as [|ρ ρs Hnotin IH] using set_ind_L ; first set_solver. + intros Hlive. apply union_subseteq; split; last first. + { apply IH. intros. apply Hlive. set_solver. } + apply singleton_subseteq_l. destruct (Hlive ρ ltac:(set_solver)) as (ζ&fs&Hlk&Hin). + by eapply ls_fuel_dom_data. + Qed. + + + Lemma ls_mapping_dom (m: LiveState): + M.(live_roles) m.(ls_under) ⊆ dom $ ls_mapping m. + Proof. rewrite ls_same_doms. apply ls_fuel_dom. Qed. + + Inductive FairLabel {FM: FairModel} := + | Take_step: FM.(fmrole) -> FM.(fmaction) → locale Λ -> option (action Λ) → FairLabel + | Silent_step: locale Λ -> option (action Λ) → FairLabel + | Config_step: FM.(fmconfig) → config_label Λ → FairLabel + . + Arguments FairLabel : clear implicits. + + Definition less (x y: option nat) := + match x, y with + | Some x, Some y => x < y + | _, _ => False + end. + + Inductive must_decrease (ρ': M.(fmrole)) (oρ: option M.(fmrole)) (a b: LiveStateData): + (option $ locale Λ) -> Prop := + | Same_tid tid (Hneqρ: Some ρ' ≠ oρ) (Hsametid: Some tid = ls_mapping a !! ρ'): + must_decrease ρ' oρ a b (Some tid) + | Change_tid otid (Hneqtid: ls_mapping a !! ρ' ≠ ls_mapping b !! ρ') + (Hissome: is_Some (ls_mapping b !! ρ')): + must_decrease ρ' oρ a b otid + (* | Zombie otid (Hismainrole: oρ = Some ρ') (Hnotalive: ρ' ∉ live_roles _ b) (Hnotdead: ρ' ∈ dom $ ls_fuel b): *) + (* must_decrease ρ' oρ a b otid *) + . + + Definition fuel_decr (tid: option $ locale Λ) (oρ: option M.(fmrole)) + (a b: LiveStateData) := + ∀ ρ', ρ' ∈ dom $ ls_fuel a -> ρ' ∈ dom $ ls_fuel b → + must_decrease ρ' oρ a b tid -> + oless (ls_fuel b !! ρ') (ls_fuel a !! ρ'). + + Definition fuel_must_not_incr oρ (a b: LiveStateData) := + ∀ ρ', ρ' ∈ dom $ ls_fuel a -> Some ρ' ≠ oρ -> + (oleq (ls_fuel b !! ρ') (ls_fuel a !! ρ') + ∨ (ρ' ∉ dom $ ls_fuel b ∧ ρ' ∉ M.(live_roles) a.(ls_under))). + + Lemma ls_map_agree {δ ρ ζ1 ζ2 fs1 fs2} : + δ.(ls_map) !! ζ1 = Some fs1 → + δ.(ls_map) !! ζ2 = Some fs2 → + ρ ∈ dom fs1 → + ρ ∈ dom fs2 → + ζ1 = ζ2 ∧ fs1 = fs2. + Proof. + intros Hlk1 Hlk2 [??]%elem_of_dom [??]%elem_of_dom. + destruct (decide (ζ1 = ζ2)) as [|Hneq]; first naive_solver. + have ?:= ls_map_disj _ _ _ _ _ Hneq Hlk1 Hlk2. exfalso. + by eapply map_disjoint_spec. + Qed. + + Definition ls_trans (fuel_limit : M → nat) (a: LiveStateData) ℓ (b: LiveStateData): Prop := + match ℓ with + | Take_step ρ fmact tid act => + M.(fmtrans) a (inl (ρ, fmact)) b + ∧ ls_mapping a !! ρ = Some tid + ∧ fuel_decr (Some tid) (Some ρ) a b + ∧ fuel_must_not_incr (Some ρ) a b + ∧ (oleq (ls_fuel b !! ρ) (Some (fuel_limit b))) + ∧ (∀ ρ, ρ ∈ (dom $ ls_fuel b) ∖ (dom $ ls_fuel a) -> oleq (ls_fuel b !! ρ) (Some (fuel_limit b))) + ∧ (dom $ ls_fuel b) ∖ (dom $ ls_fuel a) ⊆ live_roles _ b ∖ live_roles _ a + | Silent_step tid act => + (∃ ρ, ls_mapping a !! ρ = Some tid) + ∧ fuel_decr (Some tid) None a b + ∧ fuel_must_not_incr None a b + ∧ dom $ ls_fuel b ⊆ dom $ ls_fuel a + ∧ a.(ls_under) = b.(ls_under) + | Config_step fmact act => + M.(fmtrans) a (inr fmact) b + ∧ a.(ls_map) = b.(ls_map) + ∧ live_roles _ a = live_roles _ b + end. + + Lemma silent_step_suff_data fl (δ: LiveState) (fs fs' fs'': gmap _ nat) ζ (oζ' : option $ locale Λ) act : + δ.(ls_map) !! ζ = Some fs → + fs ≠ ∅ → + (∀ ρ f', fs' !! ρ = Some f' → ∃ f, fs !! ρ = Some f ∧ f' < f) → + (∀ ρ f', fs'' !! ρ = Some f' → ∃ f, fs !! ρ = Some f ∧ f' < f) → + (dom fs ∖ (dom fs' ∪ dom fs'') ∩ M.(live_roles) δ = ∅) → + (dom fs' ∩ dom fs'' = ∅) → + (∀ ζ', oζ' = Some ζ' → ζ' ∉ dom δ.(ls_map)) → + (oζ' = None → fs'' = ∅) → + let data' := + match oζ' with + | None => δ.(ls_map) + | Some ζ' => <[ζ' := fs'']> δ.(ls_map) + end + in + let data'' := <[ζ := fs']> data' in + ∃ δ', δ'.(ls_data) = {| ls_under := δ; ls_map := data'' |} ∧ + ls_trans fl δ (Silent_step ζ act) δ'. + Proof. + intros Hζ Hnemp Hfs' Hfs'' Hlives Hdisj Hnlocale Hifnone data' data''. + have Hincl' : dom fs' ⊆ dom fs. + { intros ?[? Hin]%elem_of_dom. by apply Hfs' in Hin as [?[?%elem_of_dom_2 ?]]. } + have Hincl'' : dom fs'' ⊆ dom fs. + { intros ?[? Hin]%elem_of_dom. by apply Hfs'' in Hin as [?[?%elem_of_dom_2 ?]]. } + assert (∃ δ', δ'.(ls_data) = {| ls_under := δ; ls_map := data'' |}) as [δ' Hd]. + { unshelve refine (ex_intro _ {| ls_data := {| ls_under := δ; ls_map := data'' |} |} _); last done. + { rewrite /data'' /=. intros z1 z2 fs1 fs2 Hneq Hlk1 Hlk2. apply map_disjoint_dom_2. + intros ρ Hin1 Hin2. destruct (decide (z1 = ζ)) as [->|Hneq1]. + - rewrite lookup_insert in Hlk1. simplify_eq. rewrite lookup_insert_ne // /data' in Hlk2. + destruct oζ' as [ζ'|]. + + destruct (decide (z2 = ζ')) as [->|Hneq2]. + * rewrite lookup_insert in Hlk2. simplify_eq. set_solver. + * rewrite lookup_insert_ne // in Hlk2. have ?: ρ ∈ dom fs by set_solver. + apply Hneq. eapply ls_map_agree; eauto. + + apply Hneq. eapply ls_map_agree; eauto. + - rewrite lookup_insert_ne // /data' in Hlk1. + destruct oζ' as [ζ'|]. + + destruct (decide (z1 = ζ')) as [->|Hneq2]. + * rewrite lookup_insert in Hlk1. simplify_eq. + destruct (decide (z2 = ζ)) as [->|Hneq3]. + ** rewrite lookup_insert in Hlk2. simplify_eq. set_solver. + ** rewrite !lookup_insert_ne // in Hlk2. specialize (Hnlocale _ ltac:(done)). + have ?: ρ ∈ dom fs by set_solver. + have ?: z2 = ζ by eapply ls_map_agree. simplify_eq. + * rewrite lookup_insert_ne // in Hlk1. + destruct (decide (z2 = ζ)) as [->|Hneq3]. + ** rewrite lookup_insert in Hlk2. simplify_eq. + have ?: ρ ∈ dom fs by set_solver. + apply Hneq. by eapply ls_map_agree. + ** rewrite lookup_insert_ne // /data' in Hlk2. + destruct (decide (z2 = ζ')) as [->|Hneq4]. + *** rewrite lookup_insert in Hlk2. simplify_eq. + apply Hneq1. eapply ls_map_agree; eauto. + *** rewrite lookup_insert_ne // in Hlk2. + have Hdone: fs1 ##ₘ fs2 by eapply (ls_map_disj δ z1 z2). + apply map_disjoint_dom in Hdone. + set_solver. + + destruct (decide (z2 = ζ)) as [->|Hneq3]. + ** rewrite lookup_insert in Hlk2. simplify_eq. + have ?: ρ ∈ dom fs by set_solver. + apply Hneq. by eapply ls_map_agree. + ** rewrite lookup_insert_ne // /data' in Hlk2. + have Hdone: fs1 ##ₘ fs2 by eapply (ls_map_disj δ z1 z2). + apply map_disjoint_dom in Hdone. + set_solver. } + { intros ρ Hlive. destruct (ls_map_live δ ρ Hlive) as (ζ0&fs0&?&?). + destruct (decide (ζ = ζ0)) as [->|]. + - have Hin: ρ ∈ dom fs' ∪ dom fs''. + { simpl in Hlive. simplify_eq. clear Hincl' Hincl''. + destruct (decide (ρ ∈ dom fs' ∪ dom fs'')); [done|set_solver]. } + apply elem_of_union in Hin as [Hin|Hin]. + + exists ζ0, fs'. rewrite lookup_insert //. + + destruct oζ' as [ζn|]; last naive_solver. + exists ζn, fs''. split=>//=. rewrite /data'' /data' lookup_insert_ne // ?lookup_insert //. + intros ->. eapply Hnlocale; eauto. by eapply elem_of_dom_2. + - exists ζ0, fs0. split; last done. rewrite /data'' /data' lookup_insert_ne // ?lookup_insert //. + destruct oζ' as [ζn|]; last naive_solver. rewrite lookup_insert_ne //. + intros ->. eapply Hnlocale; eauto. by eapply elem_of_dom_2. } } + exists δ'. split; first done. + constructor. + { destruct (map_choose _ Hnemp) as (ρ&?&?). exists ρ. eapply ls_mapping_data; eauto. + apply elem_of_dom. naive_solver. } + split; [|split; [| split; [|by rewrite Hd//]]]. + - rewrite /fuel_decr /=. intros ρ' Hin Hin' Hmd. + apply elem_of_dom in Hin as [f Hf]. + apply elem_of_dom in Hin' as [f' Hf']. + rewrite Hf Hf' /=. + inversion Hmd; simplify_eq. + + symmetry in Hsametid. + apply ls_mapping_data_inv in Hsametid as (fs0&Hmap0&Hin0). + simplify_eq. + apply ls_fuel_data_inv in Hf as (ζ'&fs0&?&?). + have [??] : ζ' = ζ ∧ fs0 = fs. + { eapply ls_map_agree; eauto. apply elem_of_dom; naive_solver. } + simplify_eq. + apply ls_fuel_data_inv in Hf' as (ζ2&fs2&Hmap'&Hfs2). + rewrite Hd /= /data'' in Hmap'. destruct (decide (ζ = ζ2)) as [->|Hneq]. + { rewrite lookup_insert in Hmap'. simplify_eq. + destruct (Hfs' _ _ Hfs2). naive_solver. } + rewrite lookup_insert_ne // /data' in Hmap'. destruct (oζ') as [ζn|]. + * destruct (decide (ζn = ζ2)) as [->|Hneqζ]. + ** rewrite lookup_insert in Hmap'. simplify_eq. + destruct (Hfs'' _ _ Hfs2). naive_solver. + ** rewrite lookup_insert_ne // in Hmap'. + have [??] : ζ2 = ζ ∧ fs2 = fs; last by simplify_eq. + eapply ls_map_agree; eauto. apply elem_of_dom; naive_solver. + * have [??] : ζ2 = ζ ∧ fs2 = fs; last by simplify_eq. + eapply ls_map_agree; eauto. apply elem_of_dom; naive_solver. + + destruct Hissome as [ζ0 Hlk0]. + rewrite Hlk0 in Hneqtid. + apply ls_fuel_data_inv in Hf as (ζ'&fs0&?&?). + apply ls_fuel_data_inv in Hf' as (ζ2&fs2&Hmap'&Hfs2). + apply ls_mapping_data_inv in Hlk0 as (fs3&Hmap3&Hdom3). + have [??] : ζ0 = ζ2 ∧ fs3 = fs2. + { eapply ls_map_agree; eauto. apply elem_of_dom; naive_solver. } + simplify_eq. + rewrite Hd /data'' /= in Hmap'. destruct (decide (ζ2 = ζ)); first simplify_eq. + * rewrite lookup_insert in Hmap'. symmetry in Hmap'. simplify_eq. + destruct (Hfs' _ _ Hfs2) as (?&?&?). exfalso; apply Hneqtid. + rewrite (ls_mapping_data ρ' δ ζ fs) in Hneqtid; [done|done|apply elem_of_dom; naive_solver]. + * rewrite lookup_insert_ne // /data' in Hmap'. destruct oζ' as [ζn|]. destruct (decide (ζ2 = ζn)). + ** simplify_eq. rewrite lookup_insert in Hmap'. simplify_eq. + destruct (Hfs'' _ _ Hfs2) as (ff&?&?). + have [??] : ζ' = ζ ∧ fs0 = fs; last by simplify_eq. + eapply ls_map_agree; eauto; apply elem_of_dom; naive_solver. + ** rewrite lookup_insert_ne // in Hmap'. exfalso; apply Hneqtid. + rewrite (ls_mapping_data ρ' δ ζ2 fs2) in Hneqtid; done. + ** have [??] : ζ' = ζ2 ∧ fs0 = fs2; last simplify_eq. + { eapply ls_map_agree; eauto; apply elem_of_dom; naive_solver. } + exfalso; apply Hneqtid. + eapply ls_mapping_data; eauto. + - rewrite /fuel_must_not_incr. intros ρ' Hin' _. + apply elem_of_dom in Hin' as [f Hf]. rewrite Hf. + apply ls_fuel_data_inv in Hf as (ζ'&fs0&Hmap&Hlk). + destruct (decide (ζ' = ζ)) as [->|]. + + have ? : fs0 = fs by naive_solver. simplify_eq. + destruct (decide (ρ' ∈ dom fs' ∪ dom fs'')) as [[Hin|Hin]%elem_of_union|Hnin]. + * left. apply elem_of_dom in Hin as [f' Hlk']. + destruct (Hfs' _ _ Hlk') as (?&?&?). + have -> /= : ls_fuel δ' !! ρ' = Some f'. + { eapply (ls_fuel_data _ _ ζ); eauto. rewrite Hd /data'' /= lookup_insert //. } + naive_solver lia. + * left. apply elem_of_dom in Hin as [f' Hlk']. + destruct (Hfs'' _ _ Hlk') as (?&?&?). + have -> /= : ls_fuel δ' !! ρ' = Some f'. + destruct oζ' as [ζn|]; last set_solver. + { eapply (ls_fuel_data _ _ ζn); eauto. + rewrite Hd /data'' /= lookup_insert_ne // /data' ?lookup_insert //. + intros ->. eapply Hnlocale; eauto. by eapply elem_of_dom_2. } + naive_solver lia. + * have Hdead: ρ' ∉ live_roles _ δ. + { eapply elem_of_dom_2 in Hlk. set_solver. } + right. split; last done. intros Habs. apply ls_fuel_dom_data_inv in Habs as (ζa&fsa&Hlka&Hina). + rewrite Hd /data'' /= in Hlka. + destruct (decide (ζa = ζ)). + { simplify_eq. rewrite lookup_insert in Hlka. simplify_eq. set_solver. } + rewrite lookup_insert_ne // /data' in Hlka. + destruct oζ' as [ζn|]. + ** destruct (decide (ζa = ζn)). + { simplify_eq. rewrite lookup_insert in Hlka. simplify_eq. set_solver. } + rewrite lookup_insert_ne // in Hlka. + have [??] : ζ = ζa ∧ fs = fsa; last done. + eapply ls_map_agree; eauto; apply elem_of_dom; naive_solver. + ** have [??] : ζ = ζa ∧ fs = fsa; last done. + eapply ls_map_agree; eauto; apply elem_of_dom; naive_solver. + + left. have ->: ls_fuel δ' !! ρ' = Some f; last naive_solver. + eapply (ls_fuel_data _ _ ζ'); eauto. + rewrite Hd /data'' /= lookup_insert_ne // /data'. destruct oζ' as [ζn|]; last done. + rewrite lookup_insert_ne //. intros ->. apply (Hnlocale ζ'); eauto. + by eapply elem_of_dom_2. + - intros ρ Hin. apply ls_fuel_dom_data_inv in Hin as (ζ0&fs0&Hlk0&Hin0). + rewrite Hd /data'' /= in Hlk0. destruct (decide (ζ0 = ζ)) as [->|]. + + rewrite lookup_insert in Hlk0. simplify_eq. eapply ls_fuel_dom_data; eauto. + + rewrite lookup_insert_ne // /data' in Hlk0. + destruct oζ' as [ζn|]. + * destruct (decide (ζ0 = ζn)) as [->|]. + ** rewrite lookup_insert in Hlk0. simplify_eq. eapply ls_fuel_dom_data; eauto. + ** rewrite lookup_insert_ne // /data' in Hlk0. eapply ls_fuel_dom_data; eauto. + * eapply ls_fuel_dom_data; eauto. + Qed. + + Lemma model_step_suff_data fl (δ: LiveState) ρ0 fmact0 m' (fs fs': gmap _ nat) ζ act : + fmtrans _ δ (inl (ρ0, fmact0)) m' → + δ.(ls_map) !! ζ = Some fs → + ρ0 ∈ dom fs → + (∀ ρ f f', fs' !! ρ = Some f' → ρ ≠ ρ0 → fs !! ρ = Some f → f' < f) → + (∀ f'0, fs' !! ρ0 = Some f'0 → f'0 ≤ fl m') → + (∀ ρ, ρ ∈ dom fs' ∖ dom fs → ∀ f', fs' !! ρ = Some f' → f' ≤ fl m') → + (M.(live_roles) m' ∖ M.(live_roles) δ = dom fs' ∖ dom fs) → + (∀ ρ, ρ ∈ M.(live_roles) m' ∖ M.(live_roles) δ → ∀ ζ' fs', δ.(ls_map) !! ζ' = Some fs' → ρ ∉ dom fs') → + (dom fs ∖ dom fs' ∩ M.(live_roles) δ = ∅) → + let data' := <[ζ := fs']> δ.(ls_map) in + ∃ δ', δ'.(ls_data) = {| ls_under := m'; ls_map := data' |} ∧ + ls_trans fl δ (Take_step ρ0 fmact0 ζ act) δ'. + Proof. + intros Htrans Hζ Hρ0in Hfs' Hfl0 Hfln Hborn Hnew Hdead data'. + assert (∃ δ', δ'.(ls_data) = {| ls_under := m'; ls_map := data' |}) as [δ' Hd]. + { unshelve refine (ex_intro _ {| ls_data := {| ls_under := m'; ls_map := data' |} |} _); last done. + { rewrite /data' /=. intros z1 z2 fs1 fs2 Hneq Hlk1 Hlk2. apply map_disjoint_dom_2. + intros ρ Hin1 Hin2. + destruct (decide (z1 = ζ)) as [->|Hneq1]; destruct (decide (z2 = ζ)) as [->|Hneq2] =>//. + - rewrite lookup_insert in Hlk1. rewrite lookup_insert_ne // in Hlk2. simplify_eq. + destruct (decide (ρ ∈ dom fs)). + + have Hdone: fs ##ₘ fs2 by eapply (ls_map_disj δ ζ z2). + apply map_disjoint_dom in Hdone. set_solver. + + have Hdone: ρ ∉ dom fs2; last done. eapply Hnew. set_solver. done. + - rewrite lookup_insert in Hlk2. rewrite lookup_insert_ne // in Hlk1. simplify_eq. + destruct (decide (ρ ∈ dom fs)). + + have Hdone: fs ##ₘ fs1 by eapply (ls_map_disj δ ζ z1). + apply map_disjoint_dom in Hdone. set_solver. + + have Hdone: ρ ∉ dom fs1; last done. eapply Hnew. set_solver. done. + - rewrite lookup_insert_ne // in Hlk1. rewrite lookup_insert_ne // in Hlk2. + have Hdone: fs1 ##ₘ fs2 by eapply (ls_map_disj δ z1 z2). + apply map_disjoint_dom in Hdone. set_solver. } + { simpl. intros ρ Hlive. destruct (decide (ρ ∈ live_roles _ δ)) as [Hwaslive|Hnewborn]. + - destruct (ls_map_live δ ρ Hwaslive) as (ζ'&fs''&Hlk&Hdom). destruct (decide (ζ = ζ')). + + simplify_eq. exists ζ', fs'. rewrite lookup_insert. split; first done. set_solver. + + exists ζ', fs''. rewrite lookup_insert_ne //. + - exists ζ, fs'. rewrite lookup_insert. split; first done. set_solver. } } + have H0live: ρ0 ∈ live_roles _ δ by eapply fm_live_spec. + have Hζ' : ls_map δ' !! ζ = Some fs' by rewrite Hd lookup_insert //. + exists δ'. split; first done. constructor; first by rewrite Hd //. + + have Hdom: dom (ls_fuel δ') ∖ dom (ls_fuel δ) ⊆ live_roles M δ' ∖ live_roles M δ. + { intros ρ [Hin Hnin]%elem_of_difference. rewrite Hd Hborn. + apply elem_of_dom in Hin as [f' Hin]. + apply ls_fuel_data_inv in Hin as (ζ1&fs1&Hlk1&Hlk'1). + destruct (decide (ζ1 = ζ)); first simplify_eq; last first. + { rewrite Hd lookup_insert_ne // in Hlk1. exfalso. apply Hnin. + eapply ls_fuel_dom_data=>//. by apply elem_of_dom_2 in Hlk'1. } + apply elem_of_difference. split; first by apply elem_of_dom_2 in Hlk'1. + intros Hina. apply Hnin. eapply ls_fuel_dom_data=>//. } + + split; [| split; [| split; [| split; [| split; [| done]]]]]. + - eapply ls_mapping_data =>//. + - intros ρ Hin Hin' Hmd. + apply elem_of_dom in Hin as [f Hf]. + apply elem_of_dom in Hin' as [f' Hf']. + rewrite Hf Hf' /=. inversion Hmd; simplify_eq. + + symmetry in Hsametid. apply ls_mapping_data_inv in Hsametid as (fs1&Hlk1&Hin1). + rewrite Hζ in Hlk1. symmetry in Hlk1. simplify_eq. + apply ls_fuel_data_inv in Hf as (ζ1&fs1&Hlk1&Hlk'1). + have [??] : ζ1 = ζ ∧ fs1 = fs; last simplify_eq. + { eapply (ls_map_agree (ρ := ρ) Hlk1); eauto. by apply elem_of_dom_2 in Hlk'1. } + + apply ls_fuel_data_inv in Hf' as (ζ2&fs2&Hlk2&Hlk'2). + destruct (decide (ζ2 = ζ)); last first. + { rewrite Hd lookup_insert_ne // in Hlk2. + have [??] : ζ2 = ζ ∧ fs2 = fs; last simplify_eq. + eapply (ls_map_agree (ρ := ρ) Hlk2); eauto. by apply elem_of_dom_2 in Hlk'2. } + simplify_eq. eapply Hfs'=>//. naive_solver. + + exfalso. destruct Hissome as [ζ1 Hmap]. have Hmap' := Hmap. + apply ls_mapping_data_inv in Hmap as (fs1&Hlk&YHin). + destruct (decide (ζ1 = ζ)) as [->|]. + * simplify_eq. have ?: ρ ∈ dom fs. + { apply ls_fuel_data_inv in Hf as (ζ1&fs1&Hlk1&Hlk'1). + destruct (decide (ρ ∈ dom fs)); first done. exfalso. + eapply Hnew; eauto; last by apply elem_of_dom_2 in Hlk'1. + rewrite Hborn. set_solver. } + apply Hneqtid. rewrite Hmap'. by eapply ls_mapping_data. + * apply Hneqtid. rewrite Hmap'. + eapply ls_mapping_data=>//. + rewrite Hd lookup_insert_ne // in Hlk. + - intros ρ Hin Hneq. apply ls_fuel_dom_data_inv in Hin as (ζ1&fs1&Hlk1&Hdom1). + destruct (decide (ζ1 = ζ)). + + simplify_eq. destruct (decide (ρ ∈ dom fs')) as [Hin|]; [left| right; split; [|set_solver]]. + * apply elem_of_dom in Hin as [f' Hf']. + have ->: ls_fuel δ' !! ρ = Some f' by eapply ls_fuel_data. + apply elem_of_dom in Hdom1 as [f Hf]. + have -> /=: ls_fuel δ !! ρ = Some f by eapply ls_fuel_data. + naive_solver lia. + * intros Ha. apply ls_fuel_dom_data_inv in Ha as (ζ1&fs1&Hlk1&Hin1). + destruct (decide (ζ1 = ζ)) as [|Hneq1]; first naive_solver. + rewrite Hd lookup_insert_ne // in Hlk1. apply Hneq1. + by eapply ls_map_agree. + + left. apply elem_of_dom in Hdom1 as (f'&Hf'). + have ->: ls_fuel δ' !! ρ = Some f'. + { eapply (ls_fuel_data _ _ ζ1); eauto. rewrite Hd lookup_insert_ne //. } + have ->: ls_fuel δ !! ρ = Some f'. + { eapply (ls_fuel_data _ _ ζ1); eauto. } + naive_solver. + - intros. have H0dom: ρ0 ∈ dom fs' by set_solver. apply elem_of_dom in H0dom as [f' Hf']. + rewrite (ls_fuel_data _ _ _ _ _ Hζ' Hf') Hd /=. by eapply Hfl0. + - intros ρ [Hρin Hρnin]%elem_of_difference. + have Hn: ρ ∈ dom fs' ∖ dom fs. + { rewrite -Hborn. rewrite elem_of_subseteq {2}Hd /= in Hdom. apply Hdom. set_solver. } + apply elem_of_dom in Hρin as [f' Hρin]. rewrite Hρin. + apply ls_fuel_data_inv in Hρin as (ζ1&fs1&Hlk1&Hlk'1). simpl. rewrite Hd /=. + apply elem_of_difference in Hn as [Hn1 Hn2]. + have [??] : ζ1 = ζ ∧ fs1 = fs'. + { eapply ls_map_agree=>//. by apply elem_of_dom_2 in Hlk'1. } + simplify_eq. eapply Hfln; last done. by apply elem_of_difference. + Qed. + + Record LiveModel := { + lm_ls := LiveState; + lm_lbl := FairLabel M; + lm_ls_trans (δ: LiveState) (ℓ: FairLabel M) := ls_trans fm_fl δ ℓ; + lm_cfg_labels_match : config_label Λ → fmconfig M → Prop; + lm_actions_match : option (action Λ) → fmaction M → Prop; + }. + + Definition live_model_model `(LM : LiveModel) : Model := {| + mstate := lm_ls LM; + mlabel := lm_lbl LM; + mtrans := lm_ls_trans LM; + |}. + + Definition tids_smaller (c : list (expr Λ)) (δ: LiveState) := + ∀ ζ, ζ ∈ dom $ ls_map δ -> is_Some (from_locale c ζ). + + Program Definition initial_ls `{LM: LiveModel} (s0: M) (ζ0: locale Λ) + : LM.(lm_ls) := + {| ls_data := {| ls_under := s0; + ls_map := {[ζ0 := gset_to_gmap (fm_fl s0) (M.(live_roles) s0)]}; + |} |}. + Next Obligation. + intros ???????? Hlk1 Hlk2. simpl in *. exfalso. + apply lookup_singleton_Some in Hlk1. + apply lookup_singleton_Some in Hlk2. + naive_solver. + Qed. + Next Obligation. + intros ?? ζ ??. eexists ζ, _. rewrite lookup_singleton. split; eauto. + rewrite dom_gset_to_gmap //. + Qed. + + Definition labels_match `{LM:LiveModel} (pl : locale_label Λ + config_label Λ) (ℓ : LM.(lm_lbl)) : Prop := + match pl, ℓ with + | inr cfg, Config_step fmcfg cfg' => cfg = cfg' ∧ lm_cfg_labels_match LM cfg fmcfg + | inl (ζ, act), Silent_step ζ' act' => ζ = ζ' ∧ act = act' ∧ act = None + | inl (ζ, act), Take_step ρ fmact ζ' act' => ζ = ζ' ∧ act = act' ∧ lm_actions_match LM act fmact + | _, _ => False + end. +End fairness. + +Arguments LiveState _ _ {_ _}. +Arguments LiveStateData _ _ {_ _}. +Arguments LiveModel _ _ {_ _}. +Arguments live_model_model _ {_ _ _} _. + +Definition live_model_to_model Λ M `{Countable (locale Λ)} : LiveModel Λ M -> Model := + λ lm, live_model_model Λ lm. +Coercion live_model_to_model : LiveModel >-> Model. +Arguments live_model_to_model {_ _ _ _}. + +Definition auxtrace {Λ M} `{Countable (locale Λ)} (LM: LiveModel Λ M) := trace LM.(lm_ls) LM.(lm_lbl). + +Section aux_trace. + Context `{Countable (locale Λ)} `{LM: LiveModel Λ M}. + + Definition role_enabled ρ (δ: LiveState Λ M) := ρ ∈ M.(live_roles) δ. + + Definition fair_aux ρ (auxtr: auxtrace LM): Prop := + forall n, pred_at auxtr n (λ δ _, role_enabled ρ δ) -> + ∃ m, pred_at auxtr (n+m) (λ δ ℓ, ¬role_enabled ρ δ ∨ + ∃ tid fmact act, ℓ = Some (Take_step ρ fmact tid act)). + + Lemma fair_aux_after ρ auxtr n auxtr': + fair_aux ρ auxtr -> + after n auxtr = Some auxtr' -> + fair_aux ρ auxtr'. + Proof. + rewrite /fair_aux => Hfair Hafter m Hpa. + specialize (Hfair (n+m)). + rewrite -> (pred_at_sum _ n) in Hfair. rewrite Hafter in Hfair. + destruct (Hfair Hpa) as (p&Hp). + exists (p). by rewrite <-Nat.add_assoc, ->!(pred_at_sum _ n), Hafter in Hp. + Qed. + + CoInductive auxtrace_valid: auxtrace LM -> Prop := + | auxtrace_valid_singleton δ: auxtrace_valid ⟨δ⟩ + | auxtrace_valid_cons (δ: LiveState Λ M) ℓ (tr: auxtrace LM): + LM.(lm_ls_trans) δ ℓ (trfirst tr) -> + auxtrace_valid tr → + auxtrace_valid (δ -[ℓ]-> tr). + + Lemma auxtrace_valid_forall (tr: auxtrace LM) : + auxtrace_valid tr -> + ∀ n, match after n tr with + | Some ⟨ _ ⟩ | None => True + | Some (δ -[ℓ]-> tr') => LM.(lm_ls_trans) δ ℓ (trfirst tr') + end. + Proof. + intros Hval n. revert tr Hval. induction n as [|n]; intros tr Hval; + destruct (after _ tr) as [trn|] eqn: Heq =>//; simpl in Heq; + simplify_eq; destruct trn =>//; inversion Hval; simplify_eq; try done. + specialize (IHn _ H1) (* TODO *). rewrite Heq in IHn. done. + Qed. + +End aux_trace. + +Ltac SS := + epose proof ls_fuel_dom; + (* epose proof ls_mapping_dom; *) + set_solver. + +Definition live_tids `{Countable (locale Λ)} `{LM:LiveModel Λ M} + (c : cfg Λ) (δ : LM.(lm_ls)) : Prop := + (∀ ρ ζ, ls_mapping δ !! ρ = Some ζ -> is_Some (from_locale c.1 ζ)) ∧ + ∀ ζ e, from_locale c.1 ζ = Some e -> (to_val e ≠ None) -> + ∀ ρ, ls_mapping δ !! ρ = Some ζ → ρ ∉ M.(live_roles) δ. + +Definition exaux_traces_match `{Countable (locale Λ)} `{LM:LiveModel Λ M} : + extrace Λ → auxtrace LM → Prop := + traces_match labels_match + live_tids + locale_step + LM.(lm_ls_trans). + +Definition exaux_tme `{Countable (locale Λ)} `{LM:LiveModel Λ M} := + ltl_tme (labels_match (LM := LM)) + (live_tids (LM := LM)) + locale_step + LM.(lm_ls_trans). + +Section fairness_preserved. + Context `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + Implicit Type δ : LiveState Λ M. + + Lemma exaux_preserves_validity extr (auxtr : auxtrace LM): + exaux_traces_match extr auxtr -> + auxtrace_valid auxtr. + Proof. + revert extr auxtr. cofix CH. intros extr auxtr Hmatch. + inversion Hmatch; first by constructor. + constructor =>//. by eapply CH. + Qed. + + Lemma exaux_preserves_termination extr (auxtr : auxtrace LM) : + exaux_traces_match extr auxtr -> + terminating_trace auxtr -> + terminating_trace extr. + Proof. + intros Hmatch [n HNone]. + revert extr auxtr Hmatch HNone. induction n as [|n IHn]; first done. + intros extr auxtr Hmatch HNone. + replace (S n) with (1 + n) in HNone =>//. + rewrite (after_sum' _ 1) in HNone. + destruct auxtr as [s| s ℓ auxtr']; + first by inversion Hmatch; simplify_eq; exists 1. + simpl in HNone. + inversion Hmatch; simplify_eq. + apply terminating_trace_cons. + eapply IHn =>//. + Qed. + + Lemma traces_match_labels tid act ℓ c δ rex (raux : auxtrace LM) : + exaux_traces_match (c -[inl (tid, act)]-> rex) (δ -[ℓ]-> raux) -> + ((∃ ρ fmact, ℓ = Take_step ρ fmact tid act) ∨ (ℓ = Silent_step tid act)). + Proof. + intros Hm. inversion Hm as [|?????? Hlab]; simplify_eq. + destruct ℓ; destruct act; + inversion Hlab; simplify_eq; naive_solver. + Qed. + + Lemma mapping_live_role (δ: LiveState Λ M) ρ: + ρ ∈ M.(live_roles) δ -> + is_Some (ls_mapping (Λ := Λ) δ !! ρ). + Proof. rewrite -elem_of_dom ls_same_doms. SS. Qed. + Lemma fuel_live_role (δ: LiveState Λ M) ρ: + ρ ∈ M.(live_roles) δ -> + is_Some (ls_fuel (Λ := Λ) δ !! ρ). + Proof. rewrite -elem_of_dom. SS. Qed. + + Local Hint Resolve mapping_live_role: core. + Local Hint Resolve fuel_live_role: core. + + Lemma match_locale_enabled (extr : extrace Λ) (auxtr : auxtrace LM) ζ ρ: + ρ ∈ M.(live_roles) (trfirst auxtr) → + exaux_traces_match extr auxtr -> + ls_mapping (trfirst auxtr) !! ρ = Some ζ -> + locale_enabled ζ (trfirst extr). + Proof. + intros Hlive Hm Hloc. + rewrite /locale_enabled. have [HiS Hneqloc] := traces_match_first _ _ _ _ _ _ Hm. + have [e Hein] := (HiS _ _ Hloc). exists e. split; first done. + destruct (to_val e) eqn:Heqe =>//. + exfalso. specialize (Hneqloc ζ e Hein). rewrite Heqe in Hneqloc. + have Hv: Some v ≠ None by []. by specialize (Hneqloc Hv ρ Hloc). + Qed. + + Local Hint Resolve match_locale_enabled: core. + Local Hint Resolve pred_first_trace: core. + + Definition fairness_induction_stmt ρ fm f m ζ extr (auxtr : auxtrace LM) δ c := + (forall ζ, fair_scheduling_ex ζ extr) -> + fm = (f, m) -> + exaux_traces_match extr auxtr -> + c = trfirst extr -> δ = trfirst auxtr -> + ls_fuel δ !! ρ = Some f -> + ls_mapping δ !! ρ = Some ζ -> + (pred_at extr m (λ c oζ, ¬locale_enabled ζ c ∨ ∃ act, oζ = Some (inl (ζ, act)))) -> + ∃ M, pred_at auxtr M (λ δ ℓ, ¬role_enabled ρ δ ∨ ∃ ζ0 fmact act, ℓ = Some (Take_step ρ fmact ζ0 act)). + + Local Lemma case1 ρ f m (extr' : extrace Λ) (auxtr' : auxtrace LM) δ ℓ : + (∀ m0 : nat * nat, + strict lt_lex m0 (f, m) + → ∀ (f m: nat) (ζ: locale Λ) (extr : extrace Λ) (auxtr : auxtrace LM) + (δ : LiveState Λ M) (c : cfg Λ), fairness_induction_stmt ρ m0 f m ζ extr auxtr δ c) -> + (ρ ∈ dom (ls_fuel (trfirst auxtr')) → oless (ls_fuel (trfirst auxtr') !! ρ) (ls_fuel δ !! ρ)) -> + exaux_traces_match extr' auxtr' -> + ls_fuel δ !! ρ = Some f -> + (∀ ζ, fair_scheduling_ex ζ extr') -> + ∃ M0 : nat, + pred_at (δ -[ ℓ ]-> auxtr') M0 + (λ δ0 ℓ, ¬ role_enabled ρ δ0 ∨ ∃ ζ0 fmact act, ℓ = Some (Take_step ρ fmact ζ0 act)). + Proof. + intros IH Hdec Hmatch Hsome Hfair. + unfold oless in Hdec. + simpl in *. + rewrite -> Hsome in *. + destruct (ls_fuel (trfirst auxtr') !! ρ) as [f'|] eqn:Heq. + - destruct (decide (ρ ∈ live_roles M (trfirst auxtr'))) as [Hρlive'|]; last first. + { exists 1. unfold pred_at. simpl. destruct auxtr'; eauto. } + have [ζ' Hζ'] : is_Some (ls_mapping (trfirst auxtr') !! ρ) by eauto. + + have Hloc'en: pred_at extr' 0 (λ (c : cfg Λ) (_ : option $ ex_label Λ), + locale_enabled ζ' c). + { rewrite /pred_at /= pred_first_trace. eauto. } + + have [p Hp] := (Hfair ζ' 0 Hloc'en). + have [P Hind] : ∃ M0 : nat, pred_at auxtr' M0 (λ (δ0 : LiveState Λ M) ℓ, ¬ role_enabled ρ δ0 ∨ + ∃ ζ0 fmact act, ℓ = Some (Take_step ρ fmact ζ0 act)). + { eapply (IH (f', p) _ f' p ζ' extr' auxtr'); eauto. + Unshelve. unfold strict, lt_lex. specialize (Hdec ltac:(by eapply elem_of_dom_2)). lia. } + exists (1+P). rewrite !pred_at_sum. simpl. done. + - exists 1. rewrite /pred_at /=. rewrite /role_enabled. + destruct auxtr' =>/=; left. + + apply not_elem_of_dom in Heq; eapply not_elem_of_weaken; last (by apply ls_fuel_dom); set_solver. + + apply not_elem_of_dom in Heq; eapply not_elem_of_weaken; last (by apply ls_fuel_dom); set_solver. + Qed. + + Lemma fairness_preserved_ind ρ: + ∀ fm f m ζ (extr: extrace Λ) (auxtr: auxtrace LM) δ c, + fairness_induction_stmt ρ fm f m ζ extr auxtr δ c. + Proof. + induction fm as [fm IH] using lex_ind. + intros f m ζ extr auxtr δ c Hfair -> Htm -> -> Hfuel Hmapping Hexen. + destruct extr as [|c ζ' extr'] eqn:Heq. + { destruct m=>//. rewrite /pred_at /= in Hexen. exists 0. rewrite /pred_at /=. + inversion Htm; simplify_eq. left. destruct Hexen as [Hnen|[]]=>//. + destruct H1 as [Hloc Hl]. + destruct (Hloc ρ ζ Hmapping) as [e He]. eapply Hl=>//. + intros Hc. apply Hnen. exists e=>//. } + have Hfair': (forall ζ, fair_scheduling_ex ζ extr'). + { intros. by eapply fair_scheduling_ex_cons. } + destruct auxtr as [|δ ℓ auxtr']; first by inversion Htm. + destruct (decide (ρ ∈ live_roles M δ)) as [Hρlive|]; last first. + { exists 0. left. unfold pred_at. simpl. intros contra. eauto. } + destruct ζ' as [[ζ' act]|cfg]; last first. + { simplify_eq. simpl in Htm. + inversion Htm as [|??????? Hlive ? Htrans]; simplify_eq. destruct ℓ as [| |]=>//. + simpl in *. simplify_eq. destruct Htrans as [?[Hmap ?]]. + destruct m as [|m]. + { exfalso. rewrite /pred_at /= in Hexen. destruct Hexen as [Hlocale|]; [|naive_solver]. + destruct Hlive as [Hen Hlive]. + assert (ρ ∉ live_roles M δ); last set_solver. + destruct (Hen _ _ Hmapping). rewrite /locale_enabled in Hlocale. naive_solver. } + apply pred_at_S in Hexen. + ospecialize (IH (f, m) _). + { rewrite /strict /lt_lex. lia. } + rewrite /fairness_induction_stmt in IH. + odestruct (IH f m ζ extr' _ _ _ _ _ _ _ _ _ _ Hexen) as [M' HM']; try done. + { rewrite /ls_fuel -Hmap //. } + { rewrite /ls_mapping -Hmap //. } + exists (S M'). by apply pred_at_S. } + destruct (decide (ζ = ζ')) as [Hζ|Hζ]. + - rewrite <- Hζ in *. simplify_eq. + destruct (traces_match_labels _ _ _ _ _ _ _ Htm) as [[ρ' [? ->]]| ->]; last first. + + inversion Htm as [|s1 ℓ1 r1 s2 ℓ2 r2 Hl Hs Hts Hls Hmatchrest]; simplify_eq. + unfold ls_trans in Hls. + destruct Hls as (? & Hlsdec & Hlsincr). + unfold fuel_decr in Hlsdec. + have Hmustdec: must_decrease ρ None δ (trfirst auxtr') (Some ζ'). + { constructor; eauto. } + eapply case1 =>//. + move=> Hinfuel; apply Hlsdec => //; first set_solver. + + (* Three cases: *) +(* (1) ρ' = ρ and we are done *) +(* (2) ρ' ≠ ρ but they share the same ρ -> ρ decreases *) +(* (3) ρ' ≠ ρ and they don't have the same tid -> *) +(* impossible because tid and the label must match! *) + inversion Htm as [|s1 ℓ1 r1 s2 ℓ2 r2 Hl Hs Hts Hls Hmatchrest]; simplify_eq. + destruct (decide (ρ = ρ')) as [->|Hρneq]. + { exists 0. right. rewrite /pred_at /=. eauto. } + destruct Hls as (?&Hsame&Hdec&Hnotinc&_). + rewrite -Hsame /= in Hmapping. + have Hmustdec: must_decrease ρ (Some ρ') δ (trfirst auxtr') (Some ζ'). + { constructor; eauto; congruence. } + (* Copy and paste begins here *) + eapply case1 =>//. + intros Hinfuels. apply Hdec =>//. SS. + - (* Another thread is taking a step. *) + destruct (decide (ρ ∈ live_roles M (trfirst auxtr'))) as [Hρlive'|]; last first. + { exists 1. unfold pred_at. simpl. destruct auxtr'; eauto. } + have [ζ'' Hζ''] : is_Some (ls_mapping (trfirst auxtr') !! ρ) by eauto. + destruct (decide (ζ = ζ'')) as [<-|Hchange]. + + have [f' [Hfuel' Hff']] : exists f', ls_fuel (trfirst auxtr') !! ρ = Some f' ∧ f' ≤ f. + { inversion Htm as [|s1 ℓ1 r1 s2 ℓ2 r2 Hl Hs Hts Hls Hmatchrest]; simplify_eq. + simpl in *. destruct ℓ as [ρ0 ζ0| ζ0|]. + + destruct Hls as (?&?&?&Hnoninc&?); + destruct Hl; simplify_eq. + unfold fuel_must_not_incr in Hnoninc. + have Hneq: Some ρ ≠ Some ρ0 by congruence. + specialize (Hnoninc ρ ltac:(SS) Hneq). + unfold oleq in Hnoninc. rewrite Hfuel in Hnoninc. + destruct (ls_fuel (trfirst auxtr') !! ρ) as [f'|] eqn:Heq; [|set_solver]. + eexists; split =>//. destruct Hnoninc as [Hnoninc|Hnoninc]=>//. + apply elem_of_dom_2 in Heq. set_solver. + + destruct Hls as (?&?&Hnoninc&?); destruct act; + destruct Hl; simplify_eq; first naive_solver. + unfold fuel_must_not_incr in Hnoninc. + have Hneq: Some ρ ≠ None by congruence. + specialize (Hnoninc ρ ltac:(SS) Hneq). + unfold oleq in Hnoninc. rewrite Hfuel in Hnoninc. + destruct (ls_fuel (trfirst auxtr') !! ρ) as [f'|] eqn:Heq; [|set_solver]. + eexists; split =>//. destruct Hnoninc as [Hnoninc|Hnoninc]=>//. + apply elem_of_dom_2 in Heq. set_solver. + + destruct act=>//. + } + unfold fair_scheduling_ex in *. + have Hζ'en: pred_at extr' 0 (λ (c : cfg Λ) _, locale_enabled ζ c). + { rewrite /pred_at /= pred_first_trace. inversion Htm; eauto. } + destruct m as [| m']. + { rewrite -> !pred_at_0 in Hexen. destruct Hexen as [Hexen|Hexen]. + - exfalso. apply Hexen. unfold locale_enabled. by eapply (match_locale_enabled _ _ _ _ _ Htm). + - simplify_eq. naive_solver. } + + have [P Hind] : ∃ M0 : nat, pred_at auxtr' M0 (λ δ0 ℓ, ¬ role_enabled ρ δ0 ∨ + ∃ ζ0 fmact act, ℓ = Some $ Take_step ρ fmact ζ0 act). + { eapply (IH _ _ _ m' _ extr'); eauto. by inversion Htm. + Unshelve. + - done. + - unfold strict, lt_lex. lia. } + exists (1+P). rewrite !pred_at_sum. simpl. done. + + have [f' [Hfuel' Hff']] : exists f', ls_fuel (trfirst auxtr') !! ρ = Some f' ∧ f' < f. + { inversion Htm as [|s1 ℓ1 r1 s2 ℓ2 r2 Hl Hs Hts Hls Hmatchrest]; simplify_eq. + simpl in *. destruct ℓ as [ρ0 ? ζ0 ?| ζ0|]. + + destruct Hls as (?&?&Hdec&?&?); + unfold fuel_decr in Hdec; destruct Hl; simplify_eq. + have Hmd: must_decrease ρ (Some ρ0) δ (trfirst auxtr') (Some ζ0). + { econstructor 2. congruence. rewrite Hζ''; eauto. } + specialize (Hdec ρ ltac:(SS) ltac:(SS) Hmd). + unfold oleq in Hdec. rewrite Hfuel in Hdec. + destruct (ls_fuel (trfirst auxtr') !! ρ) as [f'|] eqn:Heq; [by eexists|done]. + + destruct Hls as (?&Hdec&_). + unfold fuel_decr in Hdec. simplify_eq. + have Hmd: must_decrease ρ None δ (trfirst auxtr') (Some ζ0). + { econstructor 2. congruence. rewrite Hζ''; eauto. } + specialize (Hdec ρ ltac:(SS) ltac:(SS) Hmd). + unfold oleq in Hdec. rewrite Hfuel in Hdec. + destruct (ls_fuel (trfirst auxtr') !! ρ) as [f'|] eqn:Heq; [by eexists|done]. + + destruct act=>//. } + + unfold fair_scheduling_ex in *. + have: pred_at extr' 0 (λ c _, locale_enabled ζ'' c). + { rewrite /pred_at /= pred_first_trace. inversion Htm; eauto. } + have Hζ'en: pred_at extr' 0 (λ c _, locale_enabled ζ'' c). + { rewrite /pred_at /= pred_first_trace. inversion Htm; eauto. } + have [p Hp] := (Hfair' ζ'' 0 Hζ'en). + have [P Hind] : ∃ M0 : nat, pred_at auxtr' M0 (λ δ0 ℓ, ¬ role_enabled ρ δ0 ∨ + ∃ ζ0 fmact act, ℓ = Some (Take_step ρ fmact ζ0 act)). + { eapply (IH _ _ _ p _ extr'); eauto. by inversion Htm. + Unshelve. unfold strict, lt_lex. lia. } + exists (1+P). rewrite !pred_at_sum. simpl. done. + Qed. + + Theorem fairness_preserved (extr: extrace Λ) (auxtr: auxtrace LM): + exaux_traces_match extr auxtr -> + (forall ζ, fair_scheduling_ex ζ extr) -> (forall ρ, fair_aux ρ auxtr). + Proof. + intros Hmatch Hex ρ n Hn. + unfold pred_at in Hn. + destruct (after n auxtr) as [tr|] eqn:Heq =>//. + setoid_rewrite pred_at_sum. rewrite Heq. + have Hen: role_enabled ρ (trfirst tr) by destruct tr. + have [ζ Hζ] : is_Some(ls_mapping (trfirst tr) !! ρ) by eauto. + have [f Hfuel] : is_Some(ls_fuel (trfirst tr) !! ρ) by eauto. + have Hex' := Hex ζ n. + have [tr1' [Heq' Htr]] : exists tr1', after n extr = Some tr1' ∧ exaux_traces_match tr1' tr + by eapply traces_match_after. + have Hte: locale_enabled ζ (trfirst tr1'). + { rewrite /locale_enabled. have [HiS Hneqζ] := traces_match_first _ _ _ _ _ _ Htr. + have [e Hein] := (HiS _ _ Hζ). exists e. split; first done. + destruct (to_val e) eqn:Heqe =>//. + exfalso. specialize (Hneqζ ζ e Hein). rewrite Heqe in Hneqζ. + have HnotNull: Some v ≠ None by []. specialize (Hneqζ HnotNull ρ Hζ). done. } + setoid_rewrite pred_at_sum in Hex'. rewrite Heq' in Hex'. + have Hpa: pred_at extr n (λ c _, locale_enabled ζ c). + { unfold pred_at. rewrite Heq'. destruct tr1'; eauto. } + destruct (Hex' Hpa) as [m Hm]. + eapply (fairness_preserved_ind ρ _ f m ζ tr1' tr); eauto. + intros ?. by eapply fair_scheduling_ex_after. + Qed. + + Tactic Notation "inv" open_constr(P) := match goal with + | [H: P |- _] => inversion H; clear H; simplify_eq + end. + + (* TODO: Why do we need explicit [LM] here? *) + Definition trace_labels_match + (extr : execution_trace Λ) (auxtr : auxiliary_trace LM) := + match extr, auxtr with + | (extr :tr[oζ]: (es, σ)), auxtr :tr[ℓ]: δ => + labels_match (LM:=LM) oζ ℓ + | _, _ => True + end. + + Definition valid_state_evolution_fairness (ex : execution_trace Λ) + (atr : auxiliary_trace (live_model_to_model LM)) + : Prop := + trace_steps LM.(lm_ls_trans) atr ∧ + trace_labels_match ex atr ∧ + tids_smaller (trace_last ex).1 (trace_last atr). + + Definition valid_lift_fairness + (φ: execution_trace Λ -> auxiliary_trace LM -> Prop) + (extr : execution_trace Λ) (auxtr : auxiliary_trace LM) := + valid_state_evolution_fairness extr auxtr ∧ φ extr auxtr. + + (* TODO: Why do we need explicit [LM] here? *) + Lemma valid_inf_system_trace_implies_traces_match_strong + (φ : execution_trace Λ -> auxiliary_trace LM -> Prop) + (ψ : _ → _ → Prop) + ex atr iex iatr progtr (auxtr : auxtrace LM): + (forall (ex: execution_trace Λ) (atr: auxiliary_trace LM), + φ ex atr -> live_tids (LM:=LM) (trace_last ex) (trace_last atr)) -> + (forall (ex: execution_trace Λ) (atr: auxiliary_trace LM), + φ ex atr -> valid_state_evolution_fairness ex atr) -> + (∀ extr auxtr, φ extr auxtr → ψ (trace_last extr) (trace_last auxtr)) → + exec_trace_match ex iex progtr -> + exec_trace_match atr iatr auxtr -> + valid_inf_system_trace φ ex atr iex iatr -> + traces_match labels_match + (λ σ δ, live_tids (LM := LM) σ δ ∧ ψ σ δ) + locale_step + LM.(lm_ls_trans) progtr auxtr. + Proof. + intros Hφ1 Hφ2 Hφψ. + revert ex atr iex iatr auxtr progtr. cofix IH. + intros ex atr iex iatr auxtr progtr Hem Ham Hval. + inversion Hval as [?? Hphi |ex' atr' c [? σ'] δ' iex' iatr' oζ ℓ Hphi [=] ? Hinf]; simplify_eq. + - inversion Hem; inversion Ham. econstructor; eauto. + pose proof (Hφ1 ex atr Hphi). + split; [by simplify_eq|]. simplify_eq. by apply Hφψ. + - inversion Hem; inversion Ham. subst. + pose proof (valid_inf_system_trace_inv _ _ _ _ _ Hinf) as Hphi'. + destruct (Hφ2 (ex :tr[ oζ ]: (l, σ')) (atr :tr[ ℓ ]: δ') Hphi') as (?&?&?). + econstructor. + + naive_solver. + + eauto. + + match goal with + | [H: exec_trace_match _ iex' _ |- _] => inversion H; clear H; simplify_eq + end; done. + + match goal with + | [H: exec_trace_match _ iatr' _ |- _] => inversion H; clear H; simplify_eq + end; + match goal with + | [H: trace_steps _ _ |- _] => inversion H; clear H; simplify_eq + end; unfold trace_ends_in in *; simplify_eq; done. + + eapply IH; eauto. + Qed. + + (* TODO: Why do we need explicit [LM] here? *) + Lemma valid_inf_system_trace_implies_traces_match + (φ: execution_trace Λ -> auxiliary_trace LM -> Prop) + ex atr iex iatr progtr (auxtr : auxtrace LM): + (forall (ex: execution_trace Λ) (atr: auxiliary_trace LM), + φ ex atr -> live_tids (LM:=LM) (trace_last ex) (trace_last atr)) -> + (forall (ex: execution_trace Λ) (atr: auxiliary_trace LM), + φ ex atr -> valid_state_evolution_fairness ex atr) -> + exec_trace_match ex iex progtr -> + exec_trace_match atr iatr auxtr -> + valid_inf_system_trace φ ex atr iex iatr -> + exaux_traces_match progtr auxtr. + Proof. + intros Hφ1 Hφ2. + revert ex atr iex iatr auxtr progtr. cofix IH. + intros ex atr iex iatr auxtr progtr Hem Ham Hval. + inversion Hval as [?? Hphi |ex' atr' c [? σ'] δ' iex' iatr' oζ ℓ Hphi [=] ? Hinf]; simplify_eq. + - inversion Hem; inversion Ham. econstructor; eauto. + pose proof (Hφ1 ex atr Hphi). + by simplify_eq. + - inversion Hem; inversion Ham. subst. + pose proof (valid_inf_system_trace_inv _ _ _ _ _ Hinf) as Hphi'. + destruct (Hφ2 (ex :tr[ oζ ]: (l, σ')) (atr :tr[ ℓ ]: δ') Hphi') as (?&?&?). + econstructor. + + naive_solver. + + eauto. + + match goal with + | [H: exec_trace_match _ iex' _ |- _] => inversion H; clear H; simplify_eq + end; done. + + match goal with + | [H: exec_trace_match _ iatr' _ |- _] => inversion H; clear H; simplify_eq + end; + match goal with + | [H: trace_steps _ _ |- _] => inversion H; clear H; simplify_eq + end; unfold trace_ends_in in *; simplify_eq; done. + + eapply IH; eauto. + Qed. + +End fairness_preserved. + +Section fuel_dec_unless. + Context `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ Mdl}. + Implicit Type δ : LiveState Λ Mdl. + + Definition Ul (ℓ: LM.(mlabel)) : option (fmlabel Mdl) := + match ℓ with + | Take_step ρ fmact _ _ => Some (inl (ρ, fmact)) + | Config_step fmcfg _ => Some (inr fmcfg) + | _ => None + end. + + Definition Ψ (tr: trace (LiveState Λ Mdl) LM.(mlabel)) := + let δ := trfirst tr in + (size $ ls_fuel δ) + [^ Nat.add map] ρ ↦ f ∈ ls_fuel δ, f. + + Lemma fuel_dec_unless (auxtr: auxtrace LM) : + auxtrace_valid auxtr -> + dec_unless (λ x, ls_under (ls_data x)) Ul Ψ auxtr. + Proof. + intros Hval n. revert auxtr Hval. induction n; intros auxtr Hval; last first. + { edestruct (after (S n) auxtr) as [auxtrn|] eqn:Heq; rewrite Heq =>//. + simpl in Heq; + simplify_eq. destruct auxtrn as [|δ ℓ auxtr']=>//; last first. + inversion Hval as [|???? Hmatch]; simplify_eq =>//. + specialize (IHn _ Hmatch). rewrite Heq // in IHn. } + edestruct (after 0 auxtr) as [auxtrn|] eqn:Heq; rewrite Heq =>//. + simpl in Heq; simplify_eq. destruct auxtrn as [|δ ℓ auxtr']=>//; last first. + + inversion Hval as [|??? Htrans Hmatch]; simplify_eq =>//. + destruct ℓ as [| tid' |]; + [left; eexists; done| right | inversion Htrans; naive_solver ]. + destruct Htrans as (Hne&Hdec&Hni&Hincl&Heq). rewrite -> Heq in *. split; last done. + + destruct (decide (dom $ ls_fuel δ = dom $ ls_fuel (trfirst auxtr'))) as [Hdomeq|Hdomneq]. + - destruct Hne as [ρ Hρtid]. + + assert (ρ ∈ dom $ ls_fuel δ) as Hin by rewrite -ls_same_doms elem_of_dom //. + pose proof Hin as Hin'. pose proof Hin as Hin''. + apply elem_of_dom in Hin as [f Hf]. + rewrite Hdomeq in Hin'. apply elem_of_dom in Hin' as [f' Hf']. + rewrite /Ψ -!size_dom Hdomeq. + apply Nat.add_lt_mono_l. + + rewrite /Ψ (big_opM_delete (λ _ f, f) (ls_fuel $ ls_data (trfirst _)) ρ) //. + rewrite (big_opM_delete (λ _ f, f) (ls_fuel δ) ρ) //. + apply Nat.add_lt_le_mono. + { rewrite /fuel_decr in Hdec. specialize (Hdec ρ). rewrite Hf Hf' /= in Hdec. + apply Hdec; [set_solver | set_solver | by econstructor]. } + + apply big_addM_leq_forall => ρ' Hρ'. + rewrite dom_delete_L in Hρ'. + have Hρneqρ' : ρ ≠ ρ' by set_solver. + rewrite !lookup_delete_ne //. + destruct (decide (ρ' ∈ dom $ ls_fuel δ)) as [Hin|Hnotin]; last set_solver. + rewrite /fuel_must_not_incr in Hni. + destruct (Hni ρ' ltac:(done) ltac:(done)); [done|set_solver]. + - assert (size $ ls_fuel (trfirst auxtr') < size $ ls_fuel δ). + { rewrite -!size_dom. apply subset_size. set_solver. } + apply Nat.add_lt_le_mono =>//. + apply big_addM_leq_forall => ρ' Hρ'. + destruct (Hni ρ' ltac:(set_solver) ltac:(done)); [done|set_solver]. + Qed. +End fuel_dec_unless. + +Section destuttering_auxtr. + Context `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + + (* Why is [LM] needed here? *) + Definition upto_stutter_auxtr := + upto_stutter (λ x, ls_under (Λ:=Λ) (M:=M) (ls_data x)) (Ul (LM := LM)). + + (* Stutter equivalence for fuel *) + Definition fuel_se := + ltl_se (λ x, ls_under (Λ:=Λ) (M:=M) (ls_data x)) (Ul (LM := LM)). + Hint Unfold fuel_se : core. + Global Hint Constants Transparent : fuel_se. + + Lemma can_destutter_auxtr auxtr: + auxtrace_valid auxtr → + ∃ mtr, upto_stutter_auxtr auxtr mtr. + Proof. + intros ?. eapply can_destutter. + eapply fuel_dec_unless =>//. + Qed. + +End destuttering_auxtr. + +Section upto_preserves. + Context `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + + Lemma upto_stutter_mono' : + monotone2 (upto_stutter_ind (λ x, ls_under (Λ:=Λ) (M:=M) (ls_data x)) (Ul (LM:=LM))). + Proof. + unfold monotone2. intros x0 x1 r r' IN LE. + induction IN; try (econstructor; eauto; done). + Qed. + Hint Resolve upto_stutter_mono' : paco. + + Lemma upto_stutter_preserves_validity_coind (auxtr : auxtrace LM) mtr: + upto_stutter_auxtr auxtr mtr -> + auxtrace_valid auxtr -> + mtrace_valid_coind mtr. + Proof. + revert auxtr mtr. pcofix CH. intros auxtr mtr Hupto Hval. + punfold Hupto. + induction Hupto as [| |btr str δ ????? IH]. + - pfold. constructor. + - apply IHHupto. inversion Hval. assumption. + - pfold; constructor=>//. + + subst. inversion Hval as [| A B C Htrans E F ] =>//. subst. unfold ls_trans in *. + destruct ℓ; [|done|]. + * simpl in *. simplify_eq. + destruct Htrans as [??]. + have <- //: ls_under $ trfirst btr = trfirst str. + destruct IH as [IH|]; last done. punfold IH. inversion IH =>//. + * destruct Htrans as [Htrans [Hmap Hlive]]. + destruct ℓ'=>//. rewrite /= in H1. simplify_eq. + suff -> : trfirst str = trfirst btr; first by naive_solver. + destruct IH as [IH|]=>//. + punfold IH. inversion IH; simplify_eq=>//. + + right. eapply CH. + { destruct IH =>//. } + subst. by inversion Hval. + Qed. + + Lemma upto_stutter_preserves_validity (auxtr : auxtrace LM) mtr: + upto_stutter_auxtr auxtr mtr -> + auxtrace_valid auxtr -> + mtrace_valid mtr. + Proof. intros ??. by eapply mtrace_valid_coind_ltl, upto_stutter_preserves_validity_coind. Qed. +End upto_preserves. + +Section upto_stutter_preserves_fairness_and_termination. + Context `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + + Definition upto_stutter_aux := (upto_stutter (λ x, ls_under (M := M) (Λ := Λ) (ls_data x)) (Ul (Λ := Λ) (LM := LM))). + + Lemma upto_stutter_mono'' : (* TODO fix this proliferation *) + monotone2 (upto_stutter_ind (λ x, ls_under (Λ:=Λ) (M:=M) (ls_data x)) (Ul (LM:=LM))). + Proof. + unfold monotone2. intros x0 x1 r r' IN LE. + induction IN; try (econstructor; eauto; done). + Qed. + Hint Resolve upto_stutter_mono' : paco. + + Lemma upto_stutter_fairness_0 ρ auxtr (mtr: mtrace M): + upto_stutter_aux auxtr mtr -> + (* role_enabled_model ρ (trfirst mtr) -> *) + (∃ n, pred_at auxtr n (λ δ ℓ, ¬role_enabled (Λ := Λ) ρ δ ∨ + ∃ ζ fmact act, ℓ = Some (Take_step ρ fmact ζ act))) -> + ∃ m, pred_at mtr m (λ δ ℓ, ¬role_enabled_model ρ δ ∨ ∃ act, ℓ = Some $ inl (ρ, act)). + Proof. + intros Hupto (* Hre *) [n Hstep]. + revert auxtr mtr Hupto (* Hre *) Hstep. + induction n as [|n]; intros auxtr mtr Hupto (* Hre *) Hstep. + - punfold Hupto. inversion Hupto; simplify_eq. + + destruct Hstep as [Hpa|[??]]. + * exists 0. left. rewrite /pred_at /=. rewrite /pred_at //= in Hpa. + * naive_solver. + + rewrite -> !pred_at_0 in Hstep. exists 0. + destruct Hstep as [Hstep| [tid Hstep]]. + * rewrite /pred_at /=. destruct mtr; simpl in *; left; congruence. + * exfalso. destruct Hstep as [? [? Hstep]]. + injection Hstep => Heq. rewrite -> Heq in *. + unfold Ul in *. congruence. + + rewrite -> !pred_at_0 in Hstep. exists 0. + destruct Hstep as [Hstep| [tid Hstep]]; [left|right]. + * rewrite /pred_at //=. + * rewrite /pred_at //=. destruct Hstep as [? [? Hstep]]. injection Hstep. + intros Heq. simplify_eq. unfold Ul in *. naive_solver. + - punfold Hupto. inversion Hupto as [| |?????? ?? IH ]; simplify_eq. + + rewrite /pred_at //= in Hstep. + + rewrite -> !pred_at_S in Hstep. + eapply IHn; eauto. + by pfold. + + rewrite pred_at_S in Hstep. + destruct ℓ' as [[ρ' act']|fmcfg]. + * destruct (decide (ρ' = ρ)). + ** simplify_eq. exists 0. right. naive_solver. + ** have Hw: ∀ (P: nat -> Prop), (∃ n, P (S n)) -> (∃ n, P n). + { intros P [x ?]. by exists (S x). } + apply Hw. setoid_rewrite pred_at_S. + eapply IHn; eauto. + { destruct IH as [|]; done. } + * odestruct (IHn _ str _ Hstep) as [m Hm]. + ** inversion Hupto; simplify_eq. + match goal with [H: upaco2 _ _ _ _ |- _] => destruct H end; [ naive_solver | done]. + ** exists (S m). by apply pred_at_S. + Qed. + + Lemma upto_stutter_fairness (auxtr: auxtrace LM) (mtr: mtrace M): + upto_stutter_aux auxtr mtr -> + (∀ ρ, fair_aux ρ auxtr) -> + (∀ ρ, fair_scheduling_mtr ρ mtr). + Proof. + intros Hupto Hfa ρ n Hpmod. + unfold pred_at in Hpmod. + destruct (after n mtr) as [mtr'|] eqn:Heq; rewrite Heq // in Hpmod. + destruct (upto_stutter_after _ _ n Hupto Heq) as (n'&auxtr'&Heq'&Hupto'). + have Hre: role_enabled_model ρ (trfirst mtr') by destruct mtr'. + specialize (Hfa ρ). + have Henaux : role_enabled ρ (trfirst auxtr'). + { have HUs: ls_under (trfirst auxtr') = trfirst mtr'. + - punfold Hupto'. by inversion Hupto'. + - unfold role_enabled, role_enabled_model in *. + rewrite HUs //. } + have Hfa' := (fair_aux_after ρ auxtr n' auxtr' Hfa Heq' 0). + have Hpredat: pred_at auxtr' 0 (λ δ _, role_enabled ρ δ). + { rewrite /pred_at /=. destruct auxtr'; done. } + destruct (upto_stutter_fairness_0 ρ auxtr' mtr' Hupto' (Hfa' Hpredat)) as (m&Hres). + exists m. rewrite !(pred_at_sum _ n) Heq //. + Qed. + + Lemma upto_stutter_finiteness auxtr (mtr: mtrace M): + upto_stutter_aux auxtr mtr -> + terminating_trace mtr -> + terminating_trace auxtr. + Proof. + intros Hupto [n Hfin]. + have [n' ?] := upto_stutter_after_None _ _ n Hupto Hfin. + eexists; done. + Qed. + +End upto_stutter_preserves_fairness_and_termination. diff --git a/fairneris/fuel_jm_scheduling_fairness.v b/fairneris/fuel_jm_scheduling_fairness.v new file mode 100644 index 0000000..5eae6aa --- /dev/null +++ b/fairneris/fuel_jm_scheduling_fairness.v @@ -0,0 +1,32 @@ +From fairneris Require Import fairness fuel env_model env_model_project. + + +Section upto. + Context {Λ: language}. + Context `{GoodLang Λ}. + Context {M: UserModel Λ}. + Context {N: EnvModel Λ}. + Context {LM: LiveModel Λ (joint_model M N)}. + + + (* TODO: remove this, this is just a translation between two definitions of fairness. *) + + Lemma upto_stutter_fairness_ltl (auxtr: auxtrace LM) (mtr: mtrace (joint_model M N)): + upto_stutter_aux auxtr mtr -> + (∀ ρ, fair_aux (LM := LM) ρ auxtr) → + jm_fair_scheduling mtr. + Proof. + intros Hupto Hfair ρ. + opose proof (upto_stutter_fairness auxtr mtr _ _ (ρ: fmrole (joint_model M N))) as Hf=>//. + rewrite /fairness.fair_scheduling_mtr /jm_fair_scheduling_mtr in Hf *. + rewrite /trace_always_eventually_implies_now /trace_always_eventually_implies. + rewrite trace_alwaysI. intros tr' [n Hsuff]. rewrite trace_impliesI. intros Hnow. + rewrite /trace_utils.trace_implies in Hf. odestruct (Hf n _) as [m Hm]. + { rewrite /pred_at Hsuff. done. } + rewrite /pred_at in Hm. + rewrite trace_eventuallyI. + destruct (after (n+m) mtr) as [mtr'|] eqn:Heq; rewrite Heq in Hm; last naive_solver. + exists mtr'; split; last naive_solver. + exists m. rewrite after_sum' Hsuff // in Heq. + Qed. +End upto. diff --git a/fairneris/inftraces.v b/fairneris/inftraces.v new file mode 100644 index 0000000..e14dc6a --- /dev/null +++ b/fairneris/inftraces.v @@ -0,0 +1,780 @@ +From trillium.program_logic Require Export adequacy. +From stdpp Require Import option. +From Paco Require Import paco1 paco2 pacotac. + +Require Import + Coq.Relations.Relation_Definitions + Coq.Relations.Relation_Operators. +Require Import Coq.Arith.Wf_nat. + +Section traces. + + Delimit Scope trace_scope with trace. + + CoInductive trace (S L: Type) := + | tr_singl (s: S) + | tr_cons (s: S) (ℓ: L) (r: trace S L). + Bind Scope trace_scope with trace. + + Arguments tr_singl {_} {_}, _. + Arguments tr_cons {_} {_} _ _ _%trace. + Notation "⟨ s ⟩" := (tr_singl s) : trace_scope. + Notation "s -[ ℓ ]-> r" := (tr_cons s ℓ r) (at level 33) : trace_scope. + Open Scope trace. + + Lemma trace_unfold_fold {S L} (tr: trace S L) : + tr = match tr with + | ⟨s⟩ => ⟨s⟩ + | s -[ℓ]-> rest => s -[ℓ]-> rest + end. + Proof. destruct tr; trivial. Qed. + + Definition trfirst {S L} (tr: trace S L): S := + match tr with + | ⟨s⟩ => s + | s -[ℓ]-> r => s + end. + + Lemma pred_first_trace (S T : Type) (tr: trace S T ) (P: S -> Prop): + match tr with + | ⟨ s ⟩ | s -[ _ ]-> _ => P s + end <-> P (trfirst tr). + Proof. destruct tr; done. Qed. + + Section after. + Context {St L: Type}. + + Fixpoint after (n: nat) (t: trace St L) : option (trace St L):= + match n with + | 0 => Some t + | Datatypes.S n => + match t with + | ⟨ s ⟩ => None + | s -[ ℓ ]-> xs => after n xs + end + end. + + Definition pred_at (tr: trace St L) (n: nat) (P: St -> option L -> Prop): Prop := + match after n tr with + | None => False + | Some ⟨s⟩ => P s None + | Some (s -[ℓ]-> _) => P s (Some ℓ) + end. + + Lemma after_sum m: forall k (tr: trace St L), + after (k+m) tr = + match after m tr with + | None => None + | Some tr' => after k tr' + end. + Proof. + induction m. + - intros k tr. by have ->: k+0=k by lia. + - intros k tr. simpl. + have -> /=: (k + S m) = S (k+m) by lia. + destruct tr as [s|s l r]; simpl; auto. + Qed. + + Lemma after_sum' m: forall k (tr: trace St L), + after (k+m) tr = + match after k tr with + | None => None + | Some tr' => after m tr' + end. + Proof. intros. rewrite Nat.add_comm. apply after_sum. Qed. + + Lemma pred_at_sum P n m tr: + pred_at tr (n + m) P <-> + match after n tr with + | None => False + | Some tr' => pred_at tr' m P + end. + Proof. + rewrite /pred_at after_sum'. + by destruct (after n tr). + Qed. + + Lemma pred_at_sum' P n m tr: + pred_at tr (n + m) P <-> + match after m tr with + | None => False + | Some tr' => pred_at tr' n P + end. + Proof. + rewrite /pred_at after_sum. + by destruct (after m tr). + Qed. + + Lemma pred_at_0 s ℓ r P: + pred_at (s -[ℓ]-> r) 0 P <-> P s (Some ℓ). + Proof. by unfold pred_at. Qed. + + Lemma pred_at_S s ℓ r n P: + pred_at (s -[ℓ]-> r) (S n) P <-> pred_at r n P. + Proof. by unfold pred_at. Qed. + + Definition infinite_trace tr := + forall n, is_Some (after n tr). + + Definition terminating_trace tr := + ∃ n, after n tr = None. + + Lemma terminating_trace_cons s ℓ tr: + terminating_trace tr -> terminating_trace (s -[ℓ]-> tr). + Proof. intros [n Hterm]. by exists (1+n). Qed. + + Lemma infinite_trace_after n tr: + infinite_trace tr -> match after n tr with + | None => False + | Some tr' => infinite_trace tr' + end. + Proof. + intros Hinf. have [tr' Htr'] := (Hinf n). rewrite Htr'. + intros m. + have Hnm := Hinf (n+m). rewrite after_sum' Htr' // in Hnm. + Qed. + + Lemma infinite_cons s ℓ r: + infinite_trace (s -[ℓ]-> r) -> infinite_trace r. + Proof. + intros Hinf n. specialize (Hinf (1+n)). + rewrite (after_sum' _ 1) // in Hinf. + Qed. + + Definition trace_suffix_of tr1 tr2 : Prop := + ∃ n, after n tr2 = Some tr1. + + (** trace_suffix_of lemmas *) + + Lemma trace_suffix_of_refl (tr : trace St L) : + trace_suffix_of tr tr. + Proof. by exists 0. Qed. + + Lemma trace_suffix_of_cons_l s l (tr tr' : trace St L) : + trace_suffix_of (s -[l]-> tr) tr' → trace_suffix_of tr tr'. + Proof. + intros [n Hafter]. exists (Datatypes.S n). + replace (Datatypes.S n) with (n + 1) by lia. + rewrite after_sum'. rewrite Hafter. done. + Qed. + + Lemma trace_suffix_of_cons_r s l (tr tr' : trace St L) : + trace_suffix_of tr tr' → trace_suffix_of tr (s -[l]-> tr'). + Proof. intros [n Hafter]. by exists (Datatypes.S n). Qed. + + Lemma trace_suffix_of_cons_r' s l (tr : trace St L) : + trace_suffix_of tr (s -[l]-> tr). + Proof. by exists (Datatypes.S 0). Qed. + + Lemma trace_suffix_of_trans (tr tr' tr'' : trace St L) : + trace_suffix_of tr'' tr' → trace_suffix_of tr' tr → trace_suffix_of tr'' tr. + Proof. + intros [n Hsuffix1] [m Hsuffix2]. + exists (n+m). rewrite after_sum. rewrite Hsuffix2. + rewrite Hsuffix1. done. + Qed. + + Lemma trace_suffix_of_infinite (tr tr': trace St L) : + trace_suffix_of tr' tr → + infinite_trace tr' → + infinite_trace tr. + Proof. + intros [n Hafter] Hinf m. + destruct (decide (m < n)). + - have Heq: n = m + (n - m) by lia. + rewrite Heq in Hafter. + rewrite after_sum' in Hafter. + destruct (after _ _)=>//. + - have Heq: m = n + (m - n) by lia. + rewrite Heq after_sum' Hafter. apply Hinf. + Qed. + + Lemma trace_suffix_of_infinite' (tr tr': trace St L) : + trace_suffix_of tr' tr → + infinite_trace tr → + infinite_trace tr'. + Proof. + intros [n Hafter] Hinf m. + specialize (Hinf (n+m)). + rewrite after_sum' Hafter // in Hinf. + Qed. + End after. + +End traces. + +Delimit Scope trace_scope with trace. +Arguments tr_singl {_} {_}, _. +Arguments tr_cons {_} {_} _ _ _%trace. +Notation "⟨ s ⟩" := (tr_singl s) : trace_scope. +Notation "s -[ ℓ ]-> r" := (tr_cons s ℓ r) (at level 33) : trace_scope. +Open Scope trace. + +Section simulation. + Context {L1 L2 S1 S2: Type}. + Context (Rℓ: L1 -> L2 -> Prop) (Rs: S1 -> S2 -> Prop). + Context (trans1: S1 -> L1 -> S1 -> Prop). + Context (trans2: S2 -> L2 -> S2 -> Prop). + + CoInductive traces_match : trace S1 L1 -> trace S2 L2 -> Prop := + | trace_match_singl s1 s2: Rs s1 s2 -> traces_match ⟨ s1 ⟩ ⟨ s2 ⟩ + | trace_match_cons s1 ℓ1 r1 s2 ℓ2 r2 : Rℓ ℓ1 ℓ2 -> Rs s1 s2 -> + trans1 s1 ℓ1 (trfirst r1) -> + trans2 s2 ℓ2 (trfirst r2) -> + traces_match r1 r2 -> + traces_match (s1 -[ℓ1]-> r1) (s2 -[ℓ2]-> r2). + + Lemma traces_match_after tr1 tr2 n tr2': + traces_match tr1 tr2 -> + after n tr2 = Some tr2' -> + (exists tr1', after n tr1 = Some tr1' ∧ traces_match tr1' tr2'). + Proof. + revert tr1 tr2. + induction n; intros tr1 tr2. + { simpl. intros. exists tr1. simplify_eq. done. } + move=> /= Hm Ha. destruct tr2 as [|s ℓ tr2''] eqn:Heq; first done. + destruct tr1; first by inversion Hm. + inversion Hm; simplify_eq. by eapply IHn. + Qed. + + Lemma traces_match_after_inv tr1 tr2 n tr1': + traces_match tr1 tr2 -> + after n tr1 = Some tr1' -> + (exists tr2', after n tr2 = Some tr2' ∧ traces_match tr1' tr2'). + Proof. + revert tr1 tr2. + induction n; intros tr1 tr2. + { simpl. intros. exists tr2. simplify_eq. done. } + move=> /= Hm Ha. destruct tr1 as [|s ℓ tr1''] eqn:Heq; first done. + destruct tr2; first by inversion Hm. + inversion Hm; simplify_eq. by eapply IHn. + Qed. + + Lemma traces_match_after_None tr1 tr2 n : + traces_match tr1 tr2 -> + after n tr1 = None -> + after n tr2 = None. + Proof. + revert tr1 tr2; induction n; intros tr1 tr2; first naive_solver. + move=> /= Hm Ha. destruct tr1 as [|s ℓ tr1''] eqn:Heq; simplify_eq. + - by inversion Hm. + - inversion Hm; simplify_eq. naive_solver. + Qed. + + Lemma traces_match_suffix_of tr1 tr2 tr2': + traces_match tr1 tr2 -> + trace_suffix_of tr2' tr2 → + (exists tr1', trace_suffix_of tr1' tr1 ∧ traces_match tr1' tr2'). + Proof. + rewrite /trace_suffix_of. + intros ? [? Hafter]. eapply traces_match_after in Hafter; naive_solver. + Qed. + + Lemma traces_match_suffix_of_inv tr1 tr2 tr1': + traces_match tr1 tr2 -> + trace_suffix_of tr1' tr1 → + (exists tr2', trace_suffix_of tr2' tr2 ∧ traces_match tr1' tr2'). + Proof. + rewrite /trace_suffix_of. + intros ? [? Hafter]. eapply traces_match_after_inv in Hafter; naive_solver. + Qed. + + Lemma traces_match_first tr1 tr2: + traces_match tr1 tr2 -> + Rs (trfirst tr1) (trfirst tr2). + Proof. intros Hm. inversion Hm; done. Qed. +End simulation. + +Section equiv. + Context {St L: Type}. + + Definition trace_equiv (tr1 tr2: trace St L) : Prop := + traces_match eq eq (λ _ _ _, True) (λ _ _ _, True) tr1 tr2. + + Lemma trace_equiv_singleton n tr1 tr2 s : + trace_equiv tr1 tr2 → + after n tr1 = Some ⟨s⟩ → + after n tr2 = Some ⟨s⟩. + Proof. + intros Heq Hafter. + eapply traces_match_after_inv in Hafter as (?&->&Heq')=>//. + by inversion Heq'; simplify_eq. + Qed. + + Lemma trace_equiv_cons n tr1 tr2 s ℓ tr1' : + trace_equiv tr1 tr2 → + after n tr1 = Some (s -[ℓ]-> tr1') → + ∃ tr2', after n tr2 = Some (s -[ℓ]-> tr2') ∧ trace_equiv tr1' tr2'. + Proof. + intros Heq Hafter. + eapply traces_match_after_inv in Hafter as (?&->&Heq')=>//. + inversion Heq'; simplify_eq. eexists. naive_solver. + Qed. + + Lemma trace_equiv_None n tr1 tr2: + trace_equiv tr1 tr2 → + after n tr1 = None → + after n tr2 = None. + Proof. + intros Heq Hafter. + eapply traces_match_after_None=>//. + Qed. + + Global Instance trace_equiv_sym : Symmetric trace_equiv. + Proof. + cofix CH; intros tr1 tr2 Heq. + inversion Heq as [?? Heqs Heq1 Heq2|?????? Heq1 Heq2]. + - rewrite -Heqs {2}Heqs Heq1 Heq2. apply Heq. + - rewrite Heq1 Heq2. constructor=>//. + Qed. + + Global Instance trace_equiv_refl : Reflexive trace_equiv. + Proof. + cofix CH; intros tr. + destruct tr. + - constructor. done. + - constructor=>//. + Qed. +End equiv. + +Section execs_and_traces. + Context {S L: Type}. + + CoInductive exec_trace_match: finite_trace S L -> inflist (L * S) -> trace S L -> Prop := + | exec_trace_match_singl ft s: trace_last ft = s -> exec_trace_match ft infnil ⟨s⟩ + | exec_trace_match_cons ft s ℓ ift tr: + exec_trace_match (trace_extend ft ℓ s) ift tr -> + exec_trace_match ft (infcons (ℓ, s) ift) (trace_last ft -[ℓ]-> tr). + + CoFixpoint to_trace (s: S) (il: inflist (L * S)) : trace S L := + match il with + | infnil => ⟨ s ⟩ + | infcons (ℓ, s') rest => s -[ℓ]-> (to_trace s' rest) + end. + + Lemma to_trace_spec (fl: finite_trace S L) (il: inflist (L * S)): + exec_trace_match fl il (to_trace (trace_last fl) il). + Proof. + revert fl il. cofix CH. intros s il. + rewrite (trace_unfold_fold (to_trace _ il)). destruct il as [| [ℓ x]?]; simpl in *. + - by econstructor. + - econstructor. have ->: x = trace_last (trace_extend s ℓ x) by done. + apply CH. + Qed. + + Lemma to_trace_singleton s (il: inflist (L * S)): + exec_trace_match (trace_singleton s) il (to_trace s il). + Proof. apply to_trace_spec. Qed. + + CoFixpoint from_trace (tr: trace S L): inflist (L * S) := + match tr with + | ⟨ s ⟩ => infnil + | s -[ℓ]-> tr' => infcons (ℓ, trfirst tr') (from_trace tr') + end. + + Lemma from_trace_spec (fl: finite_trace S L) (tr: trace S L): + trace_last fl = trfirst tr -> + exec_trace_match fl (from_trace tr) tr. + Proof. + revert fl tr. cofix CH. intros fl tr Heq. + rewrite (inflist_unfold_fold (from_trace tr)). destruct tr; simpl in *. + - by econstructor. + - rewrite -Heq. econstructor. apply CH; done. + Qed. + +End execs_and_traces. + +Definition oleq (a b : option nat) : Prop := + match a, b with + | Some x, Some y => x ≤ y + | _, _ => False + end. + +Definition oless (a b : option nat) : Prop := + match a, b with + | Some x, Some y => x < y + | _, _ => False + end. + +Lemma oleq_oless a b : oless a b -> oleq a b. +Proof. destruct a; destruct b=>//. unfold oless, oleq. lia. Qed. + + +Section dec_unless. + Context {St S' L L': Type}. + Context (Us: St -> S'). + Context (Ul: L -> option L'). + + Definition dec_unless Ψ (tr: trace St L) := + ∀ n, match after n tr with + | Some ⟨ _ ⟩ | None => True + | Some (s -[ℓ]-> tr') => + (∃ ℓ', Ul ℓ = Some ℓ') ∨ + (Ψ tr') < Ψ (s -[ℓ]-> tr') ∧ Us s = Us (trfirst tr') + end. + + Lemma dec_unless_next Ψ s ℓ tr (Hdec: dec_unless Ψ (s -[ℓ]-> tr)): dec_unless Ψ tr. + Proof. + intros n. specialize (Hdec (n+1)). rewrite (after_sum 1) // in Hdec. + Qed. + +End dec_unless. + +Section destuttering. + Context {St S' L L': Type}. + Context (Us: St -> S'). + Context (Ul: L -> option L'). + + Inductive upto_stutter_ind (upto_stutter_coind: trace St L -> trace S' L' -> Prop): + trace St L -> trace S' L' -> Prop := + | upto_stutter_singleton s: + upto_stutter_ind upto_stutter_coind ⟨s⟩ ⟨Us s⟩ + | upto_stutter_stutter btr str s ℓ: + Ul ℓ = None -> + Us s = Us (trfirst btr) -> + Us s = trfirst str -> + upto_stutter_ind upto_stutter_coind btr str -> + upto_stutter_ind upto_stutter_coind (s -[ℓ]-> btr) str + | upto_stutter_step btr str s ℓ s' ℓ': + Us s = s' -> + Ul ℓ = Some ℓ' -> + upto_stutter_coind btr str -> + upto_stutter_ind upto_stutter_coind (s -[ℓ]-> btr) (s' -[ℓ']-> str). + + Definition upto_stutter := paco2 upto_stutter_ind bot2. + + Lemma upto_stutter_mono : + monotone2 (upto_stutter_ind). + Proof. + unfold monotone2. intros x0 x1 r r' IN LE. + induction IN; try (econstructor; eauto; done). + Qed. + Hint Resolve upto_stutter_mono : paco. + + Lemma upto_stutter_after {btr str} n {str'}: + upto_stutter btr str -> + after n str = Some str' -> + ∃ n' btr', after n' btr = Some btr' ∧ upto_stutter btr' str'. + Proof. + have Hw: ∀ (P: nat -> Prop), (∃ n, P (S n)) -> (∃ n, P n). + { intros P [x ?]. by exists (S x). } + revert btr str str'. induction n as [|n IH]; intros btr str str' Hupto Hafter. + { injection Hafter => <-. clear Hafter. exists 0, btr. done. } + revert str' Hafter. punfold Hupto. induction Hupto as + [s|btr str s ℓ HUl HUs1 HUs2 Hind IHH|btr str s ℓ s' ℓ' ?? Hind]. + - intros str' Hafter. done. + - intros str' Hafter. + apply Hw. simpl. by apply IHH. + - intros str' Hafter. simpl in Hafter. + apply Hw. simpl. eapply IH =>//. + by destruct Hind. + Qed. + + Lemma upto_stutter_suffix_of btr str str': + upto_stutter btr str -> + trace_suffix_of str' str -> + ∃ btr', trace_suffix_of btr' btr ∧ upto_stutter btr' str'. + Proof. + unfold trace_suffix_of. intros ? [? Hafter]. eapply upto_stutter_after in Hafter; naive_solver. + Qed. + + Lemma upto_stutter_after_inv {btr str} n {btr'}: + upto_stutter btr str -> + after n btr = Some btr' -> + ∃ n' str', after n' str = Some str' ∧ upto_stutter btr' str'. + Proof. + have Hw: ∀ (P: nat -> Prop), (∃ n, P (S n)) -> (∃ n, P n). + { intros P [x ?]. by exists (S x). } + revert str btr btr'. induction n as [|n IH]; intros str btr btr' Hupto Hafter. + { injection Hafter => <-. clear Hafter. exists 0, str. done. } + revert btr' Hafter. punfold Hupto. induction Hupto as + [s|btr str s ℓ HUl HUs1 HUs2 Hind IHH|btr str s ℓ s' ℓ' ?? Hind]. + - intros str' Hafter. done. + - intros btr' Hafter. eapply IH=>//. by pfold. + - intros str' Hafter. simpl in Hafter. + apply Hw. simpl. eapply IH =>//. + by destruct Hind. + Qed. + + Lemma upto_stutter_suffix_of_inv btr str btr': + upto_stutter btr str -> + trace_suffix_of btr' btr -> + ∃ str', trace_suffix_of str' str ∧ upto_stutter btr' str'. + Proof. + unfold trace_suffix_of. intros ? [? Hafter]. eapply upto_stutter_after_inv in Hafter; naive_solver. + Qed. + + Lemma upto_stutter_after_None {btr str} n: + upto_stutter btr str -> + after n str = None -> + ∃ n', after n' btr = None. + Proof. + have Hw: ∀ (P: nat -> Prop), (∃ n, P (S n)) -> (∃ n, P n). + { intros P [x ?]. by exists (S x). } + revert btr str. induction n as [|n IH]; intros btr str Hupto Hafter. + { exists 0. done. } + revert Hafter. punfold Hupto. induction Hupto as + [s|btr str s ℓ HUl HUs1 HUs2 Hind IHH|btr str s ℓ s' ℓ' ?? Hind]. + - intros Hafter. by exists 1. + - intros Hafter. + apply Hw. simpl. by apply IHH. + - intros Hafter. simpl in Hafter. + apply Hw. simpl. eapply IH =>//. + by destruct Hind. + Qed. + + Lemma upto_stutter_infinite_trace tr1 tr2 : + upto_stutter tr1 tr2 → infinite_trace tr1 → infinite_trace tr2. + Proof. + intros Hstutter Hinf n. + revert tr1 tr2 Hstutter Hinf. + induction n as [|n IHn]; intros tr1 tr2 Hstutter Hinf. + - punfold Hstutter. + - punfold Hstutter. + induction Hstutter. + + specialize (Hinf (1 + n)). + rewrite after_sum' in Hinf. simpl in *. apply is_Some_None in Hinf. done. + + apply IHHstutter. + intros m. specialize (Hinf (1 + m)). + rewrite after_sum' in Hinf. simpl in *. done. + + simpl. eapply (IHn btr str); [by destruct H1|]. + intros m. specialize (Hinf (1 + m)). + rewrite after_sum' in Hinf. simpl in *. done. + Qed. + + Program Fixpoint destutter_once_step N Ψ (btr: trace St L) : + Ψ btr < N → + dec_unless Us Ul Ψ btr → + S' + (S' * L' * { btr' : trace St L | dec_unless Us Ul Ψ btr'}) := + match N as n return + Ψ btr < n → + dec_unless Us Ul Ψ btr → + S' + (S' * L' * { btr' : trace St L | dec_unless Us Ul Ψ btr'}) + with + | O => λ Hlt _, False_rect _ (Nat.nlt_0_r _ Hlt) + | S N' => + λ Hlt Hdec, + match btr as z return btr = z → S' + (S' * L' * { btr' : trace St L | dec_unless Us Ul Ψ btr'}) with + | tr_singl s => λ _, inl (Us s) + | tr_cons s l btr' => + λ Hbtreq, + match Ul l as z return Ul l = z → S' + (S' * L' * { btr' : trace St L | dec_unless Us Ul Ψ btr'}) with + | Some l' => λ _, inr (Us s, l', exist _ btr' _) + | None => λ HUll, destutter_once_step N' Ψ btr' _ _ + end eq_refl + end eq_refl + end. + Next Obligation. + Proof. + intros _ Ψ btr N' Hlt Hdec s l btr' -> l' HUll; simpl. + eapply dec_unless_next; done. + Qed. + Next Obligation. + Proof. + intros _ Ψ btr N' Hlt Hdec s l btr' -> HUll; simpl in *. + pose proof (Hdec 0) as [[? ?]|[? ?]]; [congruence|lia]. + Qed. + Next Obligation. + Proof. + intros _ Ψ btr N' Hlt Hdec s l btr' -> HUll; simpl. + eapply dec_unless_next; done. + Qed. + + CoFixpoint destutter_gen Ψ N (btr: trace St L) : + Ψ btr < N -> + dec_unless Us Ul Ψ btr → trace S' L' := + λ Hlt Hdec, + match destutter_once_step N Ψ btr Hlt Hdec with + | inl s' => tr_singl s' + | inr (s', l', z) => tr_cons s' l' (destutter_gen Ψ (S (Ψ $ proj1_sig z)) + (proj1_sig z) (Nat.lt_succ_diag_r _) (proj2_sig z)) + end. + + Definition destutter Ψ (btr: trace St L) : + dec_unless Us Ul Ψ btr → trace S' L' := + λ Hdec, + destutter_gen Ψ (S (Ψ btr)) btr (Nat.lt_succ_diag_r _) Hdec. + + Lemma destutter_same_Us N Ψ btr Hlt Hdec: + match destutter_once_step N Ψ btr Hlt Hdec with + | inl s' | inr (s', _, _) => Us (trfirst btr) = s' + end. + Proof. + revert btr Hlt Hdec. induction N as [|N]; first lia. + intros btr Hlt Hdec. simpl. + destruct btr as [s|s ℓ btr']; first done. + generalize (destutter_once_step_obligation_1 Ψ (s -[ ℓ ]-> btr') N + Hlt Hdec s ℓ btr' eq_refl). + generalize (destutter_once_step_obligation_2 Ψ (s -[ ℓ ]-> btr') N Hlt Hdec s ℓ btr' eq_refl). + generalize (destutter_once_step_obligation_3 Ψ (s -[ ℓ ]-> btr') N Hlt Hdec s ℓ btr' eq_refl). + intros HunlessNone HltNone HdecSome. + destruct (Ul ℓ) as [ℓ'|] eqn:Heq; cbn; first done. + unfold dec_unless in Hdec. + destruct (Hdec 0) as [[??]|[? Hsame]]; first congruence. + rewrite Hsame. apply IHN. + Qed. + + Lemma destutter_spec_ind N Ψ (btr: trace St L) (Hdec: dec_unless Us Ul Ψ btr) + (Hlt: Ψ btr < N): + upto_stutter btr (destutter_gen Ψ N btr Hlt Hdec). + Proof. + revert N btr Hlt Hdec. + pcofix CH. pfold. + induction N. + { intros; lia. } + intros btr Hlt Hdec. + rewrite (trace_unfold_fold (destutter_gen _ _ _ _ _)). + destruct btr as [s|s ℓ btr']. + { simpl in *. econstructor. } + cbn. + generalize (destutter_once_step_obligation_1 Ψ (s -[ ℓ ]-> btr') N + Hlt Hdec s ℓ btr' eq_refl). + generalize (destutter_once_step_obligation_2 Ψ (s -[ ℓ ]-> btr') N Hlt Hdec s ℓ btr' eq_refl). + generalize (destutter_once_step_obligation_3 Ψ (s -[ ℓ ]-> btr') N Hlt Hdec s ℓ btr' eq_refl). + intros HunlessNone HltNone HdecSome. + destruct (Ul ℓ) as [ℓ'|] eqn:Heq; cbn. + - econstructor 3 =>//. right. apply (CH (S (Ψ btr'))). + - econstructor 2=>//. + + destruct (Hdec 0) as [[??]|[??]];congruence. + + have ?: Us s = Us (trfirst btr'). + { destruct (Hdec 0) as [[??]|[? Hsame]]; congruence. } + have HH := destutter_same_Us N Ψ btr' (HltNone eq_refl) (HunlessNone eq_refl). + destruct (destutter_once_step N Ψ btr' (HltNone eq_refl) (HunlessNone eq_refl)) as + [|[[??][??]]]eqn:Heq'; simpl in *; congruence. + + rewrite -trace_unfold_fold. + specialize (IHN btr' (HltNone eq_refl) (HunlessNone eq_refl)). + match goal with + [H : context[upto_stutter_ind] |- ?Y] => let X := type of H in + suffices <-: X <-> Y; first done + end. + f_equiv. + rewrite {1}(trace_unfold_fold (destutter_gen _ _ _ _ _)) /= -trace_unfold_fold //. + Qed. + + Lemma destutter_spec Ψ (btr: trace St L) (Hdec: dec_unless Us Ul Ψ btr): + upto_stutter btr (destutter Ψ btr Hdec). + Proof. eapply destutter_spec_ind. Qed. + + Lemma can_destutter Ψ (btr: trace St L) (Hdec: dec_unless Us Ul Ψ btr): + ∃ str, upto_stutter btr str. + Proof. exists (destutter Ψ btr Hdec). apply destutter_spec. Qed. + +End destuttering. + +(* TODO: Does this belong here? *) +(* Adapted from Arthur Azevedo De Amorim *) +Section lex_ind. + Section Lexicographic. + + Variables (A B : Type) (leA : relation A) (leB : relation B). + + Inductive lexprod : A * B -> A * B -> Prop := + | left_lex : forall x x' y y', leA x x' -> lexprod (x, y) (x', y') + | right_lex : forall x y y', leB y y' -> lexprod (x, y) (x, y'). + + Theorem wf_trans : + transitive _ leA -> + transitive _ leB -> + transitive _ lexprod. + Proof. + intros tA tB [x1 y1] [x2 y2] [x3 y3] H. + inversion H; subst; clear H. + - intros H. + inversion H; subst; clear H; apply left_lex; now eauto. + - intros H. + inversion H; subst; clear H. + + now apply left_lex. + + now apply right_lex; eauto. + Qed. + + Theorem wf_lexprod : + well_founded leA -> + well_founded leB -> + well_founded lexprod. + Proof. + intros wfA wfB [x y]. generalize dependent y. + induction (wfA x) as [x _ IHx]; clear wfA. + intros y. + induction (wfB y) as [y _ IHy]; clear wfB. + constructor. + intros [x' y'] H. + now inversion H; subst; clear H; eauto. + Qed. + + End Lexicographic. + + Definition lt_lex : relation (nat * nat) := fun '(x, y) '(x', y') => + x < x' ∨ (x = x' ∧ y <= y'). + + #[global] Instance lt_lex_partial_order : PartialOrder lt_lex. + Proof. + constructor. + + constructor. + * move=> [x y]. right; split; reflexivity. + * move=> [x1 y1] [x2 y2] [x3 y3] [H1|H1] [H2|H2]; unfold lt_lex; lia. + + move=> [x1 y1] [x2 y2] [?|[??]] [H2|[??]]; f_equal; try lia. + Qed. + + Definition myrel : relation (nat * nat) := + lexprod _ _ lt lt. + + Lemma lex_ind: + ∀ (n : nat*nat) (P : nat*nat → Prop), + (∀ n0 : nat*nat, (∀ m : nat*nat, (strict lt_lex) m n0 → P m) → P n0) → P n. + Proof. + assert (well_founded myrel) as Hwf. + + { apply wf_lexprod; apply lt_wf. } + induction n using (well_founded_ind Hwf). + intros P HI. apply HI =>//. intros m [Ha Hb]. + apply H =>//. destruct n as [n1 n2]; destruct m as [m1 m2]. + unfold strict, lt_lex in *. + destruct Ha as [Ha | [Ha1 Ha2]]. + - constructor 1. done. + - rewrite Ha1. constructor 2. lia. + Qed. + +End lex_ind. + +#[global] Program Instance add_monoid: Monoid Nat.add := + {| monoid_unit := 0 |}. + +Section addition_monoid. + Context `{Countable K}. + + Lemma big_addM_leq_forall (X Y: gmap K nat): + (∀ k, k ∈ dom X -> oleq (X !! k) (Y !! k)) -> + ([^ Nat.add map] k ↦ x ∈ X, x) ≤ ([^ Nat.add map] k ↦ y ∈ Y, y). + Proof. + revert Y. + induction X as [|k v X HXk IH] using map_ind. + { intros Y Hx. rewrite big_opM_empty /=. lia. } + intros Y Hx. rewrite big_opM_insert //. + have Hol: oleq (<[k:=v]> X !! k) (Y !! k) by apply Hx; set_solver. + rewrite lookup_insert in Hol. + destruct (Y!!k) as [v'|] eqn:Heq; last done. + rewrite (big_opM_delete _ Y k v') //. + apply Nat.add_le_mono=>//. + apply IH=> k' Hin. + have ?: k ≠ k'. + { intros ->. apply elem_of_dom in Hin. rewrite HXk in Hin. by destruct Hin. } + rewrite -(lookup_insert_ne X k k' v) // (lookup_delete_ne Y k) //. + apply Hx. set_solver. + Qed. +End addition_monoid. + +(* Classical *) + +Require Import Coq.Logic.Classical. +Section infinite_or_finite. + Context {St L: Type}. + + Lemma infinite_or_finite (tr: trace St L): + infinite_trace tr ∨ terminating_trace tr. + Proof. + destruct (classic (infinite_trace tr)) as [|Hni]; first by eauto. + rewrite /infinite_trace in Hni. + apply not_all_ex_not in Hni. destruct Hni as [n Hni%eq_None_not_Some]. + by right; exists n. + Qed. + +End infinite_or_finite. diff --git a/fairneris/lib/dfrac_oneshot.v b/fairneris/lib/dfrac_oneshot.v new file mode 100644 index 0000000..885736b --- /dev/null +++ b/fairneris/lib/dfrac_oneshot.v @@ -0,0 +1,179 @@ +From iris.bi.lib Require Import fractional. +From iris.algebra Require Import dfrac agree csum. +From iris.proofmode Require Import tactics. +From iris.base_logic.lib Require Export own. +From iris.prelude Require Import options. +Set Default Proof Using "Type". + +Definition dfrac_oneshotR (A : ofe) := csumR dfracR (agreeR A). + +Definition dfrac_oneshotΣ A : gFunctors := + #[GFunctor (dfrac_oneshotR A)]. + +Global Instance subG_dfrac_oneshotG {Σ} (A : ofe) : + subG (dfrac_oneshotΣ A) Σ → inG Σ (dfrac_oneshotR A). +Proof. solve_inG. Qed. + +Section def. + Context `{!inG Σ (dfrac_oneshotR A)}. + + Definition pending_def (γ : gname) (q : Qp) := + own γ (Cinl (DfracOwn q)). + Definition pending_aux : seal (pending_def). Proof. by eexists. Qed. + Definition pending := pending_aux.(unseal). + Definition pending_eq : pending = pending_def := pending_aux.(seal_eq). + + Definition pending_discarded_def (γ : gname) := + own γ (Cinl DfracDiscarded). + Definition pending_discarded_aux + : seal pending_discarded_def. Proof. by eexists. Qed. + Definition pending_discarded := pending_discarded_aux.(unseal). + Definition pending_discarded_eq : pending_discarded = pending_discarded_def := + pending_discarded_aux.(seal_eq). + + Definition shot_def γ a := own γ (Cinr (to_agree a)). + Definition shot_aux : seal shot_def. Proof. by eexists. Qed. + Definition shot := shot_aux.(unseal). + Definition shot_eq : shot = shot_def := shot_aux.(seal_eq). +End def. + +Global Arguments pending {_ _ _} _ _%Qp. + +Lemma pending_alloc `{!inG Σ (dfrac_oneshotR A)} : + ⊢ |==> ∃ (γ : gname), pending γ 1. +Proof. + iIntros. + iMod (own_alloc (Cinl (DfracOwn 1%Qp))) as (γ) "H". + { rewrite //=. } + iExists _. + rewrite pending_eq /pending_def. by iFrame. +Qed. + +Section dfrac_oneshot_lemmas. + Context `{!inG Σ (dfrac_oneshotR A)}. + + Global Instance pending_timeless γ q : Timeless (pending γ q). + Proof. rewrite pending_eq /pending_def. apply _. Qed. + + Global Instance pending_fractional γ : Fractional (λ q, pending γ q). + Proof. + intros ??. + rewrite pending_eq /pending_def -own_op -Cinl_op dfrac_op_own; auto. + Qed. + + Global Instance pending_as_fractional γ q : + AsFractional (pending γ q) (λ q, pending γ q)%I q. + Proof. split; [done|]. apply _. Qed. + + Global Instance pending_discared_timeless γ : Timeless (pending_discarded γ). + Proof. + rewrite /pending_discarded pending_discarded_aux.(seal_eq). apply _. + Qed. + + Global Instance pending_discared_persistent γ : + Persistent (pending_discarded γ). + Proof. + rewrite /pending_discarded pending_discarded_aux.(seal_eq). apply _. + Qed. + + Global Instance shot_timeless `{OfeDiscrete A} γ a : + Timeless (shot γ a). + Proof. rewrite shot_eq /shot_def. apply _. Qed. + + Global Instance shot_persistent γ a : Persistent (shot γ a). + Proof. rewrite shot_eq /shot_def. apply _. Qed. + + Definition nat_to_Qp n := pos_to_Qp (Pos.of_nat n). + + Lemma big_sepS_pending_combine `{Countable B} (X : gset B) γ q : + ([∗ set] _ ∈ X, pending γ q) ⊣⊢ + if decide (size X = 0) then True else pending γ ((nat_to_Qp (size X)) * q). + Proof. + rewrite pending_eq /pending_def. + induction X using set_ind_L. + - rewrite big_sepS_empty size_empty //. + - rewrite big_sepS_union ?big_sepS_singleton /=; [|set_solver]. + rewrite size_union ?size_singleton /=; [|set_solver]. + rewrite IHX. + destruct (decide (size X = 0)) as [->|]. + { rewrite /nat_to_Qp /Pos.of_nat /= Qp.mul_1_l bi.sep_emp //. } + rewrite -own_op -Cinl_op dfrac_op_own. + rewrite /nat_to_Qp -Pos.of_nat_succ -Pos.succ_of_nat //. + rewrite Pplus_one_succ_l -pos_to_Qp_add Qp.mul_add_distr_r Qp.mul_1_l //. + Qed. + + (* TODO: upstream? *) + Lemma size_set_seq start len : + size (set_seq start len : gset _) = len. + Proof. + revert start. induction len; [done|]. intros start. + rewrite set_seq_S_start. + rewrite size_union ?size_singleton; [|set_solver by lia]. + rewrite IHlen //. + Qed. + + Lemma pending_split_N γ (N : nat) : + N > 0 → + pending γ 1 ⊣⊢ [∗ set] _ ∈ set_seq 0 N, pending γ (/ nat_to_Qp N). + Proof. + intros ?. + rewrite big_sepS_pending_combine. + rewrite size_set_seq. + destruct decide; [lia|]. + rewrite Qp.mul_inv_r //. + Qed. + + Lemma pending_split_gset `{Countable B} (X : gset B) γ : + X ≠ ∅ → + pending γ 1 ⊣⊢ [∗ set] _ ∈ X, pending γ (/ nat_to_Qp (size X)). + Proof. + intros Hnempty. + rewrite big_sepS_pending_combine. + destruct (decide (size X = 0)) as [?%size_empty_inv|]. + { simplify_eq. } + rewrite Qp.mul_inv_r //. + Qed. + + Lemma pending_discard γ q : + pending γ q ==∗ pending_discarded γ. + Proof. + rewrite pending_eq /pending_def + pending_discarded_eq /pending_discarded_def. + iApply own_update. apply csum_update_l, dfrac_discard_update. + Qed. + + Lemma pending_discarded_shot `{OfeDiscrete A} a γ : + pending_discarded γ -∗ shot γ a -∗ False. + Proof. + rewrite pending_discarded_eq /pending_discarded_def shot_eq /shot_def. + iIntros "H H'". + by iDestruct (own_valid_2 with "H H'") as %?. + Qed. + + Lemma pending_shot `{OfeDiscrete A} γ a q : + pending γ q -∗ shot γ a -∗ False. + Proof. + rewrite pending_eq /pending_def shot_eq /shot_def. + iIntros "H H'". + by iDestruct (own_valid_2 with "H H'") as %?. + Qed. + + Lemma pending_update_shot γ a : pending γ 1 ==∗ shot γ a. + Proof. + rewrite pending_eq /pending_def shot_eq /shot_def. + iIntros "H". iMod (own_update with "H") as "$". + { by apply cmra_update_exclusive. } + done. + Qed. + + Lemma shot_agreeL `{!LeibnizEquiv A, !OfeDiscrete A} γ a b : + shot γ a -∗ shot γ b -∗ ⌜a = b⌝. + Proof. + rewrite shot_eq /shot_def. + iIntros "H1 H2". + iDestruct (own_valid_2 with "H1 H2") as "H". + rewrite -Cinr_op csum_validI. iDestruct "H" as %?. + iIntros "!%". by apply (to_agree_op_inv_L (A := A)). + Qed. + +End dfrac_oneshot_lemmas. diff --git a/fairneris/lib/gen_heap_light.v b/fairneris/lib/gen_heap_light.v new file mode 100644 index 0000000..027a2a5 --- /dev/null +++ b/fairneris/lib/gen_heap_light.v @@ -0,0 +1,205 @@ +From iris.bi.lib Require Import fractional. +From iris.proofmode Require Import tactics. +From iris.algebra Require Import auth gmap frac agree. +From iris.base_logic.lib Require Import gen_heap. +From iris.base_logic.lib Require Export own. +From iris.prelude Require Import options. +Import uPred. + +Section definitions. + + Definition gen_heapUR L `{!EqDecision L} `{!Countable L} V := + gmapUR L (prodR fracR (agreeR (leibnizO V))). + + Context `{Countable L, hG : !inG Σ (authR (gen_heapUR L V))}. + + Definition to_gen_heap (σ : gmap L V) : gmap L (frac * (agree (leibnizO V))) := + (λ v, (1%Qp, to_agree v)) <$> σ. + + Lemma lookup_to_gen_heap_None σ l : + σ !! l = None → to_gen_heap σ !! l = None. + Proof. rewrite /to_gen_heap lookup_fmap => ->//. Qed. + + Lemma to_gen_heap_insert σ l v : + to_gen_heap (<[l := v]>σ) = <[ l := (1%Qp, to_agree v)]>(to_gen_heap σ). + Proof. rewrite /to_gen_heap fmap_insert //. Qed. + + Lemma to_gen_heap_valid σ : ✓ (to_gen_heap σ). + Proof. intros i; rewrite lookup_fmap; destruct (σ !! i); done. Qed. + + Lemma gen_heap_singleton_included σ l q v : + {[ l := (q, to_agree v)]} ≼ to_gen_heap σ → σ !! l = Some v. + Proof. + rewrite singleton_included_l; intros (w & Hw1 & Hw2). + revert Hw2; rewrite -Hw1; clear Hw1. + rewrite /to_gen_heap lookup_fmap; clear w. + intros [|(w & w' & Hw1 & Hw2 & Hw3)]%option_included; first done. + destruct (σ !! l); last by inversion Hw2. + simplify_eq/=. + destruct Hw3 as [[_ ->%(@to_agree_inj)%leibniz_equiv]|Hw3]; first done. + apply prod_included in Hw3 as [_ ->%(@to_agree_included)%leibniz_equiv]; + done. + Qed. + + Definition gen_heap_light_ctx (γ : gname) (σ : gmap L V) : iProp Σ := + @own _ _ hG γ (● (to_gen_heap σ)). + + Definition lmapsto_def (γ : gname) (l : L) (q : Qp) (v: V) : iProp Σ := + own γ (◯ {[ l := (q, to_agree (v : leibnizO V)) ]}). + Definition lmapsto_aux : seal (@lmapsto_def). Proof. by eexists. Qed. + Definition lmapsto := lmapsto_aux.(unseal). + Definition lmapsto_eq : @lmapsto = @lmapsto_def := lmapsto_aux.(seal_eq). +End definitions. + +Local Notation "l ; γ ↦{ q } v" := (lmapsto γ l q v) + (at level 20, q at level 50, format "l ; γ ↦{ q } v") : bi_scope. +Local Notation "l ; γ ↦ v" := (lmapsto γ l 1 v) (at level 20) : bi_scope. + +Local Notation "l ; γ ↦{ q } -" := (∃ v, l ; γ ↦{q} v)%I + (at level 20, q at level 50, format "l ; γ ↦{ q } -") : bi_scope. +Local Notation "l ; γ ↦ -" := (l ; γ ↦{1} -)%I (at level 20) : bi_scope. + +Lemma gen_heap_light_init `{Countable L, !inG Σ (authR (gen_heapUR L V))} σ : + ⊢ |==> ∃ (γ : gname), gen_heap_light_ctx γ σ. +Proof. + iMod (own_alloc (● to_gen_heap σ)) as (γ) "Hh". + { rewrite auth_auth_valid. exact: to_gen_heap_valid. } + eauto. +Qed. + +Section gen_heap_light. + Context {L V} `{Countable L, !inG Σ (authR (gen_heapUR L V))}. + Implicit Types σ : gmap L V. + Implicit Types l : L. + Implicit Types v : V. + + (** General properties of lmapsto *) + Global Instance lmapsto_timeless l γ q v : Timeless (l ; γ ↦{q} v). + Proof. rewrite lmapsto_eq /lmapsto_def. apply _. Qed. + Global Instance lmapsto_fractional l γ v : Fractional (λ q, l ; γ ↦{q} v)%I. + Proof. + intros p q. by rewrite lmapsto_eq /lmapsto_def -own_op -auth_frag_op + singleton_op -pair_op agree_idemp. + Qed. + Global Instance lmapsto_as_fractional l γ q v : + AsFractional (l ; γ ↦{q} v) (λ q, l ; γ ↦{q} v)%I q. + Proof. split; [done|]. apply _. Qed. + + Lemma lmapsto_agree l γ q1 q2 v1 v2 : + l ; γ ↦{q1} v1 -∗ l ; γ ↦{q2} v2 -∗ ⌜v1 = v2⌝. + Proof. + iIntros "H1 H2". + rewrite lmapsto_eq /lmapsto_def. + iDestruct (own_valid_2 with "H1 H2") as %Hvalid. + iPureIntro. + rewrite auth_frag_valid singleton_op singleton_valid -pair_op in Hvalid. + by destruct Hvalid as [_ ?%to_agree_op_inv_L]. + Qed. + + Lemma lmapsto_combine l γ q1 q2 v1 v2 : + l ; γ ↦{q1} v1 -∗ l ; γ ↦{q2} v2 -∗ l ; γ ↦{q1 + q2} v1 ∗ ⌜v1 = v2⌝. + Proof. + iIntros "Hl1 Hl2". iDestruct (lmapsto_agree with "Hl1 Hl2") as %->. + iCombine "Hl1 Hl2" as "Hl". eauto with iFrame. + Qed. + + Global Instance frame_pointsto p γ l v q1 q2 q : + FrameFractionalQp q1 q2 q → + Frame p (l ; γ ↦{q1} v) (l ; γ ↦{q2} v) (l ; γ ↦{q} v) | 5. + Proof. apply: frame_fractional. Qed. + + Global Instance ex_lmapsto_fractional l γ : Fractional (λ q, l ; γ ↦{q} -)%I. + Proof. + intros p q. iSplit. + - iDestruct 1 as (v) "[H1 H2]". iSplitL "H1"; eauto. + - iIntros "[H1 H2]". iDestruct "H1" as (v1) "H1". iDestruct "H2" as (v2) "H2". + iDestruct (lmapsto_agree with "H1 H2") as %->. iExists v2. by iFrame. + Qed. + Global Instance ex_lmapsto_as_fractional l γ q : + AsFractional (l ; γ ↦{q} -) (λ q, l ; γ ↦{q} -)%I q. + Proof. split; [done|]. apply _. Qed. + + Lemma lmapsto_valid l γ q v : l ; γ ↦{q} v -∗ ✓ q. + Proof. + rewrite lmapsto_eq /lmapsto_def own_valid !discrete_valid auth_frag_valid. + iPureIntro. rewrite singleton_valid. destruct 1 as [??]; done. + Qed. + Lemma lmapsto_valid_2 l γ q1 q2 v1 v2 : + l ; γ ↦{q1} v1 -∗ l ; γ ↦{q2} v2 -∗ ✓ (q1 + q2)%Qp. + Proof. + iIntros "H1 H2". iDestruct (lmapsto_agree with "H1 H2") as %->. + iApply (lmapsto_valid l _ _ v2). by iFrame. + Qed. + + Lemma lmapsto_lmapsto_ne l1 l2 γ q1 q2 v1 v2 : + ¬ ✓(q1 + q2)%Qp → l1 ; γ ↦{q1} v1 -∗ l2 ; γ ↦{q2} v2 -∗ ⌜l1 ≠ l2⌝. + Proof. + iIntros (?) "Hl1 Hl2"; iIntros (->). + by iDestruct (lmapsto_valid_2 with "Hl1 Hl2") as %?. + Qed. + + (** Update lemmas *) + Lemma gen_heap_light_alloc σ l γ v : + σ !! l = None → + gen_heap_light_ctx γ σ ==∗ gen_heap_light_ctx γ (<[l:=v]>σ) ∗ l ; γ ↦ v. + Proof. + iIntros (Hσl). rewrite /gen_heap_light_ctx lmapsto_eq /lmapsto_def /=. + iIntros "Hσ". + iMod (own_update with "Hσ") as "[Hσ Hl]". + { eapply auth_update_alloc, + (alloc_singleton_local_update _ _ (1%Qp, to_agree (v:leibnizO _)))=> //. + by apply lookup_to_gen_heap_None. } + iModIntro. + rewrite to_gen_heap_insert. iFrame. + Qed. + + Lemma gen_heap_light_alloc_gen σ σ' γ : + σ' ##ₘ σ → + gen_heap_light_ctx γ σ ==∗ + gen_heap_light_ctx γ (σ' ∪ σ) ∗ ([∗ map] l ↦ v ∈ σ', l ; γ ↦ v). + Proof. + revert σ; induction σ' as [| l v σ' Hl IH] using map_ind; iIntros (σ Hdisj) "Hσ". + { rewrite left_id_L. auto. } + iMod (IH with "Hσ") as "[Hσ'σ Hσ']"; first by eapply map_disjoint_insert_l. + decompose_map_disjoint. + rewrite !big_opM_insert // -insert_union_l //. + by iMod (gen_heap_light_alloc with "Hσ'σ") as "($ & $ & $)"; + first by apply lookup_union_None. + Qed. + + Lemma gen_heap_light_valid σ l γ q v : + gen_heap_light_ctx γ σ -∗ l ; γ ↦{q} v -∗ ⌜σ !! l = Some v⌝. + Proof. + iIntros "Hσ Hl". + rewrite /gen_heap_light_ctx lmapsto_eq /lmapsto_def. + iDestruct (own_valid_2 with "Hσ Hl") + as %[?%gen_heap_singleton_included _]%auth_both_valid_discrete; auto. + Qed. + + Lemma gen_heap_light_update γ σ l v1 v2 : + gen_heap_light_ctx γ σ -∗ l ; γ ↦ v1 ==∗ + gen_heap_light_ctx γ (<[l:=v2]>σ) ∗ l ; γ ↦ v2. + Proof. + iIntros "Hσ Hl". rewrite /gen_heap_light_ctx lmapsto_eq /lmapsto_def. + iDestruct (own_valid_2 with "Hσ Hl") + as %[Hl%gen_heap_singleton_included _]%auth_both_valid_discrete. + iMod (own_update_2 with "Hσ Hl") as "[Hσ Hl]". + { eapply auth_update, singleton_local_update, + (exclusive_local_update _ (1%Qp, to_agree (v2:leibnizO _)))=> //. + by rewrite /to_gen_heap lookup_fmap Hl. } + iModIntro. iFrame "Hl". rewrite to_gen_heap_insert. iFrame. + Qed. + + Lemma gen_heap_light_init_strong σ : + ⊢ |==> ∃ γ, gen_heap_light_ctx γ σ ∗ + [∗ map] l ↦ v ∈ σ, lmapsto γ l 1 v. + Proof. + iInduction σ as [|σ Hnin] "IHσ" using map_ind. + { iMod (gen_heap_light_init ∅) as (γ) "Hγ". + iExists γ. rewrite big_sepM_empty. by iFrame. } + iMod "IHσ" as (γ) "[Hσ Hσs]". + iMod (gen_heap_light_alloc with "Hσ") as "[Hσ Hs]"; [done|]. + iModIntro. iExists γ. rewrite big_sepM_insert; [|done]. by iFrame. + Qed. + +End gen_heap_light. diff --git a/fairneris/lib/singletons.v b/fairneris/lib/singletons.v new file mode 100644 index 0000000..3bdfae4 --- /dev/null +++ b/fairneris/lib/singletons.v @@ -0,0 +1,293 @@ +From stdpp Require Import gmap fin_maps. +Require Import ssreflect. +From fairneris.prelude Require Import gset_map. +From fairneris.algebra Require Import disj_gsets. +From iris.algebra Require Import auth. +From iris.proofmode Require Import tactics. +From trillium.program_logic Require Import weakestpre adequacy. + +Definition is_singleton `{Countable K} (X : gset K) : Prop := + ∃ x, X = {[x]}. + +Definition is_ne `{Countable K} (X : gset K) : Prop := + X ≠ ∅. + +Definition to_singletons `{Countable K} (X : gset K) : gset (gset K) := + gset_map (λ x, {[x]}) X. + +#[global] Instance to_singletons_injective `{Countable K} : + Inj (=) (=) (@to_singletons K _ _). +Proof. apply _. Qed. + +Definition union_set `{Countable A} `{Empty A} `{Union A} (s : gset A) : A := + union_list (elements s). +Notation "⋃ₛ s" := (union_set s) (at level 20, format "⋃ₛ s") : stdpp_scope. + +Section with_K. + Context `{Countable K}. + + Lemma to_singletons_union (X Y : gset K) : + to_singletons (X ∪ Y) = to_singletons X ∪ to_singletons Y. + Proof. set_solver. Qed. + + Lemma to_singletons_fmap (f : gset K → Prop) (X : gset K) : + (∀ (x : K), f {[x]}) → set_Forall f (to_singletons X). + Proof. + intros Hf. + induction X as [|x X Hin IHX] using set_ind_L. + { done. } + rewrite /to_singletons. + rewrite gset_map_union. + eapply set_Forall_union. + { rewrite gset_map_singleton. + apply set_Forall_singleton. + rewrite /is_singleton. + apply Hf. } + done. + Qed. + + Lemma to_singletons_all_singleton (X : gset K) : + set_Forall is_singleton (to_singletons X). + Proof. apply to_singletons_fmap. intros x. rewrite /is_singleton. set_solver. Qed. + + Lemma all_is_singleton_all_disjoint (X : gset (gset K)) : + set_Forall is_singleton X → all_disjoint X. + Proof. + intros Hsingle. + induction X as [|x X HninX IHX] using set_ind_L. + { done. } + epose proof (set_Forall_union_inv_1 _ {[x]} X Hsingle) as Hsinglex. + epose proof (set_Forall_union_inv_2 _ {[x]} X Hsingle) as HsingleX. + setoid_rewrite <-all_disjoint_union. + split; [ apply all_disjoint_singleton | ]. + split; [by apply IHX|]. + apply have_disj_elems_singleton. + setoid_rewrite set_Forall_singleton in Hsinglex. + intros x' Hx'. + destruct (decide (x = x')). + { by left. } + right. + destruct Hsinglex as [y ->]. + assert (∃ y', x' = {[y']}) as [y' ->]. + { by apply HsingleX. } + set_solver. + Qed. + + Lemma to_singletons_all_disjoint (X : gset K) : + all_disjoint (to_singletons X). + Proof. apply all_is_singleton_all_disjoint. apply to_singletons_all_singleton. Qed. + + Lemma to_singletons_is_ne (X : gset K) : + set_Forall is_ne (to_singletons X). + Proof. + apply to_singletons_fmap. + intros x. rewrite /is_ne. set_solver. + Qed. + + Lemma gset_map_difference_comm `{Countable U} (f : K → U) + `{Inj _ _ (=) (=) f} (X Y : gset K) : + (gset_map f X) ∖ (gset_map f Y) = gset_map f (X ∖ Y). + Proof. + apply set_eq. + intros x. + split; intros Hin. + - assert (x ∈ gset_map f X) as HX by set_solver. + apply (gset_map_correct2) in HX as [a [Heq HX]]. + rewrite Heq. + apply gset_map_correct1. set_solver. + - apply (gset_map_correct2) in Hin as [a [Heq HX]]. + simplify_eq. + set_solver. + Qed. + + + Lemma to_singletons_difference_comm (X Y : gset K) : + (to_singletons X) ∖ (to_singletons Y) = to_singletons (X ∖ Y). + Proof. apply gset_map_difference_comm. apply _. Qed. + + Lemma big_sepS_fmap `{invGS_gen hlc Σ} `{Countable K} `{Countable U} + (f : K → U) `{Inj _ _ (=) (=) f} (X : gset K) + (Φ : U → iProp Σ) (Ψ : K → iProp Σ) : + □ (∀ x, Φ (f x) -∗ Ψ x) -∗ + ([∗ set] x ∈ gset_map f X, Φ x) -∗ ([∗ set] x ∈ X, Ψ x). + Proof. + iIntros "#Hf HX". + rewrite big_op.big_opS_unseal /big_op.big_opS_def. + rewrite -elements_fmap. + rewrite big_sepL_fmap. + iApply (big_sepL_impl with "HX"). + iIntros "!>" (k x Hin) "HΦ". + by iApply "Hf". + Qed. + + Lemma big_sepS_to_singletons `{invGS_gen hlc Σ} `{Countable K} + (X : gset K) (Φ : gset K → iProp Σ) (Ψ : K → iProp Σ) : + □ (∀ x, Φ {[x]} -∗ Ψ x) -∗ + ([∗ set] x ∈ to_singletons X, Φ x) -∗ ([∗ set] x ∈ X, Ψ x). + Proof. apply big_sepS_fmap. apply _. Qed. + + Lemma to_singletons_inv (x : K) : + to_singletons {[x]} = {[{[x]}]}. + Proof. rewrite /to_singletons. by rewrite gset_map_singleton. Qed. + + Lemma elem_of_to_singletons + (X : gset K) x : + x ∈ X ↔ {[x]} ∈ to_singletons X. + Proof. + split; intros Hx. + - assert ({[x]} ∪ X = X) as <- by set_solver. + rewrite to_singletons_union. + set_solver. + - induction X using set_ind_L. + { done. } + rewrite to_singletons_union in Hx. + apply elem_of_union in Hx. + destruct Hx as [Hx | Hx]. + + rewrite to_singletons_inv in Hx. set_solver. + + apply IHX in Hx. set_solver. + Qed. + + Lemma elem_of_to_singletons_inv (X : gset K) x : + x ∈ to_singletons X → is_singleton x. + Proof. intros Hx. by eapply to_singletons_all_singleton. Qed. + + Lemma elem_of_union_set x (Xs : gset (gset K)) : + x ∈ ⋃ₛ Xs ↔ (∃ X : gset K, X ∈ Xs ∧ x ∈ X). + Proof. + rewrite /union_set. + rewrite elem_of_union_list. + split. + - intros HXs. + destruct HXs as [X [Hxs Hx]]. + exists X. split; [|done]. + by apply elem_of_elements. + - intros HXs. + destruct HXs as [X [Hxs Hx]]. + exists X. split; [|done]. + by apply elem_of_elements. + Qed. + + Lemma elem_of_union_set_mono (Xs : gset (gset K)) X x : + X ∈ Xs → x ∈ X → x ∈ ⋃ₛ Xs. + Proof. intros HXs HX. apply elem_of_union_list. set_solver. Qed. + + Lemma not_elem_of_union_set (Xs : gset (gset K)) x : + x ∉ ⋃ₛ Xs → ∀ X, x ∈ X → X ∉ Xs. + Proof. + intros Hnin X Hin Hin'. + apply Hnin. + rewrite elem_of_union_list. + eexists X. + split; set_solver. + Qed. + + Lemma not_elem_of_union_set_singleton (Xs : gset (gset K)) x : + x ∉ ⋃ₛ Xs → {[x]} ∉ Xs. + Proof. intros Hnin. eapply not_elem_of_union_set; [done|set_solver]. Qed. + + Lemma all_disjoint_have_disj_elems_singleton (Xs : gset (gset K)) x : + all_disjoint Xs → x ∉ ⋃ₛ Xs → have_disj_elems {[{[x]}]} Xs. + Proof. + intros Hdisj Hnin. + pose proof (not_elem_of_union_set _ _ Hnin). + apply have_disj_elems_singleton. + set_solver. + Qed. + + Lemma have_disj_elems_elem_of (Xs : gset (gset K)) X : + X ∈ Xs → all_disjoint Xs → have_disj_elems {[X]} Xs. + Proof. + intros Hin Hdisj. + apply all_disjoint_union. + assert ({[X]} ∪ Xs = Xs) as -> by set_solver. + done. + Qed. + + Lemma not_elem_of_union_set_difference x (Xs Ys : gset (gset K)) : + x ∉ ⋃ₛ Ys → x ∉ ⋃ₛ (Xs ∖ Ys) → x ∉ ⋃ₛ Xs. + Proof. + intros HY HXY. + setoid_rewrite elem_of_union_set in HY. + setoid_rewrite elem_of_union_set in HXY. + rewrite elem_of_union_set. + intros HX. + destruct HX as [X' [HX HX']]. + apply HXY. + exists X'. + split; [|done]. + apply elem_of_difference. + split; [done|]. + intros HXY'. + apply HY. + exists X'. + done. + Qed. + + Lemma elem_of_union_set_singletons x (Xs : gset (gset K)) : + set_Forall is_singleton Xs → + x ∈ ⋃ₛ Xs → {[x]} ∈ Xs. + Proof. + intros Hsingle Hin. + apply elem_of_union_set in Hin. + destruct Hin as [X' [HX HX']]. + specialize (Hsingle X' HX). + destruct Hsingle as [y Hy]. + destruct (decide (x = y)). + { set_solver. } + subst. + assert (x = y) by set_solver. + done. + Qed. + + Lemma not_elem_of_to_singletons_union_set x (Xs : gset K) : + x ∉ Xs → x ∉ ⋃ₛ to_singletons Xs. + Proof. + intros Hnin. + rewrite elem_of_union_set. + intros [X [Hin Hin']]. + pose proof (elem_of_to_singletons_inv Xs X Hin) as Hsingle. + destruct Hsingle as [x' Hx]; subst. + setoid_rewrite <-elem_of_to_singletons in Hin. + set_solver. + Qed. + + Lemma union_set_empty : + ⋃ₛ (∅:gset $ gset K) = ∅. + Proof. done. Qed. + + Lemma union_set_singleton (a : gset K) : + ⋃ₛ {[a]} = a. + Proof. + rewrite /union_set. rewrite elements_singleton. + simpl. rewrite right_id_L. done. + Qed. + + Lemma union_set_union (A B : gset $ gset K) : + A ## B → ⋃ₛ (A ∪ B) = (⋃ₛ A) ∪ (⋃ₛ B). + Proof. + intros Hdisj. rewrite /union_set. + rewrite elements_disj_union; [|set_solver]. + rewrite union_list_app_L. done. + Qed. + + Lemma to_singletons_singleton (a : K) : + to_singletons {[a]} = {[{[a]}]}. + Proof. rewrite /to_singletons. by rewrite gset_map.gset_map_singleton. Qed. + + (* OBS: This can be made stronger *) + Lemma to_singletons_disj (A B : gset K) : + A ## B → to_singletons A ## to_singletons B. + Proof. rewrite /to_singletons. apply gset_map.gset_map_disj_union. apply _. Qed. + + Lemma union_set_to_singletons (A : gset K) : + ⋃ₛ to_singletons A = A. + Proof. + induction A using set_ind_L; [done|]. + rewrite to_singletons_union. + rewrite union_set_union; last first. + { apply to_singletons_disj. set_solver. } + rewrite IHA. f_equiv. + rewrite to_singletons_singleton. by rewrite union_set_singleton. + Qed. + +End with_K. diff --git a/fairneris/ltl_lite.v b/fairneris/ltl_lite.v new file mode 100644 index 0000000..0e664c6 --- /dev/null +++ b/fairneris/ltl_lite.v @@ -0,0 +1,889 @@ +From Paco Require Import paconotation pacotac paco2. +From fairneris Require Export inftraces. + +Declare Scope trace_scope. +Delimit Scope trace_scope with trace. +Bind Scope trace_scope with trace. + +Definition ltl_pred S L := trace S L → Prop. + +Section ltl_constructors. + Context {S L : Type}. + + Notation ltl_pred := (ltl_pred S L). + + (* Primitive operators *) + Definition trace_now P : ltl_pred := λ tr, pred_at tr 0 P. + Definition trace_label P : ltl_pred := λ tr, pred_at tr 0 (λ st lab, match lab with + | Some l => P l + | None => False + end). + Definition trace_not P : ltl_pred := λ tr, ¬ P tr. + Definition trace_or P Q : ltl_pred := λ tr, P tr ∨ Q tr. + Definition trace_next P : ltl_pred := + λ tr, ∃ tr', after 1 tr = Some tr' ∧ P tr'. + Inductive trace_until P Q : ltl_pred := + | trace_until_here tr : Q tr -> trace_until P Q tr + | trace_until_next s l tr : P (s -[l]-> tr) → trace_until P Q tr → trace_until P Q (s -[l]-> tr). + + (* Derived operators *) + Definition trace_and P Q := (trace_not (trace_or (trace_not P) (trace_not Q))). + Definition trace_implies P Q := (trace_or (trace_not P) Q). + Definition trace_biimplies P Q := + (trace_and (trace_implies P Q) (trace_implies Q P)). + Definition trace_true := (trace_now (λ _ _, True)). + Definition trace_false := (trace_now (λ _ _,False)). + Definition trace_eventually P := (trace_until trace_true P). + Definition trace_always P := (trace_not $ trace_eventually (trace_not P)). + Definition trace_weak_until (P Q : trace S L → Prop) : ltl_pred := + trace_or (trace_until P Q) (trace_always P). + + (* Custom constructors *) + Definition trace_always_eventually_implies + (P Q : trace S L → Prop) : ltl_pred := + trace_always (trace_implies P (trace_eventually Q)). + + Definition trace_always_eventually_implies_now + (P Q : S → option L → Prop) : ltl_pred := + trace_always_eventually_implies (trace_now P) (trace_now Q). + + Lemma trace_eventually_ind (P P0 : trace S L → Prop) : + (∀ tr : trace S L, P tr → P0 tr) → + (∀ (s : S) (l : L) (tr : trace S L), + trace_eventually P tr → P0 tr → P0 (s -[ l ]-> tr)) → + ∀ t : trace S L, trace_eventually P t → P0 t. + Proof. + intros ? IH ??. + eapply (trace_until_ind trace_true); [done|by intros; apply IH|done]. + Qed. + +End ltl_constructors. + +Arguments trace_eventually_ind : clear implicits. + +Notation "○ P" := (trace_next P) (at level 20, right associativity) : trace_scope. +Notation "□ P" := (trace_always P) (at level 20, right associativity) : trace_scope. +Notation "◊ P" := (trace_eventually P) (at level 20, right associativity) : trace_scope. +Notation "↓ P" := (trace_now P) (at level 20, right associativity) : trace_scope. +Notation "ℓ↓ P" := (trace_label P) (at level 20, right associativity) : trace_scope. +Notation "P → Q" := (trace_implies P Q) + (at level 99, Q at level 200, + format "'[' P → '/' '[' Q ']' ']'") : trace_scope. + +(* TODO: Replace existing library lemma with this *) +Lemma not_exists_forall_not_alt {A} (P : A → Prop) x : ¬ (∃ x, P x) → ¬ P x. +Proof. intros Hnex HP; apply Hnex; eauto. Qed. + +Section ltl_lemmas. + Context {S L : Type}. + + (* TODO: Move this *) + Lemma after_is_Some_le (tr : trace S L) n m : + m ≤ n → is_Some $ after n tr → is_Some $ after m tr. + Proof. + revert tr m. + induction n; intros tr m Hle. + { intros. assert (m = 0) as -> by lia. done. } + intros. + destruct m; [done|]. + simpl in *. + destruct tr; [done|]. + apply IHn. lia. done. + Qed. + + Lemma after_is_Some_lt (tr : trace S L) n m : + m < n → is_Some $ after n tr → is_Some $ after m tr. + Proof. + revert tr m. + induction n; intros tr m Hle. + { intros. assert (m = 0) as -> by lia. done. } + intros. + destruct m; [done|]. + simpl in *. + destruct tr; [done|]. + apply IHn. lia. done. + Qed. + + Lemma after_levis n m (tr1 tr2 tr3: trace S L): + n ≤ m → + after n tr1 = Some tr2 → + after m tr1 = Some tr3 → + after (m - n) tr2 = Some tr3. + Proof. + intros Hle Haftern Hafterm. + pose proof (Nat.le_exists_sub n m Hle) as [p [-> Hle']]. + rewrite Nat.add_comm Nat.add_sub'. + by rewrite after_sum Haftern in Hafterm. + Qed. + + (** trace_true lemmas *) + + Lemma trace_trueI (tr : trace S L) : trace_true tr. + Proof. destruct tr; done. Qed. + + (** trace_not lemmas *) + + Lemma trace_notI (P : trace S L → Prop) tr : + trace_not P tr ↔ ¬ P tr. + Proof. done. Qed. + + Lemma trace_not_idemp (P : trace S L → Prop) (tr : trace S L) : + trace_not (trace_not P) tr ↔ P tr. + Proof. rewrite /trace_not. split; [apply NNP_P|apply P_NNP]. Qed. + + Lemma trace_not_mono (P Q : trace S L → Prop) tr : + (Q tr → P tr) → trace_not P tr → trace_not Q tr. + Proof. intros HQP HP HQ. apply HP. by apply HQP. Qed. + + (** trace_next lemmas *) + + Lemma trace_next_intro (P : trace S L → Prop) s l (tr : trace S L) : + P tr → (○ P) (s -[l]-> tr). + Proof. intros ?. exists tr. simpl in *. by simplify_eq. Qed. + + Lemma trace_next_elim (P : trace S L → Prop) s l tr : + (○ P) (s -[l]-> tr) → P tr. + Proof. inversion 1. naive_solver. Qed. + + Lemma trace_next_elim_inv (P : trace S L → Prop) tr : + (○ P) tr → ∃ s l tr', tr = s -[l]-> tr' ∧ P tr'. + Proof. inversion 1. destruct tr; naive_solver. Qed. + + (** trace_implies lemmas *) + + Lemma trace_impliesI (P Q : trace S L → Prop) tr : + trace_implies P Q tr ↔ (P tr → Q tr). + Proof. + split; [by intros [|]|]. + intros HPQ. + assert (P tr ∨ ¬ P tr) as [HP|HP] by apply ExcludedMiddle. + + by right; apply HPQ. + + by left. + Qed. + + Lemma trace_implies_refl (P : trace S L → Prop) tr : + trace_implies P P tr. + Proof. by apply trace_impliesI. Qed. + + (** trace_or lemmas *) + + Lemma trace_orI (P Q : trace S L → Prop) (tr : trace S L) : + trace_or P Q tr ↔ P tr ∨ Q tr. + Proof. done. Qed. + + Lemma trace_or_l (P Q : trace S L → Prop) (tr : trace S L) : + P tr → trace_or P Q tr. + Proof. intros HP. by left. Qed. + + Lemma trace_or_r (P Q : trace S L → Prop) (tr : trace S L) : + Q tr → trace_or P Q tr. + Proof. intros HP. by right. Qed. + + (** trace_and lemmas *) + + Lemma trace_andI (P Q : trace S L → Prop) (tr : trace S L) : + trace_and P Q tr ↔ P tr ∧ Q tr. + Proof. + split. + - intros HPQ. + assert (P tr ∨ ¬ P tr) as [HP|HP] by apply ExcludedMiddle; last first. + { eapply trace_not_mono in HPQ; [|by apply trace_or_l]. done. } + assert (Q tr ∨ ¬ Q tr) as [HQ|HQ] by apply ExcludedMiddle; last first. + { eapply trace_not_mono in HPQ; [|by apply trace_or_r]. done. } + done. + - intros [HP HQ] [HP'|HQ']; done. + Qed. + + (** trace_now lemmas *) + + Definition trfirst_label (tr: trace S L) : option L := + match tr with + | ⟨_⟩ => None + | _ -[ℓ]-> _ => Some ℓ + end. + + Lemma trace_now_mono_strong (P Q : S → option L → Prop) tr : + (∀ s l, trfirst tr = s → trfirst_label tr = l → P s l → Q s l) → + (↓P) tr → (↓Q) tr. + Proof. + destruct tr as [s|s l tr]. + - rewrite /trace_now /pred_at /=. intros HPQ Htr. by apply HPQ. + - rewrite /trace_now /pred_at /=. intros HPQ Htr. by apply HPQ. + Qed. + + Lemma trace_now_mono (P Q : S → option L → Prop) tr : + (∀ s l, P s l → Q s l) → (↓P) tr → (↓Q) tr. + Proof. intros. eapply trace_now_mono_strong; [|done]. by eauto. Qed. + + Lemma trace_now_not P (tr : trace S L) : + (↓ (λ s l, ¬ P s l)) tr ↔ trace_not (↓ P) tr. + Proof. by destruct tr. Qed. + + Lemma trace_now_exists {A} (P : A → S → option L → Prop) (tr : trace S L) : + (↓ (λ s l, ∃ (x:A), P x s l)) tr → ∃ (x:A), (↓ P x) tr. + Proof. rewrite /trace_now /pred_at. intros H. by destruct tr. Qed. + + Lemma trace_now_or (P Q : S → option L → Prop) tr : + (↓ (P \2/ Q)) tr → (↓ P) tr ∨ (↓ Q) tr. + Proof. rewrite /trace_now /pred_at. by destruct tr=>/=. Qed. + + Lemma trace_now_and P Q (tr : trace S L) : + (↓ (P /2\ Q)) tr ↔ trace_and (↓P) (↓Q) tr . + Proof. rewrite trace_andI. destruct tr; done. Qed. + + (* TODO: Maybe remove *) + Lemma trace_now_split P Q (tr : trace S L) : + (↓ P) tr → (↓ Q) tr → (↓ (P /2\ Q)) tr. + Proof. intros. apply trace_now_and. rewrite trace_andI. done. Qed. + + (** trace_eventually lemmas *) + + Lemma trace_eventually_intro P (tr : trace S L) : + P tr → (◊ P) tr. + Proof. by constructor 1. Qed. + + Lemma trace_eventually_cons (P : trace S L → Prop) s l (tr : trace S L) : + (◊ P) tr → (◊ P) (s -[l]-> tr). + Proof. intros. by constructor 2. Qed. + + Lemma trace_eventually_idemp (P : trace S L → Prop) (tr : trace S L) : + (◊◊P) tr → (◊P) tr. + Proof. + intros Htr. induction Htr using trace_eventually_ind; [done|]. + apply trace_eventually_cons. done. + Qed. + + Lemma trace_eventuallyI_alt (P : trace S L → Prop) tr : + (◊ P) tr ↔ (∃ tr', trace_suffix_of tr' tr ∧ (◊ P) tr'). + Proof. + split. + - intros Heventually. + induction Heventually using trace_eventually_ind. + { exists tr. split; [apply trace_suffix_of_refl|]. + by apply trace_eventually_intro. } + destruct IHHeventually as [tr' [Hsuffix HP]]. + exists tr'. + split; [|done]. + by apply trace_suffix_of_cons_r. + - intros [tr' [Hsuffix Htr']]. + induction Htr' using trace_eventually_ind. + { destruct Hsuffix as [n Hafter]. + revert tr tr0 Hafter H. + induction n; intros tr tr0 Hafter HP. + { simpl in *. simplify_eq. by apply trace_eventually_intro. } + destruct tr; [done|]. + constructor 2; [done|]. + by eapply IHn. } + apply IHHtr'. + by eapply trace_suffix_of_cons_l. + Qed. + + Lemma trace_eventuallyI (P : trace S L → Prop) tr : + (◊ P) tr ↔ (∃ tr', trace_suffix_of tr' tr ∧ P tr'). + Proof. + split. + - intros Heventually. + induction Heventually using trace_eventually_ind. + { exists tr. split; [apply trace_suffix_of_refl|]. done. } + destruct IHHeventually as [tr' [Hsuffix HP]]. + exists tr'. + split; [|done]. + by apply trace_suffix_of_cons_r. + - intros [tr' [Hsuffix Htr']]. + apply trace_eventuallyI_alt. exists tr'. split=>//. + by apply trace_eventually_intro. + Qed. + + Lemma trace_eventually_until (P : trace S L → Prop) (tr : trace S L) : + (◊P) tr → trace_until (trace_not P) (P) tr. + Proof. + assert (∀ tr, P tr ∨ ¬ P tr) as Hdec by by intros; apply ExcludedMiddle. + induction 1 using trace_eventually_ind; [by constructor|]. + specialize (Hdec (s -[l]-> tr)) as [H1|H2]. + - by apply trace_until_here. + - by apply trace_until_next. + Qed. + + Lemma trace_eventually_mono_strong (P Q : trace S L → Prop) tr : + (∀ tr', trace_suffix_of tr' tr → P tr' → Q tr') → (◊P) tr → (◊Q) tr. + Proof. + intros HPQ. + induction 1 using trace_eventually_ind. + { apply HPQ, trace_eventually_intro in H. done. apply trace_suffix_of_refl. } + constructor 2; [done|]. + apply IHtrace_eventually. + intros tr' Hsuffix HP. + apply HPQ; [|done]. + destruct Hsuffix as [n Heq]. + exists (Datatypes.S n). done. + Qed. + + Lemma trace_eventually_mono (P Q : trace S L → Prop) tr : + (∀ tr, P tr → Q tr) → (◊P) tr → (◊Q) tr. + Proof. + intros. eapply trace_eventually_mono_strong; [|done]. intros. by apply H. + Qed. + + Lemma trace_eventually_next (P : trace S L → Prop) (tr : trace S L) : + (◊ ○ P) tr → (◊ P) tr. + Proof. + intros Hnext. + induction Hnext using trace_eventually_ind. + { destruct tr; [inversion H; naive_solver|]. + constructor 2; [done|]. constructor. by eapply trace_next_elim. } + constructor 2; [done|]. apply IHHnext. + Qed. + + Lemma trace_eventually_suffix_of (P : trace S L → Prop) tr1 tr2 : + trace_suffix_of tr1 tr2 → (◊P) tr1 → (◊P) tr2. + Proof. intros Hsuffix HP. apply trace_eventuallyI_alt. by exists tr1. Qed. + + Lemma trace_eventually_or (P Q : trace S L → Prop) tr : + (◊ (P \1/ Q)) tr → (◊ P) tr ∨ (◊ Q) tr. + Proof. + intros Hdisj. + induction Hdisj using trace_eventually_ind. + { inversion H; [left; by constructor|right; by constructor]. } + inversion IHHdisj. + - left. by constructor 2. + - right. by constructor 2. + Qed. + + (** trace_always lemmas *) + + Lemma trace_always_cons (P : trace S L → Prop) s l (tr : trace S L) : + (□ P) (s -[l]-> tr) → (□ P) tr. + Proof. + intros Htr Htr'. apply Htr. clear Htr. by apply trace_eventually_cons. + Qed. + + Lemma trace_always_idemp P (tr : trace S L) : + (□ P) tr → (□ □ P) tr. + Proof. + intros Htr Htr'. induction Htr'; [by apply H|]. + apply IHHtr'. by apply trace_always_cons in Htr. + Qed. + + Lemma trace_always_elim (P : trace S L → Prop) (tr : trace S L) : + (□P) tr → P tr. + Proof. + intros Htr. + assert (P tr ∨ ¬ P tr) as [|HP] by apply ExcludedMiddle; [done|]. + rewrite /trace_always in Htr. + assert (trace_not (trace_not P) tr). + { intros Htr'. apply Htr. apply trace_eventually_intro. done. } + done. + Qed. + + Lemma trace_always_mono (P Q : trace S L → Prop) tr : + (∀ tr, trace_implies P Q tr) → (□P) tr → (□Q) tr. + Proof. + intros HPQ HP HQ. apply HP. eapply trace_eventually_mono; [|done]. + clear HP HQ. intros tr' HP HQ. apply HP. + specialize (HPQ tr'). rewrite trace_impliesI in HPQ. by apply HPQ. + Qed. + + Lemma trace_always_mono_strong (P Q : trace S L → Prop) tr : + (∀ tr', trace_suffix_of tr' tr → trace_implies P Q tr') → (□P) tr → (□Q) tr. + Proof. + intros HPQ HP HQ. apply HP. eapply trace_eventually_mono_strong; [|done]. + clear HP HQ. intros tr' Htr' HP HQ. apply HP. + specialize (HPQ tr'). rewrite trace_impliesI in HPQ. by apply HPQ. + Qed. + + Lemma trace_alwaysI_alt (P : trace S L → Prop) tr : + (□P) tr ↔ (∀ tr', trace_suffix_of tr' tr → (□ P) tr'). + Proof. + split. + - intros Htr tr' Hsuffix Htr'. + apply Htr. + induction Htr' using trace_eventually_ind. + { eapply trace_eventuallyI_alt. exists tr0. split; [done|]. + by apply trace_eventually_intro. } + apply IHHtr'. by eapply trace_suffix_of_cons_l. + - intros Htr' Htr. + induction Htr using trace_eventually_ind. + { specialize (Htr' tr). apply Htr'. + { apply trace_suffix_of_refl. } + by apply trace_eventually_intro. } + apply IHHtr. intros tr' Htsuffix. apply Htr'. + by eapply trace_suffix_of_cons_r. + Qed. + + Lemma trace_always_suffix_of (P : trace S L → Prop) tr1 tr2 : + trace_suffix_of tr2 tr1 → (□P) tr1 → (□P) tr2. + Proof. rewrite (trace_alwaysI_alt _ tr1). intros Hsuffix HP. by eapply HP. Qed. + + Lemma trace_alwaysI (P : trace S L → Prop) tr : + (□P) tr ↔ (∀ tr', trace_suffix_of tr' tr → P tr'). + Proof. + split. + - intros HP tr' Hsuff. rewrite trace_alwaysI_alt in HP. + apply trace_always_elim. eauto. + - intros H Habs. apply trace_eventuallyI in Habs as (tr'&Hsuff&?). + by specialize (H _ Hsuff). + Qed. + + Lemma trace_always_eventually_always_until (P : trace S L → Prop) (tr : trace S L) : + (□ ◊P) tr → (□ trace_until (trace_not P) (P)) tr. + Proof. + rewrite !trace_alwaysI. intros He tr' Hsuff. + apply trace_eventually_until. apply He=>//. + Qed. + + Lemma trace_always_forall {A} (P : A → trace S L → Prop) tr : + (∀ (x:A), (□ (P x)) tr) ↔ (□ (λ tr', ∀ x, P x tr')) tr. + Proof. + split. + - intros Htr Htr'. + induction Htr' using trace_eventually_ind. + { apply H. intros x. specialize (Htr x). + apply trace_always_elim in Htr. apply Htr. } + apply IHHtr'. + intros x. specialize (Htr x). + by apply trace_always_cons in Htr. + - intros Htr x Htr'. + induction Htr' using trace_eventually_ind. + { apply H. apply trace_always_elim in Htr. apply Htr. } + apply IHHtr'. by apply trace_always_cons in Htr. + Qed. + + (* TODO: This breaks naming convention *) + Lemma trace_always_universal (P : trace S L → Prop) (tr : trace S L) : + (∀ tr, P tr) → (□P) tr. + Proof. + intros ? H. induction H using trace_eventually_ind; [|done]. + simplify_eq. specialize (H0 tr). done. + Qed. + + (* TODO: This is a bit of a weird statement *) + Lemma trace_always_implies (P Q : trace S L → Prop) tr : + (□(P → Q)) tr → (□P) tr → (□ Q) tr. + Proof. + intros HPQ HP. + eapply trace_always_mono_strong; [|done]. + intros tr' Hsuffix. + apply trace_always_elim. + by eapply trace_always_suffix_of. + Qed. + + Lemma trace_always_eventually P (tr : trace S L) : + (□ P) tr → (◊ P) tr. + Proof. + intros Halways. eapply trace_eventuallyI_alt. exists tr. + split; [apply trace_suffix_of_refl|]. apply trace_eventually_intro. + by apply trace_always_elim in Halways. + Qed. + + Lemma trace_always_eventually_suffix_of tr1 tr2 (P : trace S L → Prop) : + trace_suffix_of tr1 tr2 → (□◊ P) tr1 → (□◊ P) tr2. + Proof. + intros [n Hn] H1. + apply trace_alwaysI. + intros tr' [m Hm]. + apply trace_eventuallyI_alt. + destruct (decide (m ≤ n)). + - exists tr1. split. + + exists (n - m). eapply after_levis =>//. + + by apply trace_always_elim in H1. + - exists tr'. split=>//. + + exists 0. done. + + assert (Hsuff: trace_suffix_of tr' tr1). + * exists (m - n). assert (n ≤ m) by lia. eapply after_levis =>//. + * rewrite trace_alwaysI_alt in H1. specialize (H1 tr' Hsuff). + by apply trace_always_elim in H1. + Qed. + + Lemma trace_always_eventually_always_implies (P Q : trace S L → Prop) tr : + trace_always_eventually_implies P Q tr → (□P) tr → (◊Q) tr. + Proof. + intros HPQ HP. + eapply trace_always_implies in HP; [|done]. + by apply trace_always_elim. + Qed. + + Lemma trace_always_eventually_always_mono (P1 P2 Q1 Q2 : trace S L → Prop) tr : + (∀ tr, trace_implies P2 P1 tr) → (∀ tr, trace_implies Q1 Q2 tr) → + trace_always_eventually_implies P1 Q1 tr → trace_always_eventually_implies P2 Q2 tr. + Proof. + setoid_rewrite trace_impliesI. + intros HP HQ Htr. + eapply trace_always_mono; [|done]. + intros Htr'. + apply trace_impliesI. + rewrite !trace_impliesI. + intros HPQ HP2. + eapply trace_eventually_mono; [apply HQ|by apply HPQ; apply HP]. + Qed. + + Lemma trace_always_not_not_eventually (P : trace S L → Prop) (tr : trace S L) : + (□ (trace_not P)) tr ↔ trace_not (◊ P) tr. + Proof. + split. + - intros Halways Heventually. + induction Heventually. + { apply Halways. apply trace_eventually_intro. by apply P_NNP. } + apply IHHeventually. + by apply trace_always_cons in Halways. + - intros Heventually Halways. + induction Halways using trace_eventually_ind. + { apply Heventually. apply trace_eventually_intro. + eapply trace_not_mono in Heventually; [|by apply trace_eventually_intro]. + done. } + apply IHHalways. + intros Heventually'. apply Heventually. by apply trace_eventually_cons. + Qed. + + Lemma trace_eventually_not_not_always (P : trace S L → Prop) (tr : trace S L) : + (◊ trace_not P) tr ↔ (trace_not (□ P)) tr. + Proof. + split. + - intros Heventually. apply P_NNP. done. + - intros Halways. apply NNP_P in Halways. done. + Qed. + + Lemma trace_always_and P Q (tr : trace S L) : + (□ trace_and P Q) tr ↔ ((□ P) tr ∧ (□ Q) tr). + Proof. + split. + - intros HPQ. + assert ((□ P) tr ∨ ¬ (□ P) tr) as [|HP] by apply ExcludedMiddle; last first. + { apply NNP_P in HP. induction HP using trace_eventually_ind. + { apply trace_always_elim in HPQ. apply trace_andI in HPQ as [HP HQ]. + done. } + apply trace_always_cons in HPQ. apply IHHP in HPQ. + destruct HPQ as [HP' HQ]. + apply trace_eventually_not_not_always in HP. done. } + assert ((□ Q) tr ∨ ¬ (□ Q) tr) as [|HQ] by apply ExcludedMiddle; last first. + { apply NNP_P in HQ. induction HQ using trace_eventually_ind. + { apply trace_always_elim in HPQ. apply trace_andI in HPQ as [HP HQ]. + done. } + apply trace_always_cons in HPQ. + apply trace_always_cons in H. + apply IHHQ in HPQ; [|done]. + destruct HPQ as [HP HQ']. + apply trace_eventually_not_not_always in HQ. done. } + done. + - intros [HP HQ] HPQ. induction HPQ. + { apply H. apply trace_andI. apply trace_always_elim in HP, HQ. done. } + by apply IHHPQ; eapply trace_always_cons. + Qed. + + Lemma trace_weak_until_always P Q (tr : trace S L) : + (□P) tr → trace_weak_until P Q tr. + Proof. intros HP. by apply trace_or_r. Qed. + + (* TODO: Remove? *) + Lemma trace_always_implies_always (P Q : trace S L → Prop) (tr : trace S L) : + (∀ tr, (□P) tr → Q tr) → ((□P) tr → (□ Q) tr). + Proof. + intros HPQ HP%trace_always_idemp. eapply trace_always_mono; [|done]. + intros ?. apply trace_impliesI, HPQ. + Qed. + + Lemma trace_eventually_until_eventually (Q P : trace S L → Prop) tr : + (◊ P) tr ↔ (◊ (trace_until Q P)) tr. + Proof. + split. + - intros [tr' [Hsuff HP]]%trace_eventuallyI. apply trace_eventuallyI. + exists tr'; split=>//. by constructor. + - intros [tr' [Hsuff HP]]%trace_eventuallyI. induction HP as [|????? IH]. + + apply trace_eventuallyI. naive_solver. + + apply IH. by eapply trace_suffix_of_cons_l. + Qed. + + Lemma trace_always_eventually_label_infinite P (tr : trace S L) : + (□◊ℓ↓P) tr → infinite_trace tr. + Proof. + intros Hltl n. revert tr Hltl. induction n as [|n IH]; first naive_solver. + intros tr Hltl. + destruct tr as [s|s ℓ tr]. + - apply trace_always_elim in Hltl. + rewrite trace_eventuallyI in Hltl. + destruct Hltl as (tr'&Hsuff&Hltl). + destruct Hsuff as [[|m] Hafter]=>//. simpl in Hafter. by simplify_eq. + - simpl. apply IH. by eapply trace_always_cons. + Qed. +End ltl_lemmas. + +Section ltl_theorems. + Context {S L : Type}. + + (* Strong fairness implies our (network) fairness *) + Lemma SF_implies_OF (P Q: trace S L → Prop) tr : + ((□◊ P) → (□◊ Q))%trace tr → (□ ((□◊ P) → (◊ Q))) tr. + Proof. + intros Hsf. apply trace_alwaysI. intros tr' Hsuff. + apply trace_impliesI. intros Hae. + eapply trace_always_eventually_suffix_of in Hae =>//. + rewrite trace_impliesI in Hsf. specialize (Hsf Hae). + apply trace_always_elim. by eapply trace_always_suffix_of. + Qed. + + Lemma OF_implies_SF (P Q: trace S L → Prop) tr : + (□ ((□◊ P) → (◊ Q))) tr → ((□◊ P) → (□◊ Q))%trace tr. + Proof. + intros Hsf. apply trace_impliesI. + intros HP. apply trace_always_idemp in HP. revert HP. + by apply trace_always_implies. + Qed. + + Theorem SF_equiv_OF (P Q: trace S L → Prop) tr : + ((□◊ P) → (□◊ Q))%trace tr ≡ (□ ((□◊ P) → (◊ Q))) tr. + Proof. split; [apply SF_implies_OF|apply OF_implies_SF]. Qed. + + (* Our (scheduling) Fairness implies Strong Fairness *) + Lemma OF_implies_SF' (P Q: trace S L → Prop) tr : + (□ (P → (◊ Q)))%trace tr → ((□◊ P) → (□◊ Q))%trace tr. + Proof. + intros Htr. apply trace_impliesI. + apply trace_always_implies. + rewrite trace_alwaysI_alt in Htr. + rewrite trace_alwaysI. + intros tr' Hsuffix. + specialize (Htr tr' Hsuffix). + apply trace_impliesI. + intros HP. + rewrite trace_eventuallyI in HP. + destruct HP as [tr'' [Hsuffix' HP]]. + rewrite trace_alwaysI in Htr. + specialize (Htr tr'' Hsuffix'). + rewrite trace_impliesI in Htr. + rewrite trace_eventuallyI_alt. + exists tr''. split; [done|]. + apply Htr. done. + Qed. + +End ltl_theorems. + +Section stutter. + Context {St S' L L': Type}. + Context (Us: St -> S'). + Context (Ul: L -> option L'). + + Notation upto_stutter := (upto_stutter Us Ul). + + Definition ltl_se (P: ltl_pred St L) (Q: ltl_pred S' L') := + ∀ tr tr', upto_stutter tr tr' → (P tr ↔ Q tr'). + + #[local] Lemma upto_stutter_mono' : + monotone2 (upto_stutter_ind Us Ul). + Proof. exact (upto_stutter_mono Us Ul). Qed. + Hint Resolve upto_stutter_mono' : paco. + + Definition trace_silent_filter : St → option L → Prop := + λ _ ℓ, match ℓ with | Some ℓ' => Ul ℓ' = None | None => False end. + Instance trace_silent_filter_decision st ℓ : Decision (trace_silent_filter st ℓ). + Proof. unfold trace_silent_filter. destruct ℓ; solve_decision. Defined. + + Definition trace_silent := ↓ trace_silent_filter. + + Lemma ltl_se_now P P': + (∀ l, P l ↔ (∃ l', Ul l = Some l' ∧ P' l')) → + ltl_se (trace_until trace_silent (ℓ↓ P)) (ℓ↓ P'). + Proof. + intros Hp tr tr' Hupto; split. + - induction 1 as [tr Hnow| s ℓ tr Hsil Htu IH]. + + destruct tr as [s|s ℓ tr], tr' as [s'|s' ℓ' tr'] =>//=. + * punfold Hupto. inversion Hupto; simplify_eq. + rewrite /trace_label /pred_at /= in Hnow. naive_solver. + * punfold Hupto. inversion Hupto; simplify_eq; + rewrite /trace_label /pred_at /= in Hnow; naive_solver. + + rewrite /trace_silent /trace_now /pred_at /= in Hsil. + punfold Hupto. inversion Hupto; simplify_eq. + apply IH. by pfold. + - punfold Hupto. induction Hupto as [s|tr tr' s ℓ Hsil Hs1 Hs2 IH|tr tr' s ℓ s' ℓ' Hs Hl]. + + rewrite /trace_label /pred_at //=. + + intros Hnow. constructor 2; naive_solver. + + rewrite {1}/trace_label /pred_at //=. intros Hnow. constructor 1. + apply Hp. naive_solver. + Qed. + + Lemma ltl_se_now' P P': + (∀ s, P s None ↔ P' (Us s) None) → + (∀ s ℓ, Ul ℓ = None → (P s (Some ℓ) ↔ P' (Us s) None)) → + (∀ s l, P s (Some l) ↔ (∃ l', Ul l = Some l' ∧ P' (Us s) (Some l'))) → + ltl_se (trace_until trace_silent (↓ P)) (↓ P'). + Proof. + intros Hp1 Hp2 Hp3 tr tr' Hupto; split. + - induction 1 as [tr Hnow| s ℓ tr Hsil Htu IH]. + + destruct tr as [s|s ℓ tr], tr' as [s'|s' ℓ' tr'] =>//=. + * punfold Hupto. inversion Hupto; simplify_eq; naive_solver. + * punfold Hupto. inversion Hupto; simplify_eq; naive_solver. + * punfold Hupto. inversion Hupto; simplify_eq. naive_solver. + * punfold Hupto. inversion Hupto; simplify_eq; + rewrite /trace_now /pred_at /= in Hnow *; naive_solver. + + rewrite /trace_silent /trace_now /pred_at /= in Hsil. + punfold Hupto. inversion Hupto; simplify_eq. + apply IH. by pfold. + - punfold Hupto. induction Hupto as [s|tr tr' s ℓ Hsil Hs1 Hs2 IH|tr tr' s ℓ s' ℓ' Hs Hl]. + + rewrite /trace_now /pred_at //=. intros HP. constructor 1. naive_solver. + + intros Hnow. constructor 2; naive_solver. + + rewrite {1}/trace_now /pred_at //=. intros Hnow. constructor 1. + apply Hp3. naive_solver. + Qed. + + Lemma ltl_se_now_or Q Q' P1 P1' P2 P2': + (∀ s, P1 s ↔ P1' (Us s)) → + (∀ s l l', Ul l = Some l' → P2 s (Some l) ↔ (P2' (Us s) (Some l'))) → + (∀ s l, P2 s (Some l) → is_Some (Ul l)) → + (∀ s l, Q s l ↔ P1 s ∨ ∃ l', l = Some l' ∧ P2 s l) → + (∀ s l, Q' s l ↔ P1' s ∨ ∃ l', l = Some l' ∧ P2' s l) → + ltl_se (trace_until trace_silent (↓ Q)) (↓ Q'). + Proof. + intros Hp1 Hp2 Hp3 Heq1 Heq2 tr tr' Hupto; split. + - induction 1 as [tr Hnow| s ℓ tr Hsil Htu IH]. + + destruct tr as [s|s ℓ tr], tr' as [s'|s' ℓ' tr'] =>//=; + rewrite /trace_now /pred_at /= Heq1 Heq2 in Hnow *. + * punfold Hupto. inversion Hupto; simplify_eq; naive_solver. + * punfold Hupto. inversion Hupto; simplify_eq; naive_solver. + * punfold Hupto. inversion Hupto; simplify_eq. destruct Hnow as [|[?[? HP2]]]. naive_solver. + simplify_eq. exfalso. apply Hp3 in HP2. have [??] : is_Some (None : option L')=>//. congruence. + * punfold Hupto. inversion Hupto; simplify_eq; last naive_solver. + destruct Hnow as [|[?[? HP2]]]; [naive_solver|]. + simplify_eq. exfalso. apply Hp3 in HP2. have [??] : is_Some (None : option L')=>//. congruence. + + rewrite /trace_silent /trace_now /pred_at /= in Hsil. + punfold Hupto. inversion Hupto; simplify_eq. + apply IH. by pfold. + - punfold Hupto. induction Hupto as [s|tr tr' s ℓ Hsil Hs1 Hs2 IH|tr tr' s ℓ s' ℓ' Hs Hl]. + + rewrite /trace_now /pred_at //=. intros HP. constructor 1. naive_solver. + + intros Hnow. constructor 2; naive_solver. + + rewrite /trace_now /pred_at //= Heq2. intros Hnow. constructor 1. rewrite Heq1. + naive_solver. + Qed. + + Lemma ltl_se_always P P': + ltl_se P P' → + ltl_se (□ P) (□ P'). + Proof. + intros Hse tr1 tr2 Hupto. rewrite !trace_alwaysI. split. + - intros Hal tr2' Hsuff. destruct (upto_stutter_suffix_of _ _ _ _ _ Hupto Hsuff) as (?&?&Hupto'). + apply (Hse _ _ Hupto'). by apply Hal. + - intros Hal tr1' Hsuff. destruct (upto_stutter_suffix_of_inv _ _ _ _ _ Hupto Hsuff) as (?&?&Hupto'). + apply (Hse _ _ Hupto'). by apply Hal. + Qed. + + Lemma ltl_se_eventually P P': + ltl_se P P' → + ltl_se (◊ P) (◊ P'). + Proof. + intros Hse tr1 tr2 Hupto. rewrite !trace_eventuallyI. split. + - intros (?&Hsuff&?). destruct (upto_stutter_suffix_of_inv _ _ _ _ _ Hupto Hsuff) as (?&?&Hupto'). + eexists _; split=>//. apply (Hse _ _ Hupto'). naive_solver. + - intros (?&Hsuff&?). destruct (upto_stutter_suffix_of _ _ _ _ _ Hupto Hsuff) as (?&?&Hupto'). + eexists _; split=>//. apply (Hse _ _ Hupto'). naive_solver. + Qed. + + Lemma ltl_se_eventually_now P P': + (∀ l, P l ↔ (∃ l', Ul l = Some l' ∧ P' l')) → + ltl_se (◊ ((ℓ↓ P))) (◊ (ℓ↓ P')). + Proof. + intros ?. have Hccl: ltl_se (◊ (trace_until trace_silent (ℓ↓ P))) (◊ (ℓ↓ P')). + { by apply ltl_se_eventually, ltl_se_now. } + intros tr tr' ?. rewrite (trace_eventually_until_eventually trace_silent). + by apply Hccl. + Qed. + + Lemma ltl_se_eventually_now' P P': + (∀ s, P s None ↔ P' (Us s) None) → + (∀ s ℓ, Ul ℓ = None → (P s (Some ℓ) ↔ P' (Us s) None)) → + (∀ s l, P s (Some l) ↔ (∃ l', Ul l = Some l' ∧ P' (Us s) (Some l'))) → + ltl_se (◊ ((↓ P))) (◊ (↓ P')). + Proof. + intros ???. have Hccl: ltl_se (◊ (trace_until trace_silent (↓ P))) (◊ (↓ P')). + { by apply ltl_se_eventually, ltl_se_now'. } + intros tr tr' ?. rewrite (trace_eventually_until_eventually trace_silent). + by apply Hccl. + Qed. + + Lemma ltl_se_eventually_now_or Q Q' P1 P1' P2 P2': + (∀ s, P1 s ↔ P1' (Us s)) → + (∀ s l l', Ul l = Some l' → P2 s (Some l) ↔ (P2' (Us s) (Some l'))) → + (∀ s l, P2 s (Some l) → is_Some (Ul l)) → + (∀ s l, Q s l ↔ P1 s ∨ ∃ l', l = Some l' ∧ P2 s l) → + (∀ s l, Q' s l ↔ P1' s ∨ ∃ l', l = Some l' ∧ P2' s l) → + ltl_se (◊ ((↓ Q))) (◊ (↓ Q')). + Proof. + intros ?????. have Hccl: ltl_se (◊ (trace_until trace_silent (↓ Q))) (◊ (↓ Q')). + { by eapply ltl_se_eventually, ltl_se_now_or. } + intros tr tr' ?. rewrite (trace_eventually_until_eventually trace_silent). + by apply Hccl. + Qed. + + Lemma ltl_se_impl P P' Q Q': + ltl_se P P' → + ltl_se Q Q' → + ltl_se (P → Q) (P' → Q'). + Proof. + intros HseP HseQ tr1 tr2 Hupto. rewrite !trace_impliesI. + split; intros Himpl H%(HseP _ _ Hupto); apply (HseQ _ _ Hupto); naive_solver. + Qed. + + Lemma ltl_se_forall {X} P P': + (∀ (x : X), ltl_se (P x) (P' x)) → + ltl_se (λ tr, ∀ x, P x tr) (λ tr, ∀ x, P' x tr). + Proof. intros Hse tr1 tr2 Hupto. naive_solver. Qed. +End stutter. + +Section traces_match. + Context {L1 L2 S1 S2: Type}. + Context (Rl: L1 -> L2 -> Prop) (Rs: S1 -> S2 -> Prop). + Context (trans1: S1 -> L1 -> S1 -> Prop). + Context (trans2: S2 -> L2 -> S2 -> Prop). + + Notation tm := (traces_match Rl Rs trans1 trans2). + + Definition ltl_tme (P: ltl_pred S1 L1) (Q: ltl_pred S2 L2) := + ∀ tr tr', tm tr tr' → (P tr ↔ Q tr'). + + Lemma ltl_tme_use {P Q tr1 tr2}: + ltl_tme P Q → + tm tr1 tr2 → + P tr1 → + Q tr2. + Proof. intros Htme Htm. rewrite Htme //. Qed. + + Lemma ltl_tme_now P P': + (∀ l1 l2, Rl l1 l2 → (P l1 ↔ P' l2)) → + ltl_tme (ℓ↓ P) (ℓ↓ P'). + Proof. + intros Heq tr1 tr2 Htm. rewrite /trace_label /pred_at. + destruct tr1, tr2=>//=; inversion Htm; simplify_eq. naive_solver. + Qed. + + Lemma ltl_tme_always P P': + ltl_tme P P' → + ltl_tme (□ P) (□ P'). + Proof. + intros Hse tr1 tr2 Htm. rewrite !trace_alwaysI. split. + - intros Hal tr2' Hsuff. destruct (traces_match_suffix_of _ _ _ _ _ _ _ Htm Hsuff) as (?&?&Htm'). + apply (Hse _ _ Htm'). by apply Hal. + - intros Hal tr1' Hsuff. destruct (traces_match_suffix_of_inv _ _ _ _ _ _ _ Htm Hsuff) as (?&?&Htm'). + apply (Hse _ _ Htm'). by apply Hal. + Qed. + + Lemma ltl_tme_eventually P P': + ltl_tme P P' → + ltl_tme (◊ P) (◊ P'). + Proof. + intros Hse tr1 tr2 Htm. rewrite !trace_eventuallyI. split. + - intros (?&Hsuff&?). destruct (traces_match_suffix_of_inv _ _ _ _ _ _ _ Htm Hsuff) as (?&?&Htm'). + eexists _; split=>//. apply (Hse _ _ Htm'). naive_solver. + - intros (?&Hsuff&?). destruct (traces_match_suffix_of _ _ _ _ _ _ _ Htm Hsuff) as (?&?&Htm'). + eexists _; split=>//. apply (Hse _ _ Htm'). naive_solver. + Qed. + + Lemma ltl_tme_impl P P' Q Q': + ltl_tme P P' → + ltl_tme Q Q' → + ltl_tme (P → Q) (P' → Q'). + Proof. + intros HseP HseQ tr1 tr2 Htm. rewrite !trace_impliesI. + split; intros Himpl H%(HseP _ _ Htm); apply (HseQ _ _ Htm); naive_solver. + Qed. + + Lemma ltl_tme_forall {X} P P': + (∀ (x : X), ltl_tme (P x) (P' x)) → + ltl_tme (λ tr, ∀ x, P x tr) (λ tr, ∀ x, P' x tr). + Proof. intros Hse tr1 tr2 Hupto. naive_solver. Qed. +End traces_match. diff --git a/fairneris/map_included_utils.v b/fairneris/map_included_utils.v new file mode 100644 index 0000000..e69eb39 --- /dev/null +++ b/fairneris/map_included_utils.v @@ -0,0 +1,485 @@ +From Coq Require Import ssreflect. +From stdpp Require Import gmap. + +(* TODO: Make context, and generalise lemmas to canonical representation *) +Lemma map_included_spec `{∀ A, Lookup K A (MAP A)} {A} + (R : relation A) (m1 m2 : MAP A) : + map_included R m1 m2 ↔ + (∀ k v1, m1 !! k = Some v1 → ∃ v2, m2 !! k = Some v2 ∧ R v1 v2). +Proof. + split. + - rewrite /map_included /map_relation /option_relation. + intros HR. + intros k v1 Hv1. + specialize (HR k). rewrite Hv1 in HR. + destruct (m2 !! k) eqn:Heqn; [|done]. + exists a. done. + - intros HR. + rewrite /map_included /map_relation /option_relation. + intros k. + destruct (m1 !! k) eqn:Heqn. + + apply HR in Heqn as [v2 [Hv2 HR']]. + rewrite Hv2. done. + + by destruct (m2 !! k). +Qed. + +Lemma map_included_insert `{Countable K} {A} + (R : relation A) (m1 m2 : gmap K A) i x y : + R x y → + map_included R m1 m2 → + map_included R (<[i:=x]>m1) (<[i:=y]>m2). +Proof. + intros HR Hle. + rewrite /map_included /map_relation /option_relation. + intros k. + destruct (decide (i=k)) as [<-|Hneq]. + - rewrite !lookup_insert. done. + - rewrite lookup_insert_ne; [done|]. + rewrite lookup_insert_ne; [done|]. + apply Hle. +Qed. + + +Lemma map_included_refl `{∀ A, Lookup K A (MAP A)} {A} + `{!Reflexive R} (m : MAP A) : + map_included R m m. +Proof. rewrite map_included_spec. intros. by eauto. Qed. + +(* TODO: Move *) +(* TODO: Generalise to map_included instead of subseteq? *) +Lemma map_included_subseteq `{∀ A, Lookup K A (MAP A)} {A} + (R : relation A) (m1 m2 m3 : MAP A) : + m1 ⊆ m2 → map_included R m2 m3 → map_included R m1 m3. +Proof. + rewrite /subseteq /map_subseteq !map_included_spec. + intros Hle1 Hle2. + intros k v1 HSome. + apply Hle1 in HSome as [v2 [HSome HR]]. + apply Hle2 in HSome as [v3 [HSome HR']]. + exists v3. split; [done|]. + by subst. +Qed. + +(* TODO: Generalise to better typeclasses *) +Lemma map_included_subseteq_inv `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) : + map_included R m1 m2 → (dom m1) ⊆ (dom m2). +Proof. + rewrite /map_included /map_relation /option_relation. + intros Hle k. rewrite !elem_of_dom. specialize (Hle k). + intros [? Heq]. rewrite Heq in Hle. + by destruct (m2 !! k). +Qed. + +Lemma map_included_transitivity `{∀ A, Lookup K A (MAP A)} {A} + `{!Transitive R} (m1 m2 m3 : MAP A) : + map_included R m1 m2 → map_included R m2 m3 → map_included R m1 m3. +Proof. + rewrite !map_included_spec. + intros Hle1 Hle2. + intros k v1 HSome. + apply Hle1 in HSome as [v2 [HSome HR]]. + apply Hle2 in HSome as [v3 [HSome HR']]. + exists v3. split; [done|]. + by etransitivity. +Qed. + +(* TODO: Generalize types *) +Lemma map_included_fmap `{Countable K} {A} + (R : relation A) (m : gmap K A) (f : A → A) : + (∀ x:A, R x (f x)) → map_included R m (f <$> m). +Proof. + intros Hf. intros k. rewrite lookup_fmap. + destruct (m !! k); [by apply Hf|done]. +Qed. + +Lemma map_included_mono `{Countable K} {A} + (R : relation A) (m1 m2 : gmap K A) (f : A → A) : + (∀ x1 x2 : A, R x1 x2 → R (f x1) (f x2)) → + map_included R m1 m2 → + map_included R (f <$> m1) (f <$> m2). +Proof. + rewrite !map_included_spec. + intros Hf Hle. intros k v1. + intros HSome. + apply lookup_fmap_Some in HSome as (v1'&HSome&Hv1'). + apply Hle in Hv1' as (v2'&HSome2&Hv2). + exists (f v2'). simplify_eq. + rewrite lookup_fmap. rewrite HSome2. + split; [done|]. by apply Hf. +Qed. + +Lemma map_included_mono_strong `{Countable K} {A} + (R : relation A) (m1 m2 : gmap K A) (f1 f2 : gmap K A → gmap K A) : + dom (f1 m1) ⊆ dom m1 → dom m2 ⊆ dom (f2 m2) → + (∀ k x1 x2 y1 y2, + m1 !! k = Some x1 → m2 !! k = Some x2 → + (f1 m1) !! k = Some y1 → (f2 m2) !! k = Some y2 → + R x1 x2 → R y1 y2) → + map_included R m1 m2 → + map_included R (f1 m1) (f2 m2). +Proof. + rewrite !map_included_spec. + intros Hle1 Hle2 Hf HR. intros k v1. + intros HSome1. + assert (∃ v1', m1 !! k = Some v1') as [v1' HSome1']. + { apply elem_of_dom_2 in HSome1. apply Hle1 in HSome1. + apply elem_of_dom in HSome1 as [? ->]. by eauto. } + pose proof HSome1' as HSome1''. + apply HR in HSome1'' as (v2'&HSome2'&Hv2'). + assert (∃ v2, f2 m2 !! k = Some v2) as [v2 HSome2]. + { apply elem_of_dom_2 in HSome2'. apply Hle2 in HSome2'. + apply elem_of_dom in HSome2' as [? ->]. by eauto. } + exists v2. split; [done|]. + by eapply Hf. +Qed. + +Lemma map_included_filter `{Countable K} {A} + (R : relation A) (m1 m2 : gmap K A) (P : (K * A) → Prop) + `{∀ x, Decision (P x)} : + (∀ k x1 x2, + m1 !! k = Some x1 → m2 !! k = Some x2 → P (k,x1) → P (k,x2)) → + map_included R m1 m2 → + map_included R (filter P m1) (filter P m2). +Proof. + rewrite !map_included_spec. + intros HP Hle k v1 HSome1. + pose proof HSome1 as HP'. + apply map_lookup_filter_Some_1_1 in HSome1. + apply map_lookup_filter_Some_1_2 in HP'. + pose proof HSome1 as HSome2. + apply Hle in HSome2 as [v2 [HSome2 HR]]. + specialize (HP k v1 v2 HSome1 HSome2 HP'). + exists v2. split; [|done]. + by apply map_lookup_filter_Some_2. +Qed. + +Lemma map_included_subseteq_r `{∀ A, Lookup K A (MAP A)} {A} + (R : relation A) (m1 m2 m3 : MAP A) : + m2 ⊆ m3 → map_included R m1 m2 → map_included R m1 m3. +Proof. + rewrite /subseteq /map_subseteq !map_included_spec. + intros Hle1 Hle2. + intros k v1 HSome. + apply Hle2 in HSome as [v2 [HSome HR]]. + apply Hle1 in HSome as [v3 [HSome HR']]. + exists v3. split; [done|]. + by subst. +Qed. + +Definition map_agree_R `{∀ A, Lookup K A (MAP A)} {A B} + (R : A → B → Prop) (m1 : MAP A) (m2 : MAP B) := + map_relation R (λ _, False) (λ _, False) m1 m2. + +Lemma map_agree_R_spec `{∀ A, Lookup K A (MAP A)} {A} + (R : relation A) (m1 m2 : MAP A) : + map_agree_R R m1 m2 ↔ + (∀ k v1, m1 !! k = Some v1 → ∃ v2, m2 !! k = Some v2 ∧ R v1 v2) ∧ + (∀ k v2, m2 !! k = Some v2 → ∃ v1, m1 !! k = Some v1 ∧ R v1 v2). +Proof. + rewrite /map_agree_R /map_relation /option_relation. split. + - intros HR. split. + + intros k v HSome. specialize (HR k). rewrite HSome in HR. + destruct (m2 !! k); [by eauto|done]. + + intros k v HSome. specialize (HR k). rewrite HSome in HR. + destruct (m1 !! k); [by eauto|done]. + - intros [HR1 HR2] k. + destruct (m1 !! k) as [v1|] eqn:Heqn1. + { by apply HR1 in Heqn1 as [? [-> ?]]. } + destruct (m2 !! k) as [v2|] eqn:Heqn2. + { apply HR2 in Heqn2 as [? [? ?]]. by simplify_eq. } + done. +Qed. + +Lemma map_included_delete `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) k : + map_included R m1 m2 → + map_included R (delete k m1) (delete k m2). +Proof. + rewrite !map_included_spec. + intros Hle k' v HSome. + apply lookup_delete_Some in HSome as [HK HSome]. + apply Hle in HSome as (?&?&?). + exists x. by rewrite lookup_delete_ne. +Qed. + +Lemma map_agree_R_dom `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) : + map_agree_R R m1 m2 → dom m1 = dom m2. +Proof. + rewrite map_agree_R_spec. intros [Hle1 Hle2]. apply set_eq. + intros k. split. + - intros [v1 HSome1]%elem_of_dom. + apply Hle1 in HSome1 as (?&?&?). + by apply elem_of_dom. + - intros [v2 HSome2]%elem_of_dom. + apply Hle2 in HSome2 as (?&?&?). + by apply elem_of_dom. +Qed. + +Lemma map_agree_R_insert `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) k v1 v2 : + R v1 v2 → + map_agree_R R m1 m2 → + map_agree_R R (<[k:=v1]>m1) (<[k:=v2]>m2). +Proof. + rewrite !map_agree_R_spec. + intros HR [Hle1 Hle2]. + split. + - intros k' v1' HSome1. + destruct (decide (k = k')) as [->|Hneq]. + + rewrite lookup_insert in HSome1. simplify_eq. + exists v2. rewrite lookup_insert. done. + + rewrite lookup_insert_ne in HSome1; [done|]. + apply Hle1 in HSome1 as (v2'&HSome2&HR2). + exists v2'. rewrite lookup_insert_ne; [|done]. done. + - intros k' v2' HSome2. + destruct (decide (k = k')) as [->|Hneq]. + + rewrite lookup_insert in HSome2. simplify_eq. + exists v1. rewrite lookup_insert. done. + + rewrite lookup_insert_ne in HSome2; [done|]. + apply Hle2 in HSome2 as (v1'&HSome1&HR1). + exists v1'. rewrite lookup_insert_ne; [|done]. done. +Qed. + +Lemma map_agree_R_insert_inv `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) k v1 v2 : + k ∉ dom m1 → k ∉ dom m2 → + map_agree_R R (<[k:=v1]>m1) (<[k:=v2]>m2) → + map_agree_R R m1 m2. +Proof. + intros Hnin1 Hnin2. + rewrite !map_agree_R_spec. + intros [Hle1 Hle2]. + split. + - intros k' v1' HSome1. + destruct (decide (k = k')) as [->|Hneq]. + { apply not_elem_of_dom in Hnin1. set_solver. } + assert (<[k:=v1]>m1 !! k' = Some v1') as HSome1'. + { by rewrite lookup_insert_ne. } + apply Hle1 in HSome1' as (v2'&HSome2&HR). + rewrite lookup_insert_ne in HSome2; [done|]. + by eauto. + - intros k' v2' HSome2. + destruct (decide (k = k')) as [->|Hneq]. + { apply not_elem_of_dom in Hnin2. set_solver. } + assert (<[k:=v2]>m2 !! k' = Some v2') as HSome2'. + { by rewrite lookup_insert_ne. } + apply Hle2 in HSome2' as (v1'&HSome1&HR). + rewrite lookup_insert_ne in HSome1; [done|]. + by eauto. +Qed. + +Lemma map_agree_R_agree `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) k v1 v2 : + m1 !! k = Some v1 → m2 !! k = Some v2 → + map_agree_R R m1 m2 → + R v1 v2. +Proof. + rewrite map_agree_R_spec. + intros HSome1 HSome2 Hle. + apply Hle in HSome1 as (v2'&HSome2'&HR). + rewrite HSome2' in HSome2. by simplify_eq. +Qed. + +Lemma map_included_R_agree `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) k v1 v2 : + m1 !! k = Some v1 → m2 !! k = Some v2 → + map_included R m1 m2 → + R v1 v2. +Proof. + rewrite map_included_spec. + intros HSome1 HSome2 Hle. + apply Hle in HSome1 as (v2'&HSome2'&HR). + rewrite HSome2' in HSome2. by simplify_eq. +Qed. + +Lemma map_included_map_agree_R `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) : + map_included R m1 m2 → + ∃ m21 m22, + m2 = m21 ∪ m22 ∧ + m21 ##ₘ m22 ∧ + map_agree_R R m1 m21. +Proof. + revert m1. + induction m2 as [|k v2 m2 Hnin IHm2] using map_ind; intros m1 Hle. + { by exists ∅, ∅. } + destruct (decide (k ∈ dom m1)) as [Hin|Hnin']; last first. + { apply (map_included_delete _ _ _ k) in Hle. + rewrite delete_insert in Hle; [done|]. + apply IHm2 in Hle as (m21&m22&->&Hdisj&HR). + exists m21, (<[k:=v2]>m22). + assert (dom m1 = dom m21) as Hdom. + { eapply map_agree_R_dom. apply not_elem_of_dom in Hnin'. + by rewrite delete_notin in HR. } + apply map_disjoint_dom in Hdisj. + rewrite insert_union_r; [by apply not_elem_of_dom; set_solver|]. + split; [done|]. + apply not_elem_of_dom in Hnin'. + rewrite delete_notin in HR; [done|]. + split; [|done]. + apply map_disjoint_dom. + apply not_elem_of_dom in Hnin'. + set_solver. } + apply elem_of_dom in Hin as [v1 HSome]. + assert (R v1 v2). + { eapply map_included_R_agree; [| |done]. + - done. + - by rewrite lookup_insert. } + apply (map_included_delete _ _ _ k) in Hle. + rewrite delete_insert in Hle; [done|]. + apply IHm2 in Hle as (m21&m22&->&Hdisj&HR). + exists (<[k:=v2]>m21), m22. + assert (dom (delete k m1) = dom m21) as Hdom. + { eapply map_agree_R_dom. done. } + apply map_disjoint_dom in Hdisj. + rewrite insert_union_l. + split; [done|]. + apply (map_agree_R_insert _ _ _ k v1 v2) in HR; [|done]. + rewrite insert_delete in HR; [done|]. + split; [|done]. + apply map_disjoint_dom. + rewrite dom_insert_L. + apply not_elem_of_dom in Hnin. + set_solver. +Qed. + +Lemma map_agree_R_map_included `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) : + map_agree_R R m1 m2 → map_included R m1 m2. +Proof. + rewrite map_included_spec map_agree_R_spec. + by intros [Hle _]. +Qed. + +Lemma map_agree_R_union_inv `{Countable K} {V} + (R : relation V) (m11 m12 m2 : gmap K V) : + m11 ##ₘ m12 → + map_agree_R R (m11 ∪ m12) m2 → + ∃ m21 m22, m2 = m21 ∪ m22 ∧ map_agree_R R m11 m21 ∧ + map_agree_R R m12 m22. +Proof. + intros Hdisj%map_disjoint_dom Hle. + pose proof Hle as Hdom%map_agree_R_dom. + rewrite comm in Hdom. + rewrite dom_union_L in Hdom. + apply dom_union_inv_L in Hdom as (m21&m22&->&Hdosj&Hdom1&Hdom2); + [|done]. + exists m21, m22. + split; [done|]. + split. + - apply map_agree_R_spec. + split. + + intros k v1 HSome1. + apply map_agree_R_spec in Hle as [Hle1 Hle2]. + assert ((m11 ∪ m12) !! k = Some v1) as HSome1'. + { rewrite lookup_union_l; [|done]. + apply not_elem_of_dom. + apply elem_of_dom_2 in HSome1. set_solver. } + apply Hle1 in HSome1' as (v2&HSome2'&HR). + assert (m21 !! k = Some v2) as HSome2. + { rewrite lookup_union_l in HSome2'; [|done]. + apply not_elem_of_dom. apply elem_of_dom_2 in HSome1. + set_solver. } + eauto. + + intros k v2 HSome2. + apply map_agree_R_spec in Hle as [Hle1 Hle2]. + assert ((m21 ∪ m22) !! k = Some v2) as HSome2'. + { rewrite lookup_union_l; [|done]. + apply not_elem_of_dom. + apply elem_of_dom_2 in HSome2. set_solver. } + apply Hle2 in HSome2' as (v1&HSome1'&HR). + assert (m11 !! k = Some v1) as HSome1. + { rewrite lookup_union_l in HSome1'; [|done]. + apply not_elem_of_dom. apply elem_of_dom_2 in HSome2. + set_solver. } + eauto. + - apply map_agree_R_spec. + split. + + intros k v1 HSome1. + apply map_agree_R_spec in Hle as [Hle1 Hle2]. + assert ((m11 ∪ m12) !! k = Some v1) as HSome1'. + { rewrite lookup_union_r; [|done]. + apply not_elem_of_dom. + apply elem_of_dom_2 in HSome1. set_solver. } + apply Hle1 in HSome1' as (v2&HSome2'&HR). + assert (m22 !! k = Some v2) as HSome2. + { rewrite lookup_union_r in HSome2'; [|done]. + apply not_elem_of_dom. apply elem_of_dom_2 in HSome1. + set_solver. } + eauto. + + intros k v2 HSome2. + apply map_agree_R_spec in Hle as [Hle1 Hle2]. + assert ((m21 ∪ m22) !! k = Some v2) as HSome2'. + { rewrite lookup_union_r; [|done]. + apply not_elem_of_dom. + apply elem_of_dom_2 in HSome2. set_solver. } + apply Hle2 in HSome2' as (v1&HSome1'&HR). + assert (m12 !! k = Some v1) as HSome1. + { rewrite lookup_union_r in HSome1'; [|done]. + apply not_elem_of_dom. apply elem_of_dom_2 in HSome2. + set_solver. } + eauto. +Qed. + +(* OBS: Need restrictions on f *) +Lemma map_agree_R_fmap_inv `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) f : + (* OBS: Is this a general relation/function property? *) + (∀ v1 v2, R (f v1) v2 → ∃ v2', v2 = f v2') → + map_agree_R R (f <$> m1) m2 → + ∃ m2', m2 = f <$> m2'. +Proof. + revert m1. + induction m2 as [|k v2 m2 Hnin IHm2] using map_ind; intros m1 Hf Hle. + { exists ∅. rewrite fmap_empty. done. } + pose proof Hle as Hle'. + apply map_agree_R_spec in Hle. + assert (<[k:=v2]> m2 !! k = Some v2) as HSome2 + by by rewrite lookup_insert. + apply Hle in HSome2 as (v1&HSome1&HR). + apply lookup_fmap_Some in HSome1 as (v1'&<-&HSome1'). + assert (∃ v2', v2 = f v2') as [v2' Heq]. + { by eapply Hf. } + rewrite Heq in HR. + assert (map_agree_R R (f <$> (delete k m1)) m2) as Hle''. + { rewrite -(insert_id m1 k v1') in Hle'; [done|]. + rewrite -insert_delete_insert in Hle'. + rewrite fmap_insert in Hle'. + eapply map_agree_R_insert_inv; [| |apply Hle']. + - set_solver. + - apply not_elem_of_dom. set_solver. + } + apply IHm2 in Hle'' as [m2' Heq']; [|done]. + exists (<[k:=v2']>m2'). + rewrite fmap_insert. rewrite Heq. f_equiv. done. +Qed. + +(* OBS: Need restrictions on f *) +Lemma map_agree_R_fmap `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) f : + (∀ v1 v2, R (f v1) (f v2) → R v1 v2) → + map_agree_R R (f <$> m1) (f <$> m2) → + map_agree_R R m1 m2. +Proof. + intros Hf. + rewrite !map_agree_R_spec. + intros [Hle1 Hle2]. + split. + - intros k v1 HSome1. + assert ((f <$> m1) !! k = Some (f v1)) as HSome1'. + { rewrite lookup_fmap. destruct (m1 !! k); [by simplify_eq|done]. } + apply Hle1 in HSome1' as (v2'&HSome2'&HR). + apply lookup_fmap_Some in HSome2' as (v2&<-&HSome2). + apply Hf in HR. + by eauto. + - intros k v2 HSome2. + assert ((f <$> m2) !! k = Some (f v2)) as HSome2'. + { rewrite lookup_fmap. destruct (m2 !! k); [by simplify_eq|done]. } + apply Hle2 in HSome2' as (v1'&HSome1'&HR). + apply lookup_fmap_Some in HSome1' as (v1&<-&HSome1). + apply Hf in HR. + by eauto. +Qed. + diff --git a/fairneris/mu_calculus_lite.v b/fairneris/mu_calculus_lite.v new file mode 100644 index 0000000..0d9f86a --- /dev/null +++ b/fairneris/mu_calculus_lite.v @@ -0,0 +1,61 @@ +From stdpp Require Import option. +From fairneris Require Export inftraces. + +Definition mu_pred (S L : Type) : Type := trace S L → Prop. + +Section mu_defs. + Context {S L : Type}. + + Notation mu_pred := (mu_pred S L). + + Definition trtail (tr : trace S L) : option (L * trace S L) := + match tr with + | ⟨s⟩ => None + | s -[ℓ]-> r => Some (ℓ,r) + end. + + Definition mu_now (P : S → Prop) : mu_pred := + λ tr, P $ trfirst tr. + Definition mu_box (P : L → Prop) (ϕ : mu_pred) : mu_pred := + λ tr, ∃ l tr', trtail tr = Some (l, tr') ∧ P l ∧ ϕ tr'. + + Definition mu_pred_mono (F : mu_pred → mu_pred) : Prop := + ∀ (ϕ ψ : mu_pred), (∀ tr, ϕ tr → ψ tr) → (∀ tr, F ϕ tr → F ψ tr). + + Definition mu_mu {A} (F : (A → Prop) → (A → Prop)) : (A → Prop) := + λ tr, ∃ (ϕ : (A → Prop)), (∀ tr, ϕ tr → F ϕ tr) ∧ ϕ tr. + Definition mu_nu {A} (F : (A → Prop) → (A → Prop)) : (A → Prop) := + λ tr, ∀ (ϕ : (A → Prop)), (∀ tr, F ϕ tr → ϕ tr) → ϕ tr. + + (* Definition mu_mu (F : mu_pred → mu_pred) : mu_pred := *) + (* λ tr, ∃ (ϕ : mu_pred), (∀ tr, ϕ tr → F ϕ tr) ∧ ϕ tr. *) + (* Definition mu_nu (F : mu_pred → mu_pred) : mu_pred := *) + (* λ tr, ∀ (ϕ : mu_pred), (∀ tr, F ϕ tr → ϕ tr) → ϕ tr. *) + + Class MonoPred {A : Type} (F : (A → Prop) → (A → Prop)) := { + mono_pred (Φ Ψ : A → Prop) : (∀ x, Φ x → Ψ x) → ∀ x, F Φ x → F Ψ x; + }. + + Lemma least_fixpoint_unfold_2 {A} (F : (A → Prop) → (A → Prop)) `{!MonoPred F} x : + F (mu_nu F) x → mu_nu F x. + Proof using Type*. + rewrite /mu_nu /=. intros HF ϕ Hincl. + apply Hincl. eapply mono_pred; [|by apply HF]. + intros y H'. apply H'. apply Hincl. + Qed. + + Lemma least_fixpoint_unfold_1 {A} (F : (A → Prop) → (A → Prop)) `{!MonoPred F} x : + mu_nu F x → F (mu_nu F) x. + Proof using Type*. + intros HF. apply HF. + intros y Hy. eapply mono_pred; [|by apply HF]. + intros z ?. by apply least_fixpoint_unfold_2. + Qed. + + Corollary least_fixpoint_unfold {A} (F : (A → Prop) → (A → Prop)) `{!MonoPred F} x : + mu_nu F x ↔ F (mu_nu F) x. + Proof using Type*. + split; [by apply least_fixpoint_unfold_1|by apply least_fixpoint_unfold_2]. + Qed. + +End mu_defs. diff --git a/fairneris/partial_termination.v b/fairneris/partial_termination.v new file mode 100644 index 0000000..14caf04 --- /dev/null +++ b/fairneris/partial_termination.v @@ -0,0 +1,444 @@ +From Paco Require Import pacotac. +From stdpp Require Import finite. +From iris.proofmode Require Import proofmode. +From trillium Require Import adequacy. +From fairneris Require Import fairness retransmit_model. +From fairneris.aneris_lang Require Import aneris_lang resources. +From fairneris.aneris_lang.state_interp Require Import state_interp_def. +From fairneris.aneris_lang.state_interp Require Import state_interp_config_wp. +From fairneris.aneris_lang.state_interp Require Import state_interp. +From fairneris.aneris_lang.program_logic Require Import aneris_weakestpre. +From fairneris Require Import from_locale_utils trace_utils ltl_lite. + +Definition snd_proj {A1 A2 B1 B2} (l : (A1 * A2) + (B1 * B2)) : (A2 + B2) := + sum_map snd snd l. + +Definition ex_send_filter msg : cfg aneris_lang → option $ ex_label aneris_lang → Prop := + λ _ l, option_map (sum_map snd id) l = Some $ inl $ Some msg. +Instance ex_send_filter_decision msg st l : Decision (ex_send_filter msg st l). +Proof. apply make_decision. Qed. + +Definition ex_deliver_filter msg : cfg aneris_lang → option $ ex_label aneris_lang → Prop := + λ _ l, option_map (sum_map snd id) l = Some $ inr $ Some msg. +Instance ex_deliver_filter_decision msg st l : Decision (ex_deliver_filter msg st l). +Proof. apply make_decision. Qed. + +Definition retransmit_fair_network_delivery_ex msg : extrace aneris_lang → Prop := + □ (□◊↓ex_send_filter msg → ◊↓ex_deliver_filter msg). + +Definition retransmit_fair_network_ex (extr : extrace aneris_lang) : Prop := + ∀ msg, retransmit_fair_network_delivery_ex msg extr. + +(* TODO: Clean up this definition (annoying to state lemmas about, + due to separate labels) *) +Definition live_tid (c : cfg aneris_lang) (δ : retransmit_state) + (ℓ:retransmit_node_role) (ζ:locale aneris_lang) : Prop := + roles_match ζ ℓ → + role_enabled_model (ℓ:fmrole retransmit_fair_model) δ → locale_enabled ζ c. + +Definition live_tids (c : cfg aneris_lang) (δ : retransmit_state) : Prop := + ∀ ℓ ζ, live_tid c δ ℓ ζ. + +Definition live_traces_match : extrace aneris_lang → mtrace → Prop := + traces_match labels_match live_tids language.locale_step retransmit_trans. + +Lemma traces_match_cons_inv {S1 S2 L1 L2} + (Rℓ: L1 -> L2 -> Prop) (Rs: S1 -> S2 -> Prop) + (trans1: S1 -> L1 -> S1 -> Prop) + (trans2: S2 -> L2 -> S2 -> Prop) + s1 s2 l1 l2 tr1 tr2 : + traces_match Rℓ Rs trans1 trans2 (s1 -[l1]-> tr1) (s2 -[l2]-> tr2) -> + Rs s1 s2 ∧ Rℓ l1 l2. +Proof. intros Hm. inversion Hm; done. Qed. + +Lemma traces_match_valid_preserved extr mtr : + live_traces_match extr mtr → mtrace_valid mtr. +Proof. + rewrite /mtrace_valid trace_alwaysI. intros Hmatch tr [n Hsuffix]. + eapply traces_match_after in Hmatch as [? [? Hmatch]]; [|done]. + by inversion Hmatch. +Qed. + +Definition extrace_fair (extr : extrace aneris_lang) := + (∀ ζ, fair_scheduling_ex ζ extr) ∧ retransmit_fair_network_ex extr. + +Lemma labels_match_deliver_filter_impl msg s1 s2 ℓ1 ℓ2 extr mtr : + labels_match ℓ1 ℓ2 → + (↓ ex_deliver_filter msg) (s1 -[ ℓ1 ]-> extr) → + (↓ deliver_filter msg) (s2 -[ ℓ2 ]-> mtr). +Proof. + intros Hmatch Hmtr. + rewrite /trace_now /pred_at /ex_deliver_filter in Hmtr. + rewrite /trace_now /pred_at /deliver_filter. simpl in *. + destruct ℓ1; simplify_eq. + destruct ℓ2; [done|]. + rewrite /labels_match /locale_retransmit_label in Hmatch. + by simplify_eq. +Qed. + +Lemma labels_match_send_filter_impl msg s1 s2 ℓ1 ℓ2 extr mtr : + labels_match ℓ1 ℓ2 → + (↓ send_filter msg) (s2 -[ ℓ2 ]-> mtr) → + (↓ ex_send_filter msg) (s1 -[ ℓ1 ]-> extr). +Proof. + intros Hmatch Hmtr. + rewrite /trace_now /pred_at /send_filter in Hmtr. + rewrite /trace_now /pred_at /ex_send_filter. simpl in *. + simplify_eq. + destruct ℓ2; simplify_eq. + assert (r.2 = Some msg) as Heq1. + { destruct r. + rewrite /label_action /locale_retransmit_label in Hmtr. + simpl in *. by simplify_eq. } + destruct ℓ1; simplify_eq; last first. + { rewrite /labels_match /locale_retransmit_label in Hmatch. + simplify_eq. } + assert (l.2 = r.2) as Heq2. + { rewrite /labels_match /locale_retransmit_label in Hmatch. + destruct l. + destruct (locale_retransmit_role l); [|done]. + simpl in *. simplify_eq. simpl. done. } + simpl. rewrite Heq2 Heq1. done. +Qed. + +Lemma fair_network_impl extr mtr : + live_traces_match extr mtr → + retransmit_fair_network_ex extr → retransmit_fair_network mtr. +Proof. + rewrite /retransmit_fair_network_ex /retransmit_fair_network. + intros Hmatch Hfairex_network. + assert (mtrace_valid mtr) as Hvalid. + { by eapply traces_match_valid_preserved. } + intros msg. + specialize (Hfairex_network msg). + rewrite /retransmit_fair_network_delivery_ex in Hfairex_network. + rewrite trace_alwaysI in Hfairex_network. + rewrite /retransmit_fair_network_delivery. + rewrite trace_alwaysI. + intros mtr' [n Hmtr']. + pose proof Hmtr' as Hextr'. + eapply traces_match_after in Hextr'; [|done]. + destruct Hextr' as (extr'&Hextr'&Hmatch'). + specialize (Hfairex_network extr'). + assert (trace_suffix_of extr' extr) as Hsuffix. + { eexists _. done. } + apply Hfairex_network in Hsuffix. + rewrite trace_impliesI. + rewrite trace_impliesI in Hsuffix. + intros Hmtr''. + assert ((□ ◊ ↓ ex_send_filter msg) extr') as Hextr''. + { rewrite trace_alwaysI. + intros extr'' [m Hextr'']. + eapply traces_match_flip in Hmatch'. + pose proof Hextr'' as Hmtr'''. + eapply traces_match_after in Hmtr'''; [|done]. + destruct Hmtr''' as (mtr''&Hmtr'''&Hmatch''). + rewrite trace_alwaysI in Hmtr''. + specialize (Hmtr'' mtr''). + assert (trace_suffix_of mtr'' mtr') as Hsuffix'. + { eexists _. done. } + apply Hmtr'' in Hsuffix'. + rewrite trace_eventuallyI in Hsuffix'. + destruct Hsuffix' as [mtr''' [Hsuffix' Hmtr'''']]. + destruct Hsuffix' as [m'' Hsuffix']. + apply traces_match_flip in Hmatch''. + eapply traces_match_after in Hmatch''; [|done]. + destruct Hmatch'' as [extr''' [Hextr''' Hmatch''']]. + destruct mtr'''; [done|]. + simpl in *. + rewrite trace_eventuallyI. exists extr'''. + split; [eexists _;done|]. + destruct extr'''; [by inversion Hmatch'''|]. + assert (labels_match ℓ0 ℓ) as Hlabels. + { by eapply traces_match_cons_inv. } + by eapply labels_match_send_filter_impl. } + apply Hsuffix in Hextr''. + rewrite trace_eventuallyI in Hextr''. + destruct Hextr'' as [extr'' [[m Hsuffix''] Hextr'']]. + rewrite trace_eventuallyI. + eapply traces_match_flip in Hmatch'. + eapply traces_match_after in Hmatch'; [|done]. + destruct Hmatch' as [mtr'' [Hmtr''' Hmatch'']]. + exists mtr''. split; [by eexists _|]. + destruct extr''; [done|]. + destruct mtr''; [by inversion Hmatch''|]. + assert (labels_match ℓ ℓ0) as Hlabels. + { eapply traces_match_cons_inv. apply traces_match_flip. done. } + by eapply labels_match_deliver_filter_impl. +Qed. + +Definition retransmit_role_locale (ρ : retransmit_node_role) : locale aneris_lang := + match ρ with + | Arole => ("0.0.0.0",0) + | Brole => ("0.0.0.1",0) + end. + +Lemma locale_retransmit_role_cancel ρ : + locale_retransmit_role (retransmit_role_locale ρ) = Some ρ. +Proof. by destruct ρ. Qed. + +Lemma fair_scheduling_impl extr mtr : + live_traces_match extr mtr → + (∀ ζ, fair_scheduling_ex ζ extr) → retransmit_fair_scheduling mtr. +Proof. + rewrite /fair_scheduling_ex /retransmit_fair_scheduling. + intros Hmatch Hextr ρ. + rewrite /retransmit_fair_scheduling_mtr. + rewrite /trace_always_eventually_implies_now. + rewrite /trace_always_eventually_implies. + rewrite trace_alwaysI. + intros mtr' [n Hmtr_after]. rewrite trace_impliesI. + intros Hρ. + eapply traces_match_after in Hmatch; [|done]. + destruct Hmatch as [extr' [Hextr_after Hmatch]]. + specialize (Hextr (retransmit_role_locale ρ) n). + rewrite /pred_at in Hextr. + rewrite Hextr_after in Hextr. + assert (match extr' with + | ⟨ s ⟩ | s -[ _ ]-> _ => locale_enabled (retransmit_role_locale ρ) s + end) as Hextr'. + { apply traces_match_first in Hmatch. + destruct extr'. + - eapply (Hmatch ρ). + + destruct ρ; done. + + rewrite /trace_now /pred_at in Hρ. simpl in *. + by destruct mtr'. + - eapply (Hmatch ρ). + + destruct ρ; done. + + rewrite /trace_now /pred_at in Hρ. simpl in *. + by destruct mtr'. } + apply Hextr in Hextr' as [m Hextr']. + rewrite after_sum' Hextr_after in Hextr'. + destruct (after m extr') as [extr''|] eqn:Hextr_after'; last first. + { rewrite Hextr_after' in Hextr'. done. } + rewrite Hextr_after' in Hextr'. + rewrite trace_eventuallyI. + apply traces_match_flip in Hmatch. + eapply traces_match_after in Hmatch; [|done]. + destruct Hmatch as [mtr'' [Hmtr_after' Hmatch]]. + exists mtr''. split; [by eexists _|]. + rewrite /trace_now /pred_at=> /=. + destruct mtr''. + - destruct extr''; [|by inversion Hmatch]. + destruct Hextr' as [Hextr'|Hextr']; [|naive_solver]. + left. intros Hs. apply Hextr'. + apply traces_match_first in Hmatch. + eapply (Hmatch ρ). + + destruct ρ; done. + + rewrite /trace_now /pred_at in Hρ. simpl in *. done. + - destruct extr''; [by inversion Hmatch|]. + destruct Hextr' as [Hextr'|Hextr']. + { left. intros Hs. apply Hextr'. + apply traces_match_first in Hmatch. + eapply (Hmatch ρ). + + destruct ρ; done. + + rewrite /trace_now /pred_at in Hρ. simpl in *. done. } + right. simpl in *. simplify_eq. + apply traces_match_cons_inv in Hmatch as [_ Hmatch]. + rewrite /labels_match in Hmatch. + destruct ℓ0 as [[ζ act]|]; [|naive_solver]. + simpl in *. destruct Hextr'. simplify_eq. + rewrite locale_retransmit_role_cancel in Hmatch. + simpl in *. simplify_eq. done. +Qed. + +Lemma traces_match_fairness_preserved extr mtr : + live_traces_match extr mtr → + extrace_fair extr → mtrace_fair mtr. +Proof. + intros Hmatch [Hfairex_sched Hfairex_network]. + split; [by eapply fair_scheduling_impl|by eapply fair_network_impl]. +Qed. + +(* TODO: This needs updating to capture spawned threads *) +(* TODO: Can likely get rid of right disjunct if we assume maximality *) +Definition extrace_terminating_locale (ζ : locale aneris_lang) (tr : extrace aneris_lang) : Prop := + (◊↓λ st _, ¬ locale_enabled ζ st) tr ∨ ¬ infinite_trace tr. + +Lemma disabled_always_disabled ρ (mtr : mtrace) : + mtrace_valid mtr → + (↓λ st _, ρ ∉ retransmit_live_roles st) mtr → + (□↓λ st _, ρ ∉ retransmit_live_roles st) mtr. +Proof. + intros Hvalid Hmtr. + rewrite trace_alwaysI. + intros mtr' [m Hafter]. + revert mtr' Hmtr Hafter Hvalid. + induction m as [|m Hm]; intros mtr' Hmtr Hafter Hvalid. + { simpl in *. simplify_eq. done. } + replace (S m) with (m + 1) in Hafter by lia. + rewrite after_sum' in Hafter. + destruct (after m mtr) as [mtr''|] eqn:Heqn; [|done]. + eapply Hm in Hmtr; [|done|done]. + eapply trace_always_suffix_of in Hvalid; [|by eexists _]. + apply trace_always_elim in Hvalid. + destruct mtr''; [done|]. simpl in *. simplify_eq. + rewrite /trace_now /pred_at in Hmtr. simpl in *. + rewrite /trace_now /pred_at. simpl in *. + destruct mtr'. + - inversion Hvalid; try set_solver. + - inversion Hvalid; try set_solver. +Qed. + +Lemma retransmit_trace_valid_live ρ (mtr : mtrace) : + mtrace_valid mtr → + (↓ (λ (_ : retransmit_state) (ℓ : option retransmit_label), + option_map label_role ℓ = Some (inl ρ))) mtr → + ρ ∈ retransmit_live_roles (trfirst mtr). +Proof. + intros Hvalid Hlabel. + apply trace_always_elim in Hvalid. + destruct mtr; [done|]. + rewrite /trace_now /pred_at in Hlabel. simpl in *. + inversion Hvalid; set_solver. +Qed. + +(* TODO: Prove using logic laws instead. *) +Lemma not_infinite_terminating_trace {S L} (tr : trace S L) : + ¬ infinite_trace tr → terminating_trace tr. +Proof. + intros Hinf. epose proof (infinite_or_finite tr) as [?|?]; done. +Qed. + +Lemma trace_always_mono_strong_alt + {S1 S2 L1 L2} + (P : trace S1 L1 → Prop) + (Q : trace S2 L2 → Prop) + Rℓ Rs trans1 trans2 + (tr1 : trace S1 L1) (tr2 : trace S2 L2) : + traces_match Rℓ Rs trans1 trans2 tr1 tr2 → + (∀ tr1' tr2', traces_match Rℓ Rs trans1 trans2 tr1' tr2' → + (P tr1') → (Q tr2')) → + (□ P) tr1 → (□ Q) tr2. +Proof. + rewrite !trace_alwaysI. intros Hmatch Himpl HP1 tr2' [n Hafter2]. + eapply traces_match_after in Hmatch as [tr1' [Hafter1 Hmatch]]; [|done]. + eapply Himpl; [done|]. apply HP1. by eexists _. +Qed. + +Lemma trace_eventually_mono_strong_alt + {S1 S2 L1 L2} + (P : trace S1 L1 → Prop) + (Q : trace S2 L2 → Prop) + Rℓ Rs trans1 trans2 + (tr1 : trace S1 L1) (tr2 : trace S2 L2) : + traces_match Rℓ Rs trans1 trans2 tr1 tr2 → + (∀ tr1' tr2', traces_match Rℓ Rs trans1 trans2 tr1' tr2' → + (P tr1') → (Q tr2')) → + (◊ P) tr1 → (◊ Q) tr2. +Proof. + rewrite !trace_eventuallyI. intros Hmatch Himpl [tr1' [[n Hafter1] HP1]]. + eapply traces_match_flip in Hmatch. + eapply traces_match_after in Hmatch as [tr2' [Hafter2 Hmatch]]; [|done]. + exists tr2'. split; [by eexists _|]. + apply traces_match_flip in Hmatch. by eapply Himpl. +Qed. + +Lemma terminating_role_preserved ρ ζ mtr extr : + extrace_fair extr → + live_traces_match extr mtr → + roles_match ζ ρ → + retransmit_terminating_role ρ mtr → + extrace_terminating_locale ζ extr. +Proof. + intros Hfair Hmatch Hroles Hmtr. + assert (extrace_terminating_locale ζ extr ∨ + ¬ extrace_terminating_locale ζ extr) as HEM. + { by apply ExcludedMiddle. } + destruct HEM as [|Hextr]; [done|]. exfalso. + apply Classical_Prop.not_or_and in Hextr as [Hextr Hinf]. + assert ((□ ↓ (λ st _, locale_enabled ζ st)) extr) as Hextr'. + { apply trace_always_not_not_eventually in Hextr. + revert Hextr. apply trace_always_mono. + intros tr. apply trace_impliesI. intros Hextr. + apply trace_now_not in Hextr. + revert Hextr. apply trace_now_mono. + intros s _. intros Hextr. by apply NNP_P. } + assert ((□ ◊ ↓ (λ _ otid, option_map (sum_map fst id) otid = Some (inl ζ))) + extr) as Hex_sched. + { pose proof Hextr' as Hextr''. + revert Hextr'. apply trace_always_mono_strong. + intros extr' Hsuffix. rewrite trace_impliesI. + intros Hextr'. + destruct Hfair as [Hfair_sched _]. + specialize (Hfair_sched ζ). + (* TODO: Bump fairness to LTL *) + destruct Hsuffix as [n Hafter]. + eapply trace_implies_after in Hfair_sched; [|done]. + apply Hfair_sched in Hextr' as [m Hextr']. + simpl in *. + apply trace_eventuallyI. + rewrite /pred_at in Hextr'. + destruct (after m extr') as [extr''|] eqn:Heqn; last first. + { by rewrite Heqn in Hextr'. } + rewrite Heqn in Hextr'. + exists extr''. + split; [by eexists _|]. + destruct extr''. + - destruct Hextr'; [|naive_solver]. + eapply trace_always_suffix_of in Hextr''; [|by eexists _]. + eapply trace_always_suffix_of in Hextr''; [|by eexists _]. + apply trace_always_elim in Hextr''. done. + - destruct Hextr'; [|naive_solver]. + eapply trace_always_suffix_of in Hextr''; [|by eexists _]. + eapply trace_always_suffix_of in Hextr''; [|by eexists _]. + apply trace_always_elim in Hextr''. done. + } + assert ((□ ◊ ↓ (λ _ ℓ, option_map label_role ℓ = Some (inl ρ))) + mtr) as Hmtr_sched. + { revert Hex_sched. + eapply trace_always_mono_strong_alt; [done|]. + intros extr' mtr' Hmatch'. + eapply trace_eventually_mono_strong_alt; [done|]. + intros extr'' mtr'' Hmatch''. + rewrite /trace_now /pred_at=> /=. + destruct extr''; [done|]. + destruct mtr''; [by inversion Hmatch''|]. + apply traces_match_cons_inv in Hmatch'' as [_ Hmatch'']. + intros Heq. + destruct ℓ as [[]|]; [|done]. + rewrite /labels_match /locale_retransmit_label in Hmatch''. + rewrite /roles_match in Hroles. + simpl in *. simplify_eq. + destruct (locale_retransmit_role ζ) eqn:Heqn; [|done]. + simpl in *. by simplify_eq. } + destruct Hmtr as [Hmtr|Hmtr]; last first. + { apply NNP_P in Hinf. apply not_infinite_terminating_trace in Hmtr. + destruct Hmtr as [n Hafter]. + specialize (Hinf n) as [extr' Hafter']. + apply traces_match_flip in Hmatch. + eapply traces_match_after in Hmatch as [mtr'' [Hafter'' _]]; [|done]. + by simplify_eq. } + clear Hinf Hextr Hextr' Hex_sched. + eapply trace_eventually_mono_strong in Hmtr; last first. + { intros mtr' Hsuffix Hmtr'. + eapply disabled_always_disabled; [|done]. + eapply trace_always_suffix_of; [done|]. + by eapply traces_match_valid_preserved. } + rewrite trace_eventuallyI in Hmtr. + destruct Hmtr as [mtr' [Hmtr_suffix Hmtr']]. + rewrite trace_alwaysI in Hmtr_sched. + specialize (Hmtr_sched mtr' Hmtr_suffix). + rewrite trace_eventuallyI in Hmtr_sched. + destruct Hmtr_sched as [mtr'' [Hmtr_suffix' Hmtr'']]. + rewrite trace_alwaysI in Hmtr'. + specialize (Hmtr' mtr'' Hmtr_suffix'). + assert (mtrace_valid mtr''). + { eapply trace_always_suffix_of; [done|]. + eapply trace_always_suffix_of; [done|]. + by eapply traces_match_valid_preserved. } + apply retransmit_trace_valid_live in Hmtr''; [|done]. + by destruct mtr''. +Qed. + +Lemma fair_extrace_terminate extr mtr : + live_traces_match extr mtr → + extrace_valid extr → extrace_fair extr → + extrace_terminating_locale localeB extr. +Proof. + intros Hmatch Hvalid Hfair. + eapply terminating_role_preserved; [done|done|done|]. + apply retransmit_fair_traces_terminate; + [by eapply traces_match_valid_preserved|]. + by eapply traces_match_fairness_preserved. +Qed. diff --git a/fairneris/prelude/collect.v b/fairneris/prelude/collect.v new file mode 100644 index 0000000..bb4251b --- /dev/null +++ b/fairneris/prelude/collect.v @@ -0,0 +1,296 @@ +From Coq.ssr Require Import ssreflect. +From iris.algebra Require Import gmap gmultiset. + +Section collect. + Context {K} `{!EqDecision K} `{Countable K} {A : Type} + {B : Type} `{!EqDecision B} `{Countable B} + (f : K → A → gset B). + + Definition collect (g : gmap K A) : gset B := + map_fold (λ k a acc, (f k a) ∪ acc) ∅ g. + + Lemma collect_singleton k a : + collect {[k := a]} = f k a. + Proof. + rewrite /collect. + rewrite map_fold_insert_L. + - simpl. rewrite map_fold_empty; set_solver. + - set_solver. + - done. + Qed. + + Lemma collect_empty : + collect ∅ = ∅. + Proof. by rewrite /collect. + Qed. + + Lemma collect_insert k a g : + collect (<[k:=a]> g) = f k a ∪ collect (delete k g). + Proof. + generalize dependent a. + generalize dependent k. + pattern (collect g); pattern g. + match goal with + |- (λ x, (λ y, ?P) _) _ => + simpl; apply (map_fold_ind (M := gmap _) (B := gset B) (λ y, λ x, P)) + end; [ done | exact ∅ | |]. + - intros. rewrite collect_singleton. + rewrite delete_empty. rewrite collect_empty. set_solver. + - intros k' a' h acc Hk' IH k a. + destruct (decide (k = k')) as [-> | Hneq]. + + rewrite insert_insert delete_insert_delete. + set_solver. + + rewrite delete_insert_ne; last done. + assert ((<[k:=a]>(<[k':=a']> h)) = (<[k':=a']>(<[k:=a]> h))) as ->. + { by rewrite insert_commute; last done. } + rewrite /collect. + rewrite {1} map_fold_insert_L. + specialize (IH k a). + rewrite /collect in IH. + rewrite IH. + rewrite {1} map_fold_insert_L. + * set_solver. + * set_solver. + * by rewrite lookup_delete_ne. + * set_solver. + * by rewrite lookup_insert_ne; last done. + Qed. + + + Lemma collect_disjoint_union g h : + g ##ₘ h → + collect (g ∪ h) = collect g ∪ collect h. + Proof. + intros Hdisj. + generalize dependent h. + pattern (collect g); pattern g. + match goal with + |- (λ x, (λ y, ?P) _) _ => + simpl; apply (map_fold_ind (M := gmap _) (λ y, λ x, P)) + end. + - intros. by rewrite !left_id_L. + - intros k a g' acc Hk IHM h' Hdisj. + assert (f k a ∪ acc ∪ collect h' = + acc ∪ (f k a ∪ collect h')) as -> by set_solver. + rewrite insert_union_singleton_l. + assert ({[k := a]} ∪ g' ∪ h' = g' ∪ ({[k := a]} ∪ h')) as ->. + { rewrite (map_union_comm {[k := a]} g'). + by rewrite map_union_assoc. + by apply map_disjoint_singleton_l_2. } + rewrite IHM. + + rewrite -insert_union_singleton_l. + rewrite collect_insert. + simplify_map_eq. + rewrite delete_notin; last done. + done. + + apply map_disjoint_union_r_2. + * by apply map_disjoint_singleton_r_2. + * simplify_map_eq. set_solver. + Qed. + + Lemma collect_empty_f g : + (forall k a, g !! k = Some a → f k a = ∅) → collect g = ∅. + Proof. + pattern (collect g); pattern g. + match goal with + |- (λ x, (λ y, ?P) _) _ => + simpl; apply (map_fold_ind (M := gmap _) (λ y, λ x, P)) + end. + - done. + - intros k a g' M Hk IHM IHMi. + rewrite empty_union_L; split. + + specialize (IHMi k a). apply IHMi. + by rewrite lookup_insert. + + apply IHM. intros k' a' Hka'. + specialize (IHMi k' a'). + apply IHMi. + destruct (decide (k = k')) as [<-|Hneq]; by simplify_map_eq. + Qed. + + Lemma elem_of_collect g : + ∀ m, m ∈ collect g ↔ ∃ k a, g !! k = Some a ∧ m ∈ f k a. + Proof. + pattern (collect g); pattern g. + match goal with + |- (λ x, (λ y, ?P) _) _ => + simpl; apply (map_fold_ind (M := gmap _) (λ y, λ x, P)) + end. + - intros m; split; first done. + intros (?&?&?&?); done. + - intros k a g' M Hk IHM m. + split. + + intros [Hm|Hm]%elem_of_union. + * exists k, a; rewrite lookup_insert; done. + * apply IHM in Hm as (k' & a' & Hk' & Hm). + exists k', a'. + rewrite lookup_insert_ne; first done. + set_solver. + + intros (k' & a' & Hk' & Hm). + destruct (decide (k' = k)) as [->|]. + * rewrite lookup_insert in Hk'; simplify_eq. + set_solver. + * rewrite lookup_insert_ne in Hk'; last done. + apply elem_of_union; right. + apply IHM; eauto. + Qed. + +End collect. + +Section multi_collect. + Context {K} `{!EqDecision K} `{Countable K} {A : Type} + {B : Type} `{!EqDecision B} `{Countable B} + (f : K → A → gmultiset B). + + Definition multi_collect (g : gmap K A) : gmultiset B := + map_fold (λ k a acc, (f k a) ⊎ acc) ∅ g. + + Lemma multi_collect_singleton k a : + multi_collect {[k := a]} = f k a. + Proof. + rewrite /multi_collect. + rewrite map_fold_insert_L. + - simpl. rewrite map_fold_empty; multiset_solver. + - multiset_solver. + - done. + Qed. + + Lemma multi_collect_empty : + multi_collect ∅ = ∅. + Proof. by rewrite /multi_collect. + Qed. + + Lemma multi_collect_insert k a g : + multi_collect (<[k:=a]> g) = f k a ⊎ multi_collect (delete k g). + Proof. + generalize dependent a. + generalize dependent k. + pattern (multi_collect g); pattern g. + match goal with + |- (λ x, (λ y, ?P) _) _ => + simpl; apply (map_fold_ind (M := gmap _) (B := gset B) (λ y, λ x, P)) + end; [ done | exact ∅ | |]. + - intros. rewrite multi_collect_singleton; multiset_solver. + - intros k' a' h acc Hk' IH k a. + destruct (decide (k = k')) as [-> | Hneq]. + + rewrite insert_insert delete_insert_delete. + set_solver. + + rewrite delete_insert_ne; last done. + assert ((<[k:=a]>(<[k':=a']> h)) = (<[k':=a']>(<[k:=a]> h))) as ->. + { by rewrite insert_commute; last done. } + rewrite /multi_collect. + rewrite {1} map_fold_insert_L. + specialize (IH k a). + rewrite /multi_collect in IH. + rewrite IH. + rewrite {1} map_fold_insert_L. + * multiset_solver. + * multiset_solver. + * by rewrite lookup_delete_ne. + * multiset_solver. + * by rewrite lookup_insert_ne; last done. + Qed. + + + Lemma multi_collect_disjoint_union g h : + g ##ₘ h → + multi_collect (g ∪ h) = multi_collect g ⊎ multi_collect h. + Proof. + intros Hdisj. + generalize dependent h. + pattern (multi_collect g); pattern g. + match goal with + |- (λ x, (λ y, ?P) _) _ => + simpl; apply (map_fold_ind (M := gmap _) (λ y, λ x, P)) + end. + - intros. by rewrite !left_id_L. + - intros k a g' acc Hk IHM h' Hdisj. + assert (f k a ⊎ acc ⊎ multi_collect h' = + acc ⊎ (f k a ⊎ multi_collect h')) as -> by multiset_solver. + rewrite insert_union_singleton_l. + assert ({[k := a]} ∪ g' ∪ h' = g' ∪ ({[k := a]} ∪ h')) as ->. + { rewrite (map_union_comm {[k := a]} g'). + by rewrite map_union_assoc. + by apply map_disjoint_singleton_l_2. } + rewrite IHM. + + rewrite -insert_union_singleton_l. + rewrite multi_collect_insert. + simplify_map_eq. + rewrite delete_notin; last done. + done. + + apply map_disjoint_union_r_2. + * by apply map_disjoint_singleton_r_2. + * simplify_map_eq. set_solver. + Qed. + + Lemma multi_collect_empty_f g : + (forall k a, g !! k = Some a → f k a = ∅) → multi_collect g = ∅. + Proof. + pattern (multi_collect g); pattern g. + match goal with + |- (λ x, (λ y, ?P) _) _ => + simpl; apply (map_fold_ind (M := gmap _) (λ y, λ x, P)) + end. + - done. + - intros k a g' M Hk IHM IHMi. + cut (f k a = ∅ ∧ M = ∅). (* TODO: add to stdpp *) + { multiset_solver. } + split. + + specialize (IHMi k a). apply IHMi. + by rewrite lookup_insert. + + apply IHM. intros k' a' Hka'. + specialize (IHMi k' a'). + apply IHMi. + destruct (decide (k = k')) as [<-|Hneq]; by simplify_map_eq. + Qed. + + Lemma elem_of_multi_collect g : + ∀ m, m ∈ multi_collect g ↔ ∃ k a, g !! k = Some a ∧ m ∈ f k a. + Proof. + pattern (multi_collect g); pattern g. + match goal with + |- (λ x, (λ y, ?P) _) _ => + simpl; apply (map_fold_ind (M := gmap _) (λ y, λ x, P)) + end. + - intros m; split; first multiset_solver. + intros (?&?&?&?); done. + - intros k a g' M Hk IHM m. + split. + + intros [Hm|Hm]%gmultiset_elem_of_disj_union. + * exists k, a; rewrite lookup_insert; done. + * apply IHM in Hm as (k' & a' & Hk' & Hm). + exists k', a'. + rewrite lookup_insert_ne; first done. + set_solver. + + intros (k' & a' & Hk' & Hm). + destruct (decide (k' = k)) as [->|]. + * rewrite lookup_insert in Hk'; simplify_eq. + set_solver. + * rewrite lookup_insert_ne in Hk'; last done. + apply gmultiset_elem_of_disj_union; right. + apply IHM; eauto. + Qed. + + Lemma multi_collect_subseteq (g1 g2 : gmap K A) : + (∀ k v1, g1 !! k = Some v1 -> ∃ v2, g2 !! k = Some v2 ∧ f k v1 ⊆ f k v2) -> + multi_collect g1 ⊆ multi_collect g2. + Proof. + generalize dependent g2. pattern (multi_collect g1); pattern g1. + match goal with + |- (λ x, (λ y, ?P) _) _ => + simpl; apply (map_fold_ind (M := gmap _) (λ y, λ x, P)) + end. + - intros g2 Hf. multiset_solver. + - intros i a m r Hnone IH g2 Hf'. rewrite /multi_collect. + pose proof (Hf' i a) as Hin. + rewrite lookup_insert in Hin. + destruct (Hin eq_refl) as (a' & Hing2 & Hfincl). + rewrite -(insert_delete g2 i a') //. + rewrite map_fold_insert_L //; last first. + { rewrite lookup_delete //. } + { intros. multiset_solver. } + assert (r ⊆ map_fold (λ (k : K) (a0 : A) (acc : gmultiset B), f k a0 ⊎ acc) ∅ (delete i g2)); + last multiset_solver. + apply IH. intros k v Hv. destruct (decide (i = k)) as [<-|Hneq]; first congruence. + rewrite lookup_delete_ne //. apply Hf'. rewrite lookup_insert_ne //. + Qed. +End multi_collect. diff --git a/fairneris/prelude/gmultiset.v b/fairneris/prelude/gmultiset.v new file mode 100644 index 0000000..48246b7 --- /dev/null +++ b/fairneris/prelude/gmultiset.v @@ -0,0 +1,55 @@ +From stdpp Require Import gmultiset gmap. +From Coq.ssr Require Import ssreflect. + + +Section lemmas. + Context `{!EqDecision A} `{!Countable A}. + + Implicit Types M N : gmultiset A. + Implicit Types X Y : gset A. + Implicit Types x y : A. + + Definition gset_of_gmultiset (M : gmultiset A) : gset A := dom M. + + Lemma elem_of_gset_of_gmultiset M x : x ∈ gset_of_gmultiset M ↔ (0 < multiplicity x M). + Proof. rewrite /gset_of_gmultiset gmultiset_elem_of_dom. apply elem_of_multiplicity. Qed. + + Lemma gset_of_gmultiset_empty : gset_of_gmultiset ∅ = ∅. + Proof. eapply @dom_empty_L; apply _. Qed. + + Lemma gset_of_gmultiset_singleton x : gset_of_gmultiset {[+ x +]} = {[ x ]}. + Proof. apply dom_singleton_L. Qed. + + Lemma gmultiset_difference_subseteq M N : M ∖ N ⊆ M. + Proof. intros x; rewrite multiplicity_difference; lia. Qed. + + Lemma gmultiset_difference_after_disj_union M N : (M ⊎ N) ∖ N = M. + Proof. + apply gmultiset_eq; intros x. + rewrite multiplicity_difference multiplicity_disj_union. + lia. + Qed. + + Lemma gset_of_gmultiset_disj_union M N : + gset_of_gmultiset (M ⊎ N) = (gset_of_gmultiset M) ∪ (gset_of_gmultiset N). + Proof. + apply set_eq=> x. + rewrite elem_of_union !elem_of_gset_of_gmultiset multiplicity_disj_union. + lia. + Qed. + + Lemma gset_of_gmultiset_subseteq_mono M N : + N ⊆ M → gset_of_gmultiset N ⊆ gset_of_gmultiset M. + Proof. + intros Hle x. rewrite !elem_of_gset_of_gmultiset. + intros Hin. specialize (Hle x). lia. + Qed. + + Lemma gset_of_gmultiset_disj_union_subseteq M N : + N ⊆ M → gset_of_gmultiset (M ⊎ N) = gset_of_gmultiset M. + Proof. + intros Hle. rewrite gset_of_gmultiset_disj_union. + apply gset_of_gmultiset_subseteq_mono in Hle. set_solver. + Qed. + +End lemmas. diff --git a/fairneris/prelude/gset_map.v b/fairneris/prelude/gset_map.v new file mode 100644 index 0000000..a4b1913 --- /dev/null +++ b/fairneris/prelude/gset_map.v @@ -0,0 +1,416 @@ +From Coq.ssr Require Import ssreflect. +From stdpp Require Import gmap functions. + +(* TODO: outphase this; [set_map] already exists in std++, a few lemmas need + upstreaming *) +Section gset_map. + Context `{EqDecision A, !Countable A, !EqDecision B, !Countable B}. + + Definition gset_map (f : A → B) (g : gset A) : gset B := + list_to_set (f <$> elements g). + + Lemma gset_map_empty f : gset_map f ∅ = ∅. + Proof. by rewrite /gset_map elements_empty /=. Qed. + + Lemma gset_map_singleton f a : gset_map f {[a]} = {[f a]}. + Proof. by rewrite /gset_map elements_singleton /= right_id_L. Qed. + + Lemma gset_map_union f g g' : + gset_map f (g ∪ g') = gset_map f g ∪ gset_map f g'. + Proof. + revert g'. + pattern g. + match goal with |- ?F g => simpl; apply (set_ind_L F) end; set_solver. + Qed. + + Lemma gset_map_not_elem_of f g `{!Inj (=) (=) f} : + ∀ a, a ∉ g → (f a) ∉ gset_map f g. + Proof. + pattern g. + match goal with |- ?F g => simpl; apply (set_ind_L F) end; set_solver. + Qed. + + Lemma gset_map_correct1 f g : ∀ a, a ∈ g → (f a) ∈ gset_map f g. + Proof. + pattern g. + match goal with |- ?F g => simpl; apply (set_ind_L F) end; set_solver. + Qed. + + Lemma gset_map_correct2 f g : ∀ b, b ∈ gset_map f g → ∃ a, b = f a ∧ a ∈ g. + Proof. + pattern g. + match goal with |- ?F g => simpl; apply (set_ind_L F) end; set_solver. + Qed. + + Lemma gset_map_fn_insert_ne x f g y : + x ∉ g → gset_map (<[x:=y]> f) g = gset_map f g. + Proof. + rewrite /gset_map. unfold_leibniz. intros ??. + rewrite !elem_of_list_to_set !elem_of_list_fmap. + split. + - intros [? [H' ?%elem_of_elements]]. + rewrite fn_lookup_insert_ne in H'; set_solver. + - intros [x' [? ?%elem_of_elements]]. exists x'. + rewrite fn_lookup_insert_ne; set_solver. + Qed. + + (* TODO: upstream? *) + Lemma gset_map_intersection f `{!Inj (=) (=) f} X Y : + gset_map f (X ∩ Y) = gset_map f X ∩ gset_map f Y. + Proof. set_solver. Qed. + + (* TODO: upstream? *) + Lemma gset_map_size X f `{!Inj (=) (=) f} : + size (gset_map f X) = size X. + Proof. + induction X using set_ind_L; [done|]. + rewrite gset_map_union gset_map_singleton. + rewrite !size_union; [set_solver|set_solver|]. + rewrite IHX !size_singleton //. + Qed. + + Lemma gset_map_disj_union X Y f `{!Inj (=) (=) f} : + X ## Y → + gset_map f X ## gset_map f Y. + Proof. set_solver. Qed. + + Lemma gset_map_const_nonempty X f y : + X ≠ ∅ → (∀ x, x ∈ X → f x = y) → gset_map f X = {[y]}. + Proof. + move=> + Hf. + induction X using set_ind_L; [done|]. + intros ?. + rewrite gset_map_union gset_map_singleton Hf; [set_solver|]. + destruct (decide (X = ∅)); simplify_eq. + { rewrite gset_map_empty union_empty_r_L //. } + rewrite IHX //; set_solver. + Qed. + +End gset_map. + +Section gset_flat_map. + Context `{EqDecision A, !Countable A, !EqDecision B, !Countable B}. + + Definition gset_flat_map (f : A → gset B) (g : gset A) : gset B := + ⋃ elements (gset_map f g). + + Lemma gset_flat_map_empty f : gset_flat_map f ∅ = ∅. + Proof. by rewrite /gset_flat_map elements_empty. Qed. + + Lemma elem_of_gset_flat_map_1 f g a b : + a ∈ g → b ∈ f a → b ∈ gset_flat_map f g. + Proof. + intros ??. rewrite /gset_flat_map elem_of_union_list. + exists (f a). rewrite elem_of_elements. + split; [|done]. + by apply gset_map_correct1. + Qed. + + Lemma gset_flat_map_union f X Y `{!Inj (=) (=) f} : + X ## Y → + gset_flat_map f (X ∪ Y) = gset_flat_map f X ∪ gset_flat_map f Y. + Proof. + intros Hdisj. + rewrite /gset_flat_map gset_map_union. + rewrite elements_disj_union //; [by eapply gset_map_disj_union|]. + rewrite union_list_app_L //. + Qed. + + Lemma elem_of_gset_flat_map_2 f g b : + b ∈ gset_flat_map f g → ∃ a, a ∈ g ∧ b ∈ f a. + Proof. + rewrite /gset_flat_map elem_of_union_list. + intros [b' [H%elem_of_elements%gset_map_correct2 ?]]. + destruct H as [? [-> ?]]. eauto. + Qed. + + Lemma elem_of_gset_flat_map_fn_insert_1 f g a b X : + a ∈ g → + b ∈ X → + b ∈ gset_flat_map (<[a := X]> f) g. + Proof. + intros ??. eapply elem_of_gset_flat_map_1; [done|]. + by rewrite fn_lookup_insert. + Qed. + + Lemma elem_of_gset_flat_map_fn_insert_2 f g a b b' : + b ∈ gset_flat_map f g → + b ∈ gset_flat_map (<[a := {[b']} ∪ f a]> f) g. + Proof. + intros [a' [? ?]]%elem_of_gset_flat_map_2. + eapply elem_of_gset_flat_map_1; [done|]. + destruct (decide (a = a')); simplify_eq. + - rewrite fn_lookup_insert. set_solver. + - rewrite fn_lookup_insert_ne //. + Qed. + + Lemma gset_flat_map_insert_2_inv m m' f a X : + m ∈ gset_flat_map (<[a:={[m']} ∪ f a]> f) X → + m = m' ∨ m ∈ gset_flat_map f X. + Proof. + intros Hmap. + apply elem_of_gset_flat_map_2 in Hmap as (a' & ? & Hin). + destruct (decide (a = a')); simplify_eq. + - rewrite fn_lookup_insert in Hin. + apply elem_of_union in Hin as [?%elem_of_singleton_1 |]; [by left|]. + right. by eapply elem_of_gset_flat_map_1. + - rewrite fn_lookup_insert_ne in Hin; [done|]. + right. by eapply elem_of_gset_flat_map_1. + Qed. + + Lemma gset_flat_map_f_empty (f : A → gset B) X : + (∀ x, x ∈ X → f x = ∅) → gset_flat_map f X = ∅. + Proof. + induction X using set_ind_L. + { intros ?. apply gset_flat_map_empty. } + intros Hf. + rewrite /gset_flat_map. + rewrite gset_map_union gset_map_singleton. + rewrite Hf; [set_solver|]. + destruct (decide (X = (∅ : gset A))); simplify_eq. + { rewrite gset_map_empty. rewrite union_empty_r_L. + rewrite elements_singleton union_list_singleton_L //. } + rewrite (gset_map_const_nonempty _ _ ∅); [done|set_solver|]. + by set_unfold. + Qed. + +End gset_flat_map. + +Section elements. + Context `{Countable A, Countable B}. + + (* TODO: upstream? *) + Lemma elements_fmap (f : A → B) `{!Inj (=) (=) f} (X : gset A) : + f <$> elements X ≡ₚ elements (gset_map f X). + Proof. + induction X using set_ind_L; [done|]. + rewrite gset_map_union. + rewrite ?elements_disj_union. + { set_solver. } + { apply gset_map_disj_union; set_solver. } + rewrite gset_map_singleton !elements_singleton. + rewrite fmap_app list_fmap_singleton IHX //. + Qed. + +End elements. + +Section fn_to_gmap. + Context `{EqDecision A, !Countable A, B : Type}. + + Definition fn_to_gmap (X : gset A) (f : A → B) : gmap A B := + set_to_map (λ a, (a, f a)) X. + + Global Instance gmap_fn_inj (f : A → B) : Inj (=) (=) (λ a : A, (a, f a)). + Proof. by intros ?? [=]. Qed. + + Lemma fn_to_gmap_dom (X : gset A) (f : A → B) : dom (fn_to_gmap X f) = X. + Proof. + rewrite /fn_to_gmap /= /set_to_map dom_list_to_map_L. + apply set_eq; intros x. + rewrite elem_of_list_to_set elem_of_list_fmap. + setoid_rewrite elem_of_list_fmap. setoid_rewrite elem_of_elements. + split. + - by intros (?&?&?&?&?); subst. + - intros; eexists (_,_); eauto. + Qed. + + Lemma lookup_fn_to_gmap (x : A) (X : gset A) (f : A → B) (y : B) : + fn_to_gmap X f !! x = Some y ↔ f x = y ∧ x ∈ X. + Proof. + rewrite /fn_to_gmap lookup_set_to_map //. + split. + - intros (?&?&?); simplify_eq; done. + - intros [<- ?]; eauto. + Qed. + + Lemma lookup_fn_to_gmap_1 (x : A) (X : gset A) (f : A → B) (y : B) : + fn_to_gmap X f !! x = Some y → f x = y. + Proof. apply lookup_fn_to_gmap. Qed. + + Lemma lookup_fn_to_gmap_2 (x : A) (X : gset A) (f : A → B) (y : B) : + x ∈ X → f x = y → fn_to_gmap X f !! x = Some y. + Proof. by intros; apply lookup_fn_to_gmap. Qed. + + Lemma lookup_fn_to_gmap_2' (x : A) (X : gset A) (f : A → B): + x ∈ X → fn_to_gmap X f !! x = Some (f x). + Proof. by intros; apply lookup_fn_to_gmap. Qed. + + Lemma lookup_fn_to_gmap_not_in (x : A) (X : gset A) (f : A → B) : + x ∉ X ↔ fn_to_gmap X f !! x = None. + Proof. + rewrite /fn_to_gmap /set_to_map -not_elem_of_list_to_map. + rewrite elem_of_list_fmap. + setoid_rewrite elem_of_list_fmap. setoid_rewrite elem_of_elements. + split. + - by intros ? (?&?&?&?&?); simplify_eq/=. + - intros Hnot ?; apply Hnot; eexists (_, _); eauto. + Qed. + + Lemma lookup_fn_to_gmap_not_in1 (x : A) (X : gset A) (f : A → B) : + x ∉ X → fn_to_gmap X f !! x = None. + Proof. apply lookup_fn_to_gmap_not_in. Qed. + + Lemma lookup_fn_to_gmap_not_in2 (x : A) (X : gset A) (f : A → B) : + fn_to_gmap X f !! x = None → x ∉ X. + Proof. apply lookup_fn_to_gmap_not_in. Qed. + + Lemma fn_to_gmap_insert (x : A) (y : B) (X : gset A) (f : A → B) : + x ∈ X → fn_to_gmap X (<[x:=y]>f) = <[x:=y]>(fn_to_gmap X f). + Proof. + intros ?. rewrite /fn_to_gmap. + apply map_eq. intros x'. + destruct (decide (x = x')) as [<-|]. + - rewrite lookup_insert lookup_set_to_map //. + exists x. split; [done|]. f_equal. + apply fn_lookup_insert. + - rewrite lookup_insert_ne //. + rewrite /set_to_map. + destruct (decide (x' ∈ X)). + + rewrite !(elem_of_list_to_map_1' _ x' (f x')) //; [| |set_solver..]. + * intros ? (?&?&?)%elem_of_list_fmap. simplify_eq. + rewrite fn_lookup_insert_ne //. + * apply elem_of_list_fmap. exists x'. + rewrite fn_lookup_insert_ne; set_solver. + + rewrite !not_elem_of_list_to_map_1; set_solver. + Qed. + + Lemma fn_to_gmap_eq_fns (X : gset A) (f g : A → B) : + (∀ x, x ∈ X → f x = g x) → fn_to_gmap X f = fn_to_gmap X g. + Proof. + intros Heq; apply map_eq; intros x. + destruct (decide (x ∈ X)). + - rewrite !lookup_fn_to_gmap_2'; [done|done|]. + rewrite Heq; done. + - rewrite !lookup_fn_to_gmap_not_in1; done. + Qed. + + Lemma const_fn_to_gmap (X : gset A) (f : A → B) (y : B) : + (∀ x, f x = y) → fn_to_gmap X f = gset_to_gmap y X. + Proof. + intros Heq; apply map_eq; intros x. + destruct (decide (x ∈ X)). + - rewrite lookup_fn_to_gmap_2'; first done. + rewrite Heq. + rewrite lookup_gset_to_gmap option_guard_True; done. + - rewrite lookup_fn_to_gmap_not_in1; first done. + rewrite lookup_gset_to_gmap option_guard_False; done. + Qed. + + Lemma fn_to_gmap_singleton (f : A → B) (x : A) : + fn_to_gmap {[x]} f = {[x := f x]}. + Proof. + rewrite /fn_to_gmap /set_to_map. + rewrite elements_singleton list_fmap_singleton //. + Qed. + + Context `{Countable B}. + + Lemma fn_to_gmap_disj_union (f : A → B) (X Y : gset A) : + X ## Y → + fn_to_gmap (X ∪ Y) f = fn_to_gmap X f ∪ fn_to_gmap Y f. + Proof. + rewrite /fn_to_gmap /set_to_map => ?. + rewrite -list_to_map_app. + apply list_to_map_proper. + { rewrite -list_fmap_compose. + eapply NoDup_fmap; [by intros ??|]. + apply NoDup_elements. } + rewrite elements_fmap gset_map_union. + rewrite elements_disj_union. + { apply gset_map_disj_union; [|set_solver]. apply _. } + rewrite !elements_fmap //. + Qed. + +End fn_to_gmap. + +Fixpoint list_to_gmap_go (i : nat) [A B] (f : A → B) (l : list A) : gmap nat B := + match l with + | nil => ∅ + | a :: l' => <[i := f a]> (list_to_gmap_go (S i) f l') + end. + +Notation list_to_gmap := (list_to_gmap_go 0). + +Section list_to_gmap. + Context {A B} (f : A → B). + + Lemma list_to_gmap_go_nil i : list_to_gmap_go i f [] = ∅. + Proof. done. Qed. + + Lemma list_to_gmap_nil : list_to_gmap f [] = ∅. + Proof. done. Qed. + + Lemma list_to_gmap_go_cons i a l : + list_to_gmap_go i f (a :: l) = <[i := f a]> (list_to_gmap_go (S i) f l). + Proof. done. Qed. + + Lemma list_to_gmap_go_lookup i j l : + i ≤ j → list_to_gmap_go i f l !! j = option_map f (l !! (j - i)). + Proof. + revert i j; induction l as [|a l IHl]; intros i j Hij. + { rewrite /= lookup_empty //. } + rewrite /=. + destruct (decide (i = j)) as [->|]. + { rewrite Nat.sub_diag lookup_insert //. } + rewrite lookup_insert_ne //. + destruct (j - i) as [|k] eqn:Heq; first lia. + replace k with (j - S i) by lia. + apply IHl; lia. + Qed. + + Lemma list_to_gmap_lookup j l : list_to_gmap f l !! j = option_map f (l !! j). + Proof. rewrite -{2}(Nat.sub_0_r j); apply (list_to_gmap_go_lookup 0); lia. Qed. + + Lemma list_to_gmap_go_lookup_lt i j locs : + j < i → list_to_gmap_go i f locs !! j = None. + Proof. + revert i j; induction locs as [|a l IHl]; intros i j Hij. + { rewrite /= lookup_empty //. } + rewrite /=. + rewrite lookup_insert_ne; first lia. + apply IHl; lia. + Qed. + + Lemma list_to_gmap_go_insert i j l a : + i ≤ j → + j < i + length l → + <[j := f a]> (list_to_gmap_go i f l) = list_to_gmap_go i f (<[j - i := a]>l). + Proof. + revert i j; induction l as [|b l IHl]; intros i j Hij Hj. + { simpl in *; lia. } + rewrite /=. + destruct (decide (i = j)) as [->|]. + { rewrite insert_insert Nat.sub_diag //. } + simpl in *. + rewrite insert_commute; first lia. + destruct (j - i) as [|k] eqn:Heq; first lia. + replace k with (j - S i) by lia. + rewrite /= IHl; [lia|lia|done]. + Qed. + + Lemma list_to_gmap_insert j a l : + j < length l → <[j := f a]> (list_to_gmap f l) = list_to_gmap f (<[j := a]>l). + Proof. rewrite -{3}(Nat.sub_0_r j); apply (list_to_gmap_go_insert 0); lia. Qed. + +End list_to_gmap. + +#[global] Instance gset_map_injective `{Countable K} `{Countable U} + (f : K → U) `{Inj K U (=) (=) f} : + Inj (=) (=) (gset_map f). +Proof. + intros X Y Heq. + apply set_eq. + intros x. + split; intros Hx. + - apply (gset_map_correct1 f) in Hx. + rewrite Heq in Hx. + apply gset_map_correct2 in Hx as [a [Heq' Hx]]. + simplify_eq. + done. + - apply (gset_map_correct1 f) in Hx. + rewrite -Heq in Hx. + apply gset_map_correct2 in Hx as [a [Heq' Hx]]. + simplify_eq. + done. +Qed. +Global Arguments list_to_gmap_go : simpl never. diff --git a/fairneris/prelude/list.v b/fairneris/prelude/list.v new file mode 100644 index 0000000..a4c3bde --- /dev/null +++ b/fairneris/prelude/list.v @@ -0,0 +1,244 @@ +From Coq.ssr Require Import ssreflect. +From stdpp Require Import list gmap. + +Definition flatten {A : Type} (l : list (list A)) : list A := fold_right (λ l1 l2, l1 ++ l2) [] l. + +Lemma elem_of_flatten {A} l l' : + l' ∈ flatten l ↔ ∃ l'' : list A, l' ∈ l'' ∧ l'' ∈ l. +Proof. + revert l'; induction l as [|a l IHl]; simpl. + - intros ?; split. + + intros ?%elem_of_nil; done. + + intros (? & ? & ?%elem_of_nil); done. + - intros l'; split. + + intros [Hl'|Hl']%elem_of_app. + * exists a; split; first done. apply elem_of_cons; auto. + * apply IHl in Hl' as (?&?&?). + eexists _; split; first done. apply elem_of_cons; auto. + + intros (l'' & Hl'l'' & [->|Hl'']%elem_of_cons). + * apply elem_of_app; auto. + * apply elem_of_app; right. apply IHl; eauto. +Qed. + +Lemma filter_cons_inv {A} (P : A → Prop) `{!∀ x, Decision (P x)} l x l': + filter P l = x :: l' → ∃ l1 l2, l = l1 ++ x :: l2 ∧ ∀ z, z ∈ l1 → ¬ P z. +Proof. + induction l as [|a l IHl]; first done. + destruct (decide (P a)). + - rewrite filter_cons_True; first done. + intros ?; simplify_eq. + exists [], l; split; first done. + setoid_rewrite elem_of_nil; done. + - rewrite filter_cons_False; first done. + intros (l1 & l2 & -> & Hfa)%IHl. + eexists (a :: _), _; split; first done. + intros ?; rewrite elem_of_cons; intros [->|]; auto. +Qed. +Lemma filter_list_extract_first2 {A} (P : A → Prop) `{!∀ x, Decision (P x)} l x y l': + filter P l = x :: y :: l' → ∃ i j, i < j ∧ l !! i = Some x ∧ l !! j = Some y ∧ P x ∧ P y. +Proof. + intros Heq. + destruct (filter_cons_inv _ _ _ _ Heq) as (l1 & l2 & -> & Hfa). + rewrite filter_app in Heq. + destruct (filter P l1) as [|b] eqn:Hl1; last first. + { exfalso; apply (Hfa b); eapply elem_of_list_filter; erewrite Hl1; apply elem_of_cons; auto. } + simpl in *. + assert (P x). + { eapply elem_of_list_filter; erewrite Heq; apply elem_of_cons; auto. } + rewrite filter_cons_True in Heq; first done. + simplify_eq. + destruct (filter_cons_inv _ _ _ _ Heq) as (l3 & l4 & -> & Hfa'). + assert (P y). + { eapply elem_of_list_filter; erewrite Heq; apply elem_of_cons; auto. } + exists (length l1), (length l1 + S (length l3)); split_and!; [lia| | |done|done]. + - rewrite lookup_app_r; first done. rewrite Nat.sub_diag; done. + - rewrite lookup_app_r; first lia. + rewrite Nat.add_comm Nat.add_sub /=. + rewrite lookup_app_r; first done. rewrite Nat.sub_diag; done. +Qed. + +Lemma prefix_Some_None {A} (P : A → Prop) `{!∀ x, Decision (P x)} xs ys zs x : + last (filter P xs) = Some x → + last (filter P ys) = None → + xs `prefix_of` ys ++ zs → + ys `prefix_of` xs. +Proof. + intros Hsome Hnone Hprefix. + rewrite last_None in Hnone. + generalize dependent xs. + induction ys as [|y ys]; intros xs Hsome Hprefix. + { by apply prefix_nil. } + destruct xs as [|x' xs]; [done|]. + assert (y = x') as <-. + { by apply prefix_cons_inv_1 in Hprefix. } + apply prefix_cons. + rewrite filter_cons in Hnone. + apply prefix_cons_inv_2 in Hprefix. + rewrite filter_cons in Hsome. + apply IHys; [by destruct (decide (P y))|by destruct (decide (P y))|done]. +Qed. + +Lemma prefix_cons_nil {A:Type} (xs : list A) y ys : + xs ≠ [] → + xs `prefix_of` y :: ys → + [y] `prefix_of` xs. +Proof. + intros Hneq Hprefix. + destruct xs; [done|]. + apply prefix_cons_inv_1 in Hprefix. + rewrite Hprefix. + by apply prefix_cons, prefix_nil. +Qed. + +Lemma last_filter_app_r {A} (P : A → Prop) `{!∀ x, Decision (P x)} xs ys x : + last (filter P (xs ++ ys)) = Some x → + last (filter P xs) = None → + last (filter P ys) = Some x. +Proof. + intros Hsome Hnone%last_None. + by rewrite filter_app Hnone in Hsome. +Qed. + +Lemma prefix_split_eq {A} (P : A → Prop) `{!∀ x, Decision (P x)} xs ys zs x y : + last (filter P xs) = Some x → + last (filter P ys) = None → + last (filter P zs) = None → + xs `prefix_of` ys ++ [y] ++ zs → + x = y. +Proof. + intros Hsome Hnone1 Hnone2 Hprefix. + assert (ys `prefix_of` xs) as [k ->]. + { by eapply prefix_Some_None. } + apply prefix_app_inv in Hprefix. + apply last_filter_app_r in Hsome; [|done]. + assert ([y] `prefix_of` k) as [k' ->]. + { eapply prefix_cons_nil; [|done]. by intros ->. } + rewrite filter_app in Hsome. + rewrite last_None in Hnone2. + apply prefix_app_inv in Hprefix. + destruct Hprefix as [k'' ->]. + rewrite filter_app in Hnone2. + apply app_eq_nil in Hnone2. + destruct Hnone2 as [Hnone2 _]. + rewrite Hnone2 in Hsome. + rewrite filter_cons in Hsome. + destruct (decide (P y)); [|done]. + simpl in *. by simplify_eq. +Qed. + +Lemma elem_of_last_filter_exists_Some + {A} `{EqDecision A} (P : A → Prop) `{!∀ x, Decision (P x)} xs x y : + last (filter P xs) = x → + y ∈ xs → P y → + ∃ x', last (filter P xs) = Some x'. +Proof. + intros Hlast Hin HPy. + induction xs as [|z xs IHxs]; [by set_solver|]. + destruct (decide (P z)) as [HPz|HPz]. + - rewrite filter_cons_True; [done|]. + assert (last (filter P xs) = None ∨ + ∃ x', last (filter P xs) = Some x') as Hfilter. + { by destruct (last (filter P xs)); [right; eexists _|left]. } + destruct Hfilter as [Hnone|[x' Hsome]]. + + exists z. rewrite last_None in Hnone. by rewrite Hnone. + + exists x'. rewrite last_cons. by rewrite Hsome. + - rewrite filter_cons_False; [done|]. + rewrite filter_cons_False in Hlast; [done|]. + assert (y ≠ z) as Hneq. + { intros Heq. by simplify_eq. } + apply elem_of_cons in Hin. + destruct Hin as [Hin|Hin]; [done|by apply IHxs]. +Qed. + +Lemma NoDup_prefix {A} (xs ys : list A) : + NoDup ys → + xs `prefix_of` ys → + NoDup xs. +Proof. + revert ys. + induction xs as [|x xs IHxs]; intros ys HNoDup Hprefix. + { by apply NoDup_nil. } + apply NoDup_cons. + destruct ys as [|y ys]. + { destruct Hprefix as [k Heq]. + by rewrite -app_comm_cons in Heq. } + assert (x = y) as <- by by apply prefix_cons_inv_1 in Hprefix. + apply prefix_cons_inv_2 in Hprefix. + apply NoDup_cons in HNoDup as [Hnin HNoDup]. + split; [|by eapply IHxs]. + intros Hin. apply Hnin. + by eapply elem_of_prefix. +Qed. + +Lemma Forall_filter_empty {A} P `{!∀ x, Decision (P x)} (xs : list A) : + Forall (λ x, ¬ P x) xs → + filter P xs = []. +Proof. + intros HForall. + induction xs as [|x xs]; [done|]. + apply Forall_cons in HForall as [HPx HForall]. + rewrite filter_cons_False; [done|]. + by apply IHxs. +Qed. + +Lemma NoDup_last_filter_Some {A} P `{!∀ x, Decision (P x)} (xs ys zs : list A) x : + NoDup zs → + last (filter P xs) = Some x → + last (filter P zs) = Some x → + xs `prefix_of` ys → + ys `prefix_of` zs → + last (filter P ys) = Some x. +Proof. + intros HNoDup Hxs Hzs Hprefix Hprefix'. + assert (NoDup ys) as HNoDupys by by eapply NoDup_prefix. + assert (NoDup xs) as HNoDupxs by by eapply NoDup_prefix. + assert (xs `prefix_of` zs) as Hprefix'' by by eapply transitivity. + assert (last (filter P xs) = Some x) as Hxs' by done. + assert (last (filter P zs) = Some x) as Hzs' by done. + apply last_filter_Some in Hxs as (l1 & l2 & -> & HP). + apply last_filter_Some in Hzs as (k1 & k2 & -> & HP'). + assert (l1 = k1 ∧ x = x ∧ l2 `prefix_of` k2) as (Heq1 & Heq2 & Hprefix'''). + { eapply prefix_not_elem_of_app_cons_inv. + { apply NoDup_app in HNoDup as (_&Hnin&HNoDup). + intros Hin. + apply Hnin in Hin. + apply Hin. by left. } + { apply NoDup_app in HNoDupxs as (_&Hnin&HNoDupxs). + intros Hin. + apply Hnin in Hin. + apply Hin. by left. } + done. } + simplify_eq. + destruct Hprefix as [k ->]. + rewrite -!assoc in Hprefix'. + apply prefix_app_inv in Hprefix'. + rewrite -app_comm_cons in Hprefix'. + apply prefix_cons_inv_2 in Hprefix'. + rewrite filter_app. + rewrite last_app. + rewrite Hxs'. + destruct Hprefix' as [k' ->]. + apply Forall_app in HP' as [HP' _]. + apply Forall_app in HP' as [_ HP']. + by rewrite Forall_filter_empty. +Qed. + +Lemma NoDup_last_filter_None {A} P `{!∀ x, Decision (P x)} (xs ys : list A) : + NoDup ys → + last (filter P ys) = None → + xs `prefix_of` ys → + last (filter P xs) = None. +Proof. + revert ys. + induction xs as [|x xs IHxs]; intros ys HNodup Hys Hprefix; [done|]. + destruct ys as [|y ys]. + { destruct Hprefix as [k Heq]. + by rewrite -app_comm_cons in Heq. } + assert (x = y) as <- by by apply prefix_cons_inv_1 in Hprefix. + apply prefix_cons_inv_2 in Hprefix. + rewrite filter_cons in Hys. + rewrite filter_cons. + destruct (decide (P x)) as [HPx|HPx]. + { rewrite last_cons in Hys. by destruct (last (filter P ys)). } + eapply IHxs; [by eapply NoDup_cons_1_2|done|done]. +Qed. diff --git a/fairneris/prelude/misc.v b/fairneris/prelude/misc.v new file mode 100644 index 0000000..da86cdc --- /dev/null +++ b/fairneris/prelude/misc.v @@ -0,0 +1,218 @@ +From iris.algebra Require Import gmap. + +Lemma nat_Z_eq (n : nat) (z : Z) : + (0 ≤ z)%Z → n = Z.to_nat z :> nat → n = z :> Z. +Proof. lia. Qed. + +Section find_one_maximal. + Context {A B : Type} (f : A → B) + (R : relation B) `{!RelDecision R} `{!Transitive R} + (S : relation B) `{!Transitive S} `{!Reflexive S} + (HRS : ∀ a b, R a b → S a b) + (HSR : ∀ a b, S a b → a = b ∨ R a b) + (HRir : ∀ a, ¬ R a a) + (HRex : ∀ a b, R a b → R b a → False) + (HSR_trans : ∀ a b c, S a b → R b c → R a c). + + Fixpoint find_one_maximal (candidate : A) (l : list A) := + match l with + | [] => candidate + | a :: l' => if bool_decide (R (f candidate) (f a)) then + find_one_maximal a l' + else + find_one_maximal candidate l' + end. + + Lemma find_one_maximal_rel c l : S (f c) (f (find_one_maximal c l)). + Proof. + revert c; induction l as [|a l IHl]; intros c; first done. + destruct (decide (R (f c) (f a))). + - rewrite /= bool_decide_eq_true_2 //; by etrans; eauto. + - rewrite /= bool_decide_eq_false_2 //. + Qed. + + Lemma find_one_maximal_maximal c l y : + y ∈ l → ¬ R (f (find_one_maximal c l)) (f y). + Proof. + revert c; induction l as [|a l IHl]; intros c; first by inversion 1. + intros [->|Hy]%elem_of_cons. + - destruct (decide (R (f c) (f a))) as [|Hnot]. + + rewrite /= bool_decide_eq_true_2 //. + pose proof (find_one_maximal_rel a l) as [ <- | ?]%HSR; + first by apply HRir. + intros ?; eapply HRex; eauto. + + rewrite /= bool_decide_eq_false_2 //. + intros ?. + apply Hnot. + eapply HSR_trans; eauto using find_one_maximal_rel. + - destruct (decide (R (f c) (f a))) as [|Hnot]. + + rewrite /= bool_decide_eq_true_2 //. + intros ?; eapply IHl; eauto. + + rewrite /= bool_decide_eq_false_2 //. + intros ?; eapply IHl; eauto. + Qed. + + Lemma find_one_maximal_eq_or_elem_of c l : + find_one_maximal c l = c ∨ find_one_maximal c l ∈ l. + Proof. + revert c; induction l as [|a l IHl]; intros c; first by left. + destruct (decide (R (f c) (f a))) as [|Hnot]. + - rewrite /= bool_decide_eq_true_2 //. + destruct (IHl a) as [->|]; by right; constructor. + - rewrite /= bool_decide_eq_false_2 //. + destruct (IHl c) as [->|]; first by left. + by right; constructor. + Qed. + + Context (HNRS : ∀ a b, ¬ R a b → S b a) + (min : A) + (Hmin : ∀ a, S (f min) a). + + Definition sup l := find_one_maximal min l. + + Lemma sup_UB l a : a ∈ l → S (f a) (f (sup l)). + Proof. by intros Hl; apply HNRS; apply find_one_maximal_maximal. Qed. + + Lemma sup_LUB l u : (∀ a, a ∈ l → S (f a) (f u)) → (S (f (sup l)) (f u)). + Proof. + intros Hu. + rewrite /sup. + destruct (find_one_maximal_eq_or_elem_of min l) as [->|]; + first by apply Hmin. + by apply Hu. + Qed. + + Context `{!RelDecision S} `{!EqDecision A} `{!AntiSymm eq S} `{!Inj eq eq f}. + + Lemma sup_elem_of a l : a ∈ l → sup l ∈ l. + Proof. + intros Hal. + rewrite /sup. + destruct (find_one_maximal_eq_or_elem_of min l) as [Heq|]; last done. + rewrite Heq. + destruct (decide (S (f a) (f min))) as [|Hnz]. + - assert (a = min) as <-; last done. + eapply inj; first apply _. + eapply anti_symm; first apply _; auto. + - exfalso; apply Hnz. + rewrite -Heq. + by apply sup_UB. +Qed. + + Lemma sup_mono l l' : (∀ a, a ∈ l → a ∈ l') → S (f (sup l)) (f (sup l')). + Proof. + destruct l as [|x l]; first by intros; rewrite /sup /=; auto. + assert (x ∈ (x :: l)) as Hx by constructor. + revert Hx. + generalize (x :: l) as k; clear l; intros l Hxl. + intros Hll. + apply sup_UB. + apply Hll. + eapply sup_elem_of; eauto. + Qed. + +Lemma sup_equiv `{!AntiSymm S' S} l l' : + (∀ a, a ∈ l ↔ a ∈ l') → S' (f (sup l)) (f (sup l')). +Proof. intros; eapply anti_symm; first done; apply sup_mono; naive_solver. Qed. + +Lemma sup_of_nil : sup [] = min. +Proof. done. Qed. + +End find_one_maximal. + +Definition nat_sup (l : list nat) := sup id lt 0 l. + +Lemma nat_sup_UB l a : a ∈ l → a ≤ (nat_sup l). +Proof. apply (sup_UB id); try apply _; auto with lia. Qed. + +Lemma nat_sup_LUB l u : (∀ a, a ∈ l → a ≤ u) → (nat_sup l) ≤ u. +Proof. apply (sup_LUB id); try apply _; simpl; auto with lia. Qed. + +Lemma nat_sup_elem_of a l : a ∈ l → nat_sup l ∈ l. +Proof. + eapply (sup_elem_of id lt le); try apply _; simpl; auto with lia. +Qed. + +Lemma nat_sup_mono l l' : (∀ a, a ∈ l → a ∈ l') → (nat_sup l) ≤ (nat_sup l'). +Proof. + eapply (sup_mono id lt le); try apply _; simpl; auto with lia. +Qed. + +Lemma nat_sup_equiv l l' : (∀ a, a ∈ l ↔ a ∈ l') → (nat_sup l) = (nat_sup l'). +Proof. + intros; eapply (sup_equiv id lt le) with (S' := eq); + try apply _; simpl; auto with lia. +Qed. + +Lemma nat_sup_of_nil : nat_sup [] = 0. +Proof. apply sup_of_nil. Qed. + +Lemma not_inj_fn `{EqDecision A} {B} (x y : A) (f : A → B) `{!Inj (=) (=) f} : + f x ≠ f y → x ≠ y. +Proof. + intros Hf. + destruct (bool_decide (x = y)) eqn:Heq. + - apply bool_decide_eq_true_1 in Heq. simplify_eq. + - by apply bool_decide_eq_false_1 in Heq. +Qed. + +Lemma nth_error_lookup {A} (l : list A) (i : nat) x : + nth_error l i = Some x → l !! i = Some x. +Proof. + revert i. induction l as [|?? IHl]; destruct i; auto. + by apply IHl. +Qed. + +Lemma take_S_r_nth `{A : Type}: + ∀ (l : list A) (n : nat) (x : A), + nth_error l n = Some x → take (n + 1) l = take n l ++ [x]. +Proof. induction l; intros []; naive_solver eauto with f_equal. Qed. + +Lemma map_nth_error_inv { A B}: forall n (l: list A) d (f: A → B), + (∀ x y, f x = f y → x = y) → + nth_error (map f l) n = Some (f d) → nth_error l n = Some d. +Proof. + induction n; intros [|] ??? H; simpl in *; inversion H; eauto using f_equal. +Qed. + +Lemma map_lookup_Some {A B} (f : A → B) (l : list A) (i : nat) (k : B) : + map f l !! i = Some k → + ∃ a, k = f a ∧ l !! i = Some a. +Proof. + revert i. induction l; [done|]. + intros [] Hmap. + - eexists. by inversion Hmap. + - by apply IHl in Hmap. +Qed. + +Lemma list_to_set_size `{EqDecision A, !Countable A} l : + NoDup l → + size (list_to_set l : gset A) = length l. +Proof. + induction l; [done|]. + rewrite NoDup_cons /=; intros [? ?]. + rewrite size_union ?size_singleton ?IHl //. + set_solver. +Qed. + +Lemma rtc_destutter {A} (R : relation A) x1 x2 : + rtc (λ x x', x = x' ∨ R x x') x1 x2 → rtc R x1 x2. +Proof. + apply (rtc_ind_l (λ x, rtc R x x2)). + { constructor. } + intros ? ? [-> | ?] ? ?; [done|]. + by econstructor. +Qed. + +Lemma gt_exists_S_n n m : + n < m → ∃ m', m = S m'. +Proof. destruct n, m; [lia|eauto with lia|lia|eauto with lia]. Qed. + +Lemma rt_rtc_same {A} (R : relation A) `{!Reflexive R, !Transitive R} : ∀ x y, rtc R x y ↔ R x y. +Proof. intros ??; split; last by apply rtc_once. induction 1; first done. etrans; eauto. Qed. + +Global Instance fin_inh n : Inhabited (fin (S n)) := populate 0%fin. + +Lemma difference_difference_union `{Countable T} (A B C : gset T) : + C ⊆ A -> A ∖ (B ∖ C) = A ∖ B ∪ C. +Proof. rewrite sets.set_eq. intros. destruct (decide (x ∈ C)); set_solver. Qed. diff --git a/fairneris/prelude/quorum.v b/fairneris/prelude/quorum.v new file mode 100644 index 0000000..cbc36a5 --- /dev/null +++ b/fairneris/prelude/quorum.v @@ -0,0 +1,37 @@ +Require Import Arith ZArith ZArith ZifyClasses ZifyInst Lia. +From Coq.ssr Require Import ssreflect. +From stdpp Require Import base gmap fin_sets. + +(* For the [lia] tactic to support [Nat.div]. *) +Ltac Zify.zify_post_hook ::= Z.to_euclidean_division_equations. +#[global] Program Instance Op_Nat_div : BinOp Nat.div := + {| TBOp := Z.div ; TBOpInj := Nat2Z.inj_div |}. +Add Zify BinOp Op_Nat_div. + +Record Quorum `{Countable A} (X : gset A) := quorum { + quorum_car :> gset A → Prop; + quorum_subseteq Q : quorum_car Q → Q ⊆ X; + quorum_intersection_nonempty Q1 Q2 : + quorum_car Q1 → quorum_car Q2 → Q1 ∩ Q2 ≠ ∅; +}. +Arguments quorum {_ _ _}. +Arguments quorum_car : simpl never. +Arguments quorum_subseteq {_ _ _ _}. +Arguments quorum_intersection_nonempty {_ _ _ _}. + +Lemma quorum_choose `{Countable A, QuorumX : Quorum X} (Q1 Q2 : gset A) : + QuorumX Q1 → QuorumX Q2 → ∃ a, a ∈ Q1 ∩ Q2. +Proof. + intros ??. by eapply set_choose_L, quorum_intersection_nonempty. +Qed. + +Program Definition Quorum_majority `{Countable A} (X : gset A) : Quorum X := + quorum _ (λ Q, size X / 2 < size Q ∧ Q ⊆ X) _ _. +Next Obligation. by destruct 1. Qed. +Next Obligation. + intros ?????? [? ?] [? ?] ?. + assert (size Q1 + size Q2 ≤ size X). + { rewrite -size_union; [set_solver|]. + by apply subseteq_size, union_subseteq. } + lia. +Qed. diff --git a/fairneris/prelude/strings.v b/fairneris/prelude/strings.v new file mode 100644 index 0000000..743ad66 --- /dev/null +++ b/fairneris/prelude/strings.v @@ -0,0 +1,479 @@ +From Coq Require Import Ascii. +From Coq.ssr Require Import ssreflect. +From stdpp Require Import pretty strings. +From fairneris.prelude Require Import misc. +Coercion Z.of_nat : nat >-> Z. + +Definition StringOfZ (x : Z) := + match x with + | 0%Z => "0" + | Z.pos x0 => pretty (N.pos x0) + | Z.neg x0 => "-" +:+ pretty (N.pos x0) + end. + +Definition ZOfAscii (c : Ascii.ascii) : option N := + match c with + | "0"%char => Some 0%N + | "1"%char => Some 1%N + | "2"%char => Some 2%N + | "3"%char => Some 3%N + | "4"%char => Some 4%N + | "5"%char => Some 5%N + | "6"%char => Some 6%N + | "7"%char => Some 7%N + | "8"%char => Some 8%N + | "9"%char => Some 9%N + | _ => None + end. + +Fixpoint ZOfString' (x : string) (ac : N) : option N := + match x with + | EmptyString => Some ac + | String c x' => + match ZOfAscii c with + None => None + | Some d => (ZOfString' x' ((ac * 10) + d)%N) + end + end. + +Definition ZOfString (x : string) : option Z:= + match x with + | EmptyString => None + | String "-"%char x' => + match (ZOfString' x' 0) with + | Some z => Some (- (Z.of_N z))%Z + | None => None + end + | String _ + _ => + match (ZOfString' x 0) with + | Some z => Some (Z.of_N z) + | None => None + end + end. + +Lemma lt_acc (n : N) : Acc N.lt n. +Proof. + induction n using N.peano_ind; first by constructor; intros; lia. + constructor => m Hlt. + destruct (decide (m < n)%N); first by apply IHn. + by replace m with n by lia. +Qed. + +Lemma ZOfAscii_pretty x : + (x < 10)%N → + ZOfAscii (pretty_N_char x) = Some x. +Proof. + intros Hlt. + inversion Hlt as [Hlt']; cbv in Hlt'. + destruct x as [|p]; first done. + destruct p as [[[[]|[]|]|[[]|[]|]|]|[[[]|[]|]|[[]|[]|]|]|]; try done. +Qed. + +Lemma ZOfString'_app s s' k : + match ZOfString' s k with + | None => ZOfString' (s +:+ s') k = None + | Some m => ZOfString' (s +:+ s') k = ZOfString' s' m + end. +Proof. + revert s' k; induction s. + - induction s'; simpl; first done. + intros k. + destruct a as [[] [] [] [] [] [] [] []]; simpl; auto; + match goal with + |- match ZOfString' s' ?A with _ => _ end => + specialize (IHs' A); + destruct (ZOfString' s' A); trivial + end. + - intros s' k; simpl; fold append. + destruct a as [[] [] [] [] [] [] [] []]; simpl; auto; + match goal with + |- match ZOfString' s ?A with _ => _ end => + specialize (IHs s' A); + destruct (ZOfString' s (k * 10 + 7)); auto + end. +Qed. + +Global Instance append_assoc : Assoc eq append. +Proof. + intros x. + induction x. + - induction y; auto with f_equal. + - intros y z. + rewrite /append -/append IHx. f_equal. +Qed. + +Lemma pretty_N_go_app m s : + (0 < m)%N → pretty_N_go m s = (pretty_N_go m "") +:+ s. +Proof. + intros Hlt. revert s. + induction (lt_acc m) as [? ? IH] => s. + rewrite !(pretty_N_go_step x) //. + destruct (decide (x < 10)%N). + - rewrite N.div_small // pretty_N_go_0 /=. + - assert (x `div` 10 < x)%N as Hltdv. + { apply N.div_lt; auto with lia. } + assert (0 < x `div` 10)%N as Hdvp. + { apply N.div_str_pos; lia. } + pose proof (IH _ Hltdv Hdvp) as IH'. + rewrite (IH' (String (pretty_N_char (x `mod` 10)) "")). + rewrite IH'; simpl. + by rewrite -assoc. +Qed. + +Lemma ZOfString'_inv (n : nat) : + ZOfString' (StringOfZ n) 0 = Some (N.of_nat n). +Proof. + destruct n; first done; simpl. + unfold pretty, pretty_N. + remember (N.pos (Pos.of_succ_nat n)) as m. + replace (S n) with (N.to_nat m); last first. + { by rewrite Heqm positive_N_nat SuccNat2Pos.id_succ. } + assert (Hmlt : (0 < m)%N) by lia. + rewrite decide_False; [|lia]. + clear dependent n. + induction (lt_acc m) as [? ? IH]. + rewrite pretty_N_go_step; last done. + destruct (decide (x < 10)%N). + - rewrite N.mod_small //. + rewrite N.div_small // pretty_N_go_0 /= ZOfAscii_pretty //. f_equiv. lia. + - assert (x `div` 10 < x)%N as Hltdv. + { apply N.div_lt; auto with lia. } + assert (0 < x `div` 10)%N as Hdvp. + { apply N.div_str_pos; lia. } + rewrite pretty_N_go_app //. + pose proof (ZOfString'_app + (pretty_N_go (x `div` 10) "") + (String (pretty_N_char (x `mod` 10)) "") 0) as Hlp. + rewrite (IH _ Hltdv Hdvp) in Hlp. + rewrite Hlp. + rewrite /= ZOfAscii_pretty; last by apply N.mod_lt. + rewrite {3}(N.div_mod' x 10) //. f_equiv. lia. +Qed. + +Lemma pretty_N_go_nnil m s : + (0 < m)%N → pretty_N_go m s ≠ "". +Proof. + intros Hlt. revert s. + induction (lt_acc m) as [? ? IH] => s. + rewrite !(pretty_N_go_step x) //. + destruct (decide (x < 10)%N). + - rewrite N.div_small // pretty_N_go_0 /=. + - assert (x `div` 10 < x)%N as Hltdv. + { apply N.div_lt; auto with lia. } + assert (0 < x `div` 10)%N as Hdvp. + { apply N.div_str_pos; lia. } + apply (IH _ Hltdv Hdvp). +Qed. + +Lemma pretty_N_go_pos_nneg m s s': + (0 < m)%N → pretty_N_go m s ≠ String "-" s'. +Proof. + intros Hlt. revert s. + induction (lt_acc m) as [? ? IH] => s. + rewrite !(pretty_N_go_step x) //. + destruct (decide (x < 10)%N). + - rewrite N.div_small // pretty_N_go_0 /=. + destruct x as [|p]; first done. + destruct p as [[[[]|[]|]|[[]|[]|]|]|[[[]|[]|]|[[]|[]|]|]|]; done. + - assert (x `div` 10 < x)%N as Hltdv. + { apply N.div_lt; auto with lia. } + assert (0 < x `div` 10)%N as Hdvp. + { apply N.div_str_pos; lia. } + apply (IH _ Hltdv Hdvp). +Qed. + +Lemma StringOfZ_nnil m : StringOfZ m ≠ "". +Proof. + unfold StringOfZ; simpl. + destruct m; auto. + apply pretty_N_go_nnil; lia. +Qed. + +Lemma ZOfString_inv (n : Z) : ZOfString (StringOfZ n) = Some n. +Proof. + unfold ZOfString. + destruct (StringOfZ n) eqn:Heq; + first by exfalso; eapply StringOfZ_nnil; eauto. + destruct n as [|p|p] eqn:Heqn. + - destruct a as [[] [] [] [] [] [] [] []]; try done. + rewrite -?Heq //. + - rewrite -?Heq. + pose proof (ZOfString'_inv (Pos.to_nat p)) as HZSi. + rewrite positive_nat_Z in HZSi. + rewrite HZSi nat_N_Z positive_nat_Z. + destruct a as [[] [] [] [] [] [] [] []]; auto. + by rewrite Heq in HZSi. + - simpl in Heq. + assert (0 < 1)%nat as Hneq by lia. + pose proof (append_correct1 "-" (pretty (N.pos p)) 0 Hneq) as Hf; + simpl in Heq. + rewrite Heq in Hf; inversion Hf; subst. + rewrite -(@string_app_inj "-" (pretty (N.pos p)) s Heq). + pose proof (ZOfString'_inv (Pos.to_nat p)) as HZSi. + rewrite positive_nat_Z in HZSi. + by rewrite HZSi nat_N_Z positive_nat_Z. +Qed. + +Lemma append_nil_l s : + "" +:+ s = s. +Proof. done. Qed. + +Lemma append_cons s1 : + ∀ s2 a, String a (s1 +:+ s2) = (String a s1) +:+ s2. +Proof. + induction s1; intros. + - by rewrite append_nil_l. + - rewrite -IHs1. done. +Qed. + +Lemma length_Sn a s : + String.length (String a s) = S (String.length s). +Proof. by cbn. Qed. + +Lemma length_app s1 : + ∀ s2, String.length (s1 +:+ s2) = (String.length s1 + String.length s2)%nat. +Proof. + induction s1; intros. + - by rewrite append_nil_l. + - by rewrite -append_cons !length_Sn IHs1. +Qed. + +Lemma prefix_empty_true s : + String.prefix "" s = true. +Proof. destruct s; cbn; auto. Qed. + +Lemma index_0_empty s : + index 0 "" s = Some 0%nat. +Proof. destruct s; by cbn. Qed. + +Lemma index_prefix_true s s' : + index 0 s s' = Some 0%nat → + String.prefix s s' = true. +Proof. + destruct s,s'; simpl; cbn; auto. + - intro; inversion H. + - intro; destruct ascii_dec. + + destruct (String.prefix s s'); auto; destruct (index 0 _ s'); inversion H. + + destruct (index 0 _ s'); inversion H. +Qed. + +Lemma index_cons_0_eq a s s' : + index 0 s s' = Some 0%nat → index 0 (String a s) (String a s') = Some 0%nat. +Proof. + intros Hindex. + cbn. destruct ascii_dec. + - assert (Hprefix: String.prefix s s' = true). + { by apply index_prefix_true. } + by rewrite Hprefix. + - by destruct n. +Qed. + +Lemma index_append_here s t : + index 0 s (s +:+ t) = Some 0%nat. +Proof. + induction s. + - apply index_0_empty. + - apply index_cons_0_eq. + apply IHs. +Qed. + +Lemma index_0_append_char a t v s : + s = String a "" → + index 0 s t = None → + index 0 s (t +:+ s +:+ v) = Some (String.length t). +Proof. + induction t; intros. + - rewrite append_nil_l. apply index_append_here. + - rewrite H. rewrite -append_cons. cbn. + destruct ascii_dec; subst. cbn in H0. destruct ascii_dec. + rewrite prefix_empty_true in H0. inversion H0. + by destruct n. + rewrite IHt; auto. cbn in H0. destruct ascii_dec. by destruct n. + destruct index; auto. inversion H0. +Qed. + +Lemma substring_0_length s : + substring 0 (String.length s) s = s. +Proof. induction s; simpl; auto. by rewrite IHs. Qed. + +Lemma substring_Sn a n m s : + substring (S n) m (String a s) = substring n m s. +Proof. induction s; destruct n,m; simpl; auto. Qed. + +Lemma substring_add_length_app n m s1 : + ∀ s2, substring (String.length s1 + n) m (s1 +:+ s2) = substring n m s2. +Proof. induction s1; destruct n,m; simpl; auto. Qed. + +Lemma substring_0_length_append s1 s2 : + substring 0 (String.length s1) (s1 +:+ s2) = s1. +Proof. apply prefix_correct, index_prefix_true, index_append_here. Qed. + +Lemma substring_length_append s1 : + ∀ s2, substring (String.length s1) (String.length s2) (s1 +:+ s2) = s2. +Proof. + induction s1; intros s2. + - rewrite append_nil_l. apply substring_0_length. + - rewrite length_Sn substring_Sn. apply IHs1. +Qed. + +Definition not_number (c : ascii) := + (c ≠ "0" ∧ c ≠ "1" ∧ c ≠ "2" ∧ c ≠ "3" ∧ c ≠ "4" ∧ + c ≠ "5" ∧ c ≠ "6" ∧ c ≠ "7" ∧ c ≠ "8" ∧ c ≠ "9")%char. + +Lemma get_n_pretty_N_go_ne n N s (c : ascii) : + not_number c → + (∀ m, get m s ≠ Some c) → get n (pretty_N_go N s) ≠ Some c. +Proof. + intros (?&?&?&?&?&?&?&?&?&?). revert s. + induction (N.lt_wf_0 N) as [x _ IH]. intros s Hs. + assert (x = 0 ∨ 0 < x < 10 ∨ 10 ≤ x)%N as [->|[[??]|?]] by lia. + - rewrite pretty_N_go_0. done. + - rewrite pretty_N_go_step; [|done]. + apply IH. + { by apply N.div_lt. } + assert (x = 1 ∨ x = 2 ∨ x = 3 ∨ x = 4 ∨ x = 5 ∨ x = 6 + ∨ x = 7 ∨ x = 8 ∨ x = 9)%N as Hx by lia. + destruct_or! Hx; simplify_eq; intros []; + simpl; (done || by intros [=]). + - rewrite pretty_N_go_step; [|lia]. + apply IH. + { apply N.div_lt; lia. } + intros []; [|by simpl]. + unfold pretty_N_char; + repeat (discriminate || case_match); simpl; + by intros [=]. +Qed. + +Lemma get_StringOfZ_ne z n c : + not_number c ∧ c ≠ "-"%char → get n (StringOfZ z) ≠ Some c. +Proof. + intros [Hc Hdash]. + destruct z. + - destruct n; intros [=]. by destruct_and! Hc. + - simpl. unfold pretty, pretty_N. + destruct decide; [done|]. by eapply get_n_pretty_N_go_ne. + - destruct n; simpl; [congruence|]. by eapply get_n_pretty_N_go_ne. +Qed. + +Lemma append_length_gt (n : nat) s1 s2 : + String.length s1 < n → get n (s1 +:+ s2) = get (n - String.length s1) s2. +Proof. + revert s2 n; induction s1; intros s2 n Hgt. + - rewrite append_nil_l Nat.sub_0_r //. + - destruct (gt_exists_S_n _ _ Hgt) as [m ->]. + rewrite -append_cons. + simpl in *. apply IHs1. lia. +Qed. + +Lemma get_n_append_ne s1 s2 c n : + (∀ m, get m s1 ≠ Some c) → + (∀ m, get m s2 ≠ Some c) → + get n (s1 +:+ s2) ≠ Some c. +Proof. + destruct (decide (n < String.length s1)). + { rewrite -append_correct1 //. } + destruct (decide (n = String.length s1)) as [-> |]. + { rewrite -(append_correct2 _ _ 0). auto. } + rewrite append_length_gt //. lia. +Qed. + +Lemma get_head_ne_succ a a' n s : + a ≠ a' → get n (String a s) = Some a' → + ∃ n', n = S n' ∧ get (S n') (String a s) = Some a'. +Proof. intros Hneq Hget. destruct n; [by inversion Hget|by exists n]. Qed. + +Lemma string_length_zero s : String.length s = 0 → s = "". +Proof. by destruct s. Qed. + +Lemma append_eq_length_inv (s1 s2 s1' s2' : string) : + String.length s1 = String.length s2 → + s1 +:+ s1' = s2 +:+ s2' → s1 = s2 ∧ s1' = s2'. +Proof. + revert s2; induction s1; simpl. + - destruct s2; [done|]. intros [=]. + - destruct s2; simpl; [intros [=]|]. + rewrite -!append_cons. + intros [=] [=]. simplify_eq. + split; [f_equal|]; by eapply IHs1. +Qed. + +Lemma char_splits_l s1 s2 s1' s2' (c : ascii) : + (∀ n, get n s2 ≠ Some c) → + (∀ n, get n s2' ≠ Some c) → + s1 +:+ (String c "") +:+ s1' = s2 +:+ (String c "") +:+ s2' → + s1 = s2 ∧ s1' = s2'. +Proof. + intros Hs2 Hs2' Heq. + apply append_eq_length_inv in Heq as [? [=]]; [done|]. + pose proof ((proj2 (get_correct _ _) Heq (String.length s1))) as Hget. + rewrite -(append_correct2 _ _ 0) /= in Hget. + edestruct Nat.lt_trichotomy as [Hlt | [Heq' | Hgt]]; [ |exact Heq'|]. + - rewrite -(append_correct1) //= in Hget. + symmetry in Hget. by apply Hs2 in Hget. + - rewrite (append_length_gt _ s2) // in Hget. + destruct (gt_exists_S_n _ _ Hgt) as [n Hn]. + rewrite Hn in Hget. + rewrite Nat.sub_succ_l in Hget; [|lia]. + simpl in Hget. symmetry in Hget. + by apply Hs2' in Hget. +Qed. + +Inductive elem_of_string : ElemOf ascii string := +| elem_of_string_here (x : ascii) s : elem_of x (String x s) +| elem_of_string_further (x y : ascii) s : elem_of x s → elem_of x (String y s). +Local Existing Instance elem_of_string. + +Lemma elem_of_string_cons (a1 a2 : ascii) (s : string) : + a1 ∈ String a2 s ↔ a1 = a2 ∨ a1 ∈ s. +Proof. by split; [inversion 1; subst|intros [->|?]]; constructor. Qed. +Lemma not_elem_of_string_cons (s : string) (x y : ascii) : + x ∉ String y s ↔ x ≠ y ∧ x ∉ s. +Proof. rewrite elem_of_string_cons. tauto. Qed. + +(** This lemma is ported from the stdpp library on lists. + It is very similar to [char_splits_l], although it asserts properties + about the prefix, rather than suffix. + The suffix variant has not been ported, as it relies on list reverse, + which has no analog for strings. *) +Lemma not_elem_of_string_app_cons_inv_l (a1 a2 : ascii) (l1 l2 k1 k2 : string) : + a1 ∉ k1 → a2 ∉ l1 → + l1 +:+ String a1 l2 = k1 +:+ String a2 k2 → + l1 = k1 ∧ a1 = a2 ∧ l2 = k2. +Proof. + revert k1. + induction l1 as [|x' l1 IH]; intros [|y' k1] Hx Hy ?; simplify_eq/=; + try apply not_elem_of_string_cons in Hx as [??]; + try apply not_elem_of_string_cons in Hy as [??]; naive_solver. +Qed. +Lemma get_string_elem_of a s : (∃ n, get n s = Some a) ↔ a ∈ s. +Proof. + split. + - intros [n Hget]. + generalize dependent n. + induction s as [|a' s IHs]; [done|]. + intros n Hget. + destruct (decide (a=a')) as [<-|]; [apply elem_of_string_here|]. + apply elem_of_string_further. + apply get_head_ne_succ in Hget; [|done]. + destruct Hget as (n'&->&Hget). + by eapply IHs. + - intros Hin. + induction s as [|a' s IHs]; [by inversion Hin|]. + apply elem_of_string_cons in Hin. + destruct Hin as [<-|Hin]; [by exists 0|]. + apply IHs in Hin. destruct Hin as [m Hget]. + by exists (S m). +Qed. + +(** This is very domain specific. Can maybe be generalised to derive the + possible values of [a] *) +Lemma StringOfZ_not_sep a n : + a ∈ StringOfZ n → a ≠ "_"%char. +Proof. + intros Hin ->. + rewrite -get_string_elem_of in Hin. + destruct Hin as [n' Hin]. + assert (not_number "_"%char ∧ "_"%char ≠ "-"%char) as Hnan by done. + by eapply get_StringOfZ_ne in Hnan. +Qed. diff --git a/fairneris/prelude/time.v b/fairneris/prelude/time.v new file mode 100644 index 0000000..7c73a45 --- /dev/null +++ b/fairneris/prelude/time.v @@ -0,0 +1,315 @@ +(** Realisation of the time using vector clocs. *) + +From fairneris.aneris_lang Require Import lang. +From fairneris.prelude Require Import misc strings. +From stdpp Require Import list sets. + +Definition vector_clock := list nat. + +(** Alternatively the specs in vector_clock.v can use + the following instead of the is_vc predicate. *) +Fixpoint vector_clock_to_val (t : vector_clock) : val := + match t with + | [] => NONEV + | a :: t' => SOMEV (#a, vector_clock_to_val t') + end. + +#[global] Program Instance Inj_vector_clock : Inj eq eq vector_clock_to_val. +Next Obligation. + intros x; induction x as [ | h x' IH]; intros y Heq; + destruct y; [done | done | done |]. + inversion Heq as [[Hh Ht]]. + apply f_equal2; [by apply Nat2Z.inj | by apply IH]. +Qed. + +Definition vector_clock_le (t t' : vector_clock) := Forall2 le t t'. + +Definition vector_clock_lt (t t' : vector_clock) := + vector_clock_le t t' ∧ Exists (λ x, x.1 < x.2) (zip t t'). + +#[global] Instance vector_clock_le_dec : RelDecision vector_clock_le. +Proof. apply Forall2_dec; apply _. Qed. + +#[global] Instance vector_clock_lt_dec : RelDecision vector_clock_lt. +Proof. intros ? ?; apply and_dec; apply _. Qed. + +#[global] Instance vector_clock_le_PO : PartialOrder vector_clock_le. +Proof. + split; first split. + - intros ?; rewrite /vector_clock_le /=; reflexivity. + - intros ???; rewrite /vector_clock_le /=; etrans; eauto. + - intros ? ?; rewrite /vector_clock_le /=. + revert y; induction x as [|a x]. + + by inversion 1; simplify_eq. + + intros [|b y]; first by inversion 1. + do 2 inversion 1; simplify_eq. + auto with f_equal lia. +Qed. + +Lemma vector_clock_lt_irreflexive x : ¬ vector_clock_lt x x. +Proof. + intros [? (?&(?&?&?&?&?&?)%elem_of_lookup_zip_with_1&?)%Exists_exists]; + simplify_eq/=; lia. +Qed. + +#[global] Instance vector_clock_lt_transitive : Transitive vector_clock_lt. +Proof. + intros x y z + [Hxy1 (?&(i&xi&yi&?&Hi1&Hi2)%elem_of_lookup_zip_with_1&?)%Exists_exists] + [Hyz1 Hyz2]; + simplify_eq/=. + split; first etrans; eauto. + apply Exists_exists. + destruct (Forall2_lookup_l _ _ _ _ _ Hyz1 Hi2) as (zi&?&?). + exists (xi, zi); split; last by simpl; lia. + apply elem_of_lookup_zip_with; eauto 10. +Qed. + +Lemma vector_clock_lt_le t t' : vector_clock_lt t t' → vector_clock_le t t'. +Proof. by intros [? ?]. Qed. + +Lemma vector_clock_lt_exclusion t t' : + vector_clock_lt t t' → vector_clock_lt t' t → False. +Proof. + intros [Htt'1 (?&(i&xi&yi&?&Hi1&Hi2)%elem_of_lookup_zip_with_1&?)%Exists_exists] + [Ht't1 Ht't2]; simplify_eq/=. + pose proof (Forall2_lookup_lr _ _ _ _ _ _ Ht't1 Hi2 Hi1); lia. +Qed. + +Lemma vector_clock_le_eq_or_lt t t' : + vector_clock_le t t' → t = t' ∨ vector_clock_lt t t'. +Proof. + intros Hlt. + destruct (decide (t = t')) as [|Hneq]; first by left. + right. + split; first done. + revert t' Hlt Hneq. + induction t as [|a t IHt]. + - by inversion 1. + - intros [|b t']; inversion 1; simplify_eq/=. + intros. + destruct (decide (a = b)); last by constructor 1; simpl; lia. + subst. + constructor 2; apply IHt; auto with f_equal. +Qed. + +Lemma vector_clock_le_lt_trans t t' t'' : + vector_clock_le t t' → vector_clock_lt t' t'' → + vector_clock_lt t t''. +Proof. + intros Hle [? Hlt]; split; first by etrans; eauto. + apply Exists_exists in Hlt as + (?&(i&xi&yi&?&Hi1&Hi2)%elem_of_lookup_zip_with_1&?); simplify_eq/=. + destruct (Forall2_lookup_r _ _ _ _ _ Hle Hi1) as (zi&?&?). + apply Exists_exists. + eexists (zi, yi); split; last by simpl; lia. + eapply elem_of_lookup_zip_with; eauto 10. +Qed. + +Lemma vector_clock_lt_le_trans t t' t'' : + vector_clock_lt t t' → vector_clock_le t' t'' → + vector_clock_lt t t''. +Proof. + intros [? Hlt] Hle; split; first by etrans; eauto. + apply Exists_exists in Hlt as + (?&(i&xi&yi&?&Hi1&Hi2)%elem_of_lookup_zip_with_1&?); simplify_eq/=. + destruct (Forall2_lookup_l _ _ _ _ _ Hle Hi2) as (zi&?&?). + apply Exists_exists. + eexists (xi, zi); split; last by simpl; lia. + eapply elem_of_lookup_zip_with; eauto 10. +Qed. + + Definition incr_time (t : vector_clock) (i : nat) := + <[ i := S (default 0 (t !! i)) ]> t. + + Lemma incr_time_length t i : length (incr_time t i) = length t. + Proof. by rewrite /incr_time insert_length. Qed. + + Lemma incr_time_proj t i k : + t !! i = Some k → (incr_time t i) !! i = Some (S k). + Proof. + rewrite /incr_time; intros Heq. + rewrite list_lookup_insert; last by apply lookup_lt_is_Some_1; eauto. + rewrite !Heq; done. + Qed. + + Lemma incr_time_proj_neq t i j : i ≠ j → (incr_time t i) !! j = t !! j. + Proof. apply list_lookup_insert_ne. Qed. + + Lemma incr_time_lt t i : i < length t → vector_clock_lt t (incr_time t i). + Proof. + intros Hit. + destruct (lookup_lt_is_Some_2 t i) as [q Hq]; first done. + split. + - eapply Forall2_lookup; intros j. + destruct (decide (i = j)) as [->|]. + + erewrite Hq, incr_time_proj; last done. + constructor; auto. + + rewrite incr_time_proj_neq; done. + - apply Exists_exists. + exists (q, S q); split; last by auto. + apply elem_of_lookup_zip_with. + eexists i, _, _; split_and!; auto. + erewrite incr_time_proj; eauto. + Qed. + +Section Compute_Maximals. + Context `{!EqDecision T, !Countable T} (f : T → vector_clock). + + #[global] Instance: RelDecision (λ x y, vector_clock_lt (f x) (f y)). + Proof. solve_decision. Qed. + + Definition compute_maximals_as_list (g : gset T) : list T := + let el := elements g in + (filter (λ x : T, (Forall (λ y, ¬ vector_clock_lt (f x) (f y)) el)) el). + + Definition compute_maximals (g : gset T) : gset T := + list_to_set (compute_maximals_as_list g). + + Lemma elem_of_compute_maximals_as_list1 g x : + x ∈ compute_maximals_as_list g → + x ∈ g ∧ ∀ y, y ∈ g → ¬ vector_clock_lt (f x) (f y). + Proof. + intros Ht. + apply elem_of_list_filter in Ht as [Ht1 Ht2%elem_of_elements]. + split; first done. + intros. + eapply Forall_forall in Ht1; eauto. + by apply elem_of_elements. + Qed. + + Lemma elem_of_compute_maximals_as_list2 g x : + x ∈ g → (∀ y, y ∈ g → ¬ vector_clock_lt (f x) (f y)) → + x ∈ compute_maximals_as_list g. + Proof. + intros Ht1 Ht2. + apply elem_of_list_filter; split; last by apply elem_of_elements. + apply Forall_forall; intros ?; rewrite elem_of_elements; auto. + Qed. + + Lemma compute_maximals_as_list_NoDup g : NoDup (compute_maximals_as_list g). + Proof. + apply NoDup_filter, NoDup_elements. + Qed. + + Lemma elem_of_compute_maximals_as_list_union_singleton g z x: + z ∈ compute_maximals_as_list g → + z ∈ compute_maximals_as_list ({[x]} ∪ g) ∨ + (vector_clock_lt (f z) (f x) ∧ x ∈ compute_maximals_as_list ({[x]} ∪ g)). + Proof. + intros [Hz1 Hz2]%elem_of_compute_maximals_as_list1. + destruct (decide (vector_clock_lt (f z) (f x))). + - right; split; first done. + apply elem_of_compute_maximals_as_list2; first set_solver. + intros y [Hy%elem_of_singleton_1|Hy]%elem_of_union; first subst. + + apply vector_clock_lt_irreflexive. + + intros ?; apply (Hz2 y); first done. + etrans; eauto. + - left. + apply elem_of_compute_maximals_as_list2; first set_solver. + intros y [?%elem_of_singleton_1|]%elem_of_union; first subst; auto. + Qed. + + Lemma find_one_maximal_in_maximals x g : + x ∈ g → + find_one_maximal f vector_clock_lt x (elements g) + ∈ compute_maximals_as_list g. + Proof. + intros Hx. + apply elem_of_compute_maximals_as_list2. + - destruct (find_one_maximal_eq_or_elem_of f vector_clock_lt x (elements g)) + as [->|]; first done. + by apply elem_of_elements. + - intros ? ?%elem_of_elements. + apply (find_one_maximal_maximal f vector_clock_lt vector_clock_le); + eauto using vector_clock_le_eq_or_lt, vector_clock_lt_irreflexive, + vector_clock_lt_exclusion, vector_clock_le_lt_trans, vector_clock_lt_le. + Qed. + + Lemma compute_maximals_as_list_correct g x : + x ∈ g → + ∃ y, y ∈ compute_maximals_as_list g ∧ vector_clock_le (f x) (f y). + Proof. + intros Hx. + exists (find_one_maximal f vector_clock_lt x (elements g)); + split. + - by apply find_one_maximal_in_maximals. + - apply (find_one_maximal_rel f vector_clock_lt vector_clock_le); + eauto using vector_clock_lt_le. + Qed. + + Definition compute_maximum (g : gset T) : option T := + match (compute_maximals_as_list g) with + | [] => None + | t :: l => + match l with + | [] => Some t + | _ => None + end + end. + + Definition IsMaximals (g g' : gset T) := + ∀ t : T, t ∈ g' ↔ t ∈ g ∧ ∀ t' : T, t' ∈ g → ¬ vector_clock_lt (f t) (f t'). + + Definition IsMaximum (g : gset T) (mx : T) := + mx ∈ g ∧ ∀ t, t ∈ g → (¬ t = mx) → vector_clock_lt (f t) (f mx). + + Lemma compute_maximals_correct + (g : gset T) : IsMaximals g (compute_maximals g). + Proof. + rewrite /compute_maximals. + intros t; split. + - intros Ht%elem_of_list_to_set. + by apply elem_of_compute_maximals_as_list1. + - intros [Ht1 Ht2]. + apply elem_of_list_to_set. + by apply elem_of_compute_maximals_as_list2. + Qed. + + Lemma compute_maximum_correct (g : gset T) : + (∀ x y, x ∈ g → y ∈ g → f x = f y → x = y) → + (∀ x, compute_maximum g = Some x ↔ IsMaximum g x). + Proof. + intros Hginj. + rewrite /compute_maximum. + intros x; split; intros Hx. + - destruct (compute_maximals_as_list g) as [|z []] eqn:Heql; simplify_eq/=. + assert (∀ y, y ∈ compute_maximals_as_list g ↔ y = x) as Hx. + { rewrite Heql; set_solver. } + split. + + by apply elem_of_compute_maximals_as_list1; apply Hx. + + intros t Ht Htx. + pose proof (compute_maximals_as_list_correct _ _ Ht) as (y & Hy1 & Hy2). + apply Hx in Hy1; subst. + apply vector_clock_le_eq_or_lt in Hy2 as [Hy2|Hy2]; last done. + contradict Htx; apply Hginj; auto. + by apply elem_of_compute_maximals_as_list1, Hx. + - destruct (compute_maximals_as_list g) as [|z []] eqn:Heql. + + destruct Hx as [Hx1 Hx2]. + apply compute_maximals_as_list_correct in Hx1 as (y & Hy1 & Hy2). + rewrite Heql in Hy1; eapply elem_of_nil in Hy1; done. + + destruct Hx as [Hx1 Hx2]. + destruct (decide (z = x)) as [->|Hneq]; first done. + pose proof (elem_of_compute_maximals_as_list1 g z) as [Hz1 Hz2]. + { rewrite Heql; constructor. } + specialize (Hz2 x Hx1). + specialize (Hx2 _ Hz1 Hneq); done. + + destruct Hx as [Hx1 Hx2]. + assert (z ≠ x ∨ t ≠ x) as [Hzx|Htx]. + { destruct (decide (z = x)); last by eauto. + destruct (decide (t = x)); last by eauto. + pose proof (compute_maximals_as_list_NoDup g) as Hnd. + rewrite Heql in Hnd. + apply NoDup_cons in Hnd as [[Hneq1 Hnin1]%not_elem_of_cons Hnd]. + simplify_eq. } + * assert (z ∈ compute_maximals_as_list g) as Hzmg. + { rewrite Heql; repeat constructor. } + pose proof (elem_of_compute_maximals_as_list1 g z Hzmg) as [Hzg Hz]. + exfalso; by eapply Hz; last apply Hx2. + * assert (t ∈ compute_maximals_as_list g) as Htmg. + { rewrite Heql; repeat constructor. } + pose proof (elem_of_compute_maximals_as_list1 g t Htmg) as [Htg Ht]. + exfalso; by eapply Ht; last apply Hx2. + Qed. + +End Compute_Maximals. diff --git a/fairneris/testbed.v b/fairneris/testbed.v new file mode 100644 index 0000000..7100a89 --- /dev/null +++ b/fairneris/testbed.v @@ -0,0 +1,73 @@ +From stdpp Require Import option countable. +From fairneris Require Export inftraces trace_utils fairness. + +Record Lts lab : Type := { + lts_state :> Type; + lts_state_eqdec :: EqDecision lts_state; + lts_state_inhabited :: Inhabited lts_state; + + lts_lab_eqdec :: EqDecision lab; + lts_lab_countable : Countable lab; + lts_lab_inhabited :: Inhabited lab; + + lts_trans: lts_state → lab → lts_state → Prop; +}. + +Arguments lts_state {_}. +Arguments lts_trans {_}. + +Record EnvModel (Λ : language) := { + env_lts :> Lts (action Λ + config_label Λ); + env_states_match : cfg Λ → env_lts.(lts_state) → Prop; + env_apply_trans : env_lts.(lts_state) → config_label Λ → env_lts.(lts_state); + env_apply_trans_spec : ∀ c1 m1 cl c2 m2, + env_apply_trans m1 cl = m2 → + locale_step c1 (inr cl) c2 → + env_states_match c1 m1 → + env_states_match c2 m2; +}. + +Arguments env_lts {_}. + +Record UserModel (Λ : language) := { + usr_role : Type; + usr_lts :> Lts (usr_role * option (action Λ)); + + usr_eqdec: EqDecision usr_role; + usr_countable: Countable usr_role; + usr_inhabited: Inhabited usr_role; + usr_live_roles: usr_lts.(lts_state) → gset usr_role; + usr_live_spec: ∀ s ρ α s', usr_lts.(lts_trans) s (ρ,α) s' → ρ ∈ usr_live_roles s; +}. + +Arguments usr_role {_}. +Arguments usr_lts {_}. +Arguments usr_live_roles {_ _}. + +Inductive joint_trans {Λ: language} {M: UserModel Λ} {N: EnvModel Λ} : + (M * N) → ((usr_role M * option (action Λ)) + config_label Λ) → (M * N) → Prop := +| UsrTrans n u1 u2 ρ : lts_trans M u1 (ρ, None) u2 → joint_trans (u1, n) (inl (ρ, None)) (u2, n) +| NetTrans u n1 n2 ℓ : lts_trans N n1 (inr ℓ) n2 → joint_trans (u, n2) (inr ℓ) (u, n2) +| SyncTrans u1 u2 n1 n2 ρ α : + lts_trans M u1 (ρ, Some α) u2 → lts_trans N n1 (inl α) n2 → + joint_trans (u1, n2) (inl (ρ, Some α)) (u2, n2) +. + +Program Definition joint_model {Λ: language} (M: UserModel Λ) (N: EnvModel Λ) : FairModel := +{| + fmstate := lts_state (usr_lts M) * lts_state N; + (* Why doesn't this work??? *) + fmrole := usr_role M; + fmaction := option (action Λ); + fmconfig := config_label Λ; + fmtrans s1 ℓ s2 := joint_trans s1 ℓ s2; + live_roles s := usr_live_roles s.1; + + fmrole_eqdec := usr_eqdec _ M; + fmrole_countable := usr_countable _ M; + fmrole_inhabited := usr_inhabited _ M; + + (* let's see what to do later... *) + fmfairness _ := True; +|}. +Next Obligation. by intros ???????; inversion 1; simplify_eq; eapply usr_live_spec. Qed. diff --git a/fairneris/trace_utils.v b/fairneris/trace_utils.v new file mode 100644 index 0000000..6778192 --- /dev/null +++ b/fairneris/trace_utils.v @@ -0,0 +1,275 @@ +From stdpp Require Import option. +From Paco Require Import paco1 paco2 pacotac. +From fairneris Require Export inftraces. + +Definition trace_implies {S L} (P Q : S → option L → Prop) (tr : trace S L) : Prop := + ∀ n, pred_at tr n P → ∃ m, pred_at tr (n+m) Q. + +Lemma trace_implies_after {S L : Type} (P Q : S → option L → Prop) tr tr' k : + after k tr = Some tr' → + trace_implies P Q tr → trace_implies P Q tr'. +Proof. + intros Haf Hf n Hp. + have Hh:= Hf (k+n). + have Hp': pred_at tr (k + n) P. + { rewrite (pred_at_sum _ k) Haf /= //. } + have [m Hm] := Hh Hp'. exists m. + by rewrite <- Nat.add_assoc, !(pred_at_sum _ k), Haf in Hm. +Qed. + +Lemma trace_implies_cons {S L : Type} (P Q : S → option L → Prop) s l tr : + trace_implies P Q (s -[l]-> tr) → trace_implies P Q tr. +Proof. intros H. by eapply (trace_implies_after _ _ (s -[l]-> tr) tr 1). Qed. + +Lemma pred_at_or {S L : Type} (P1 P2 : S → option L → Prop) tr n : + pred_at tr n (λ s l, P1 s l ∨ P2 s l) ↔ + pred_at tr n P1 ∨ + pred_at tr n P2. +Proof. + split. + - revert tr. + induction n as [|n IHn]; intros tr Htr. + + destruct tr; [done|]. + rewrite !pred_at_0. rewrite !pred_at_0 in Htr. + destruct Htr as [Htr | Htr]; [by left|by right]. + + destruct tr; [done|by apply IHn]. + - revert tr. + induction n as [|n IHn]; intros tr Htr. + + destruct tr; [done|]. + rewrite !pred_at_0 in Htr. rewrite !pred_at_0. + destruct Htr as [Htr | Htr]; [by left|by right]. + + by destruct tr; [by destruct Htr as [Htr|Htr]|apply IHn]. +Qed. + +Lemma traces_match_flip {S1 S2 L1 L2} + (Rℓ: L1 -> L2 -> Prop) (Rs: S1 -> S2 -> Prop) + (trans1: S1 -> L1 -> S1 -> Prop) + (trans2: S2 -> L2 -> S2 -> Prop) + tr1 tr2 : + traces_match Rℓ Rs trans1 trans2 tr1 tr2 ↔ + traces_match (flip Rℓ) (flip Rs) trans2 trans1 tr2 tr1. +Proof. + split. + - revert tr1 tr2. cofix CH. + intros tr1 tr2 Hmatch. inversion Hmatch; simplify_eq. + { by constructor. } + constructor; [done..|]. + by apply CH. + - revert tr1 tr2. cofix CH. + intros tr1 tr2 Hmatch. inversion Hmatch; simplify_eq. + { by constructor. } + constructor; [done..|]. + by apply CH. +Qed. + +Lemma traces_match_traces_implies {S1 S2 L1 L2} + (Rℓ: L1 -> L2 -> Prop) (Rs: S1 -> S2 -> Prop) + (trans1: S1 -> L1 -> S1 -> Prop) + (trans2: S2 -> L2 -> S2 -> Prop) + (P1 Q1 : S1 → option L1 → Prop) + (P2 Q2 : S2 → option L2 → Prop) + tr1 tr2 : + traces_match Rℓ Rs trans1 trans2 tr1 tr2 → + (∀ s1 s2 oℓ1 oℓ2, Rs s1 s2 → + match oℓ1, oℓ2 with + | Some ℓ1, Some ℓ2 => Rℓ ℓ1 ℓ2 + | None, None => True + | _, _ => False + end → + P2 s2 oℓ2 → P1 s1 oℓ1) → + (∀ s1 s2 oℓ1 oℓ2, Rs s1 s2 → + match oℓ1, oℓ2 with + | Some ℓ1, Some ℓ2 => Rℓ ℓ1 ℓ2 + | None, None => True + | _, _ => False + end → Q1 s1 oℓ1 → Q2 s2 oℓ2) → + trace_implies P1 Q1 tr1 → trace_implies P2 Q2 tr2. +Proof. + intros Hmatch HP HQ Htr1. + intros n Hpred_at. + rewrite /pred_at in Hpred_at. + assert (traces_match (flip Rℓ) + (flip Rs) + trans2 trans1 + tr2 tr1) as Hmatch'. + { by rewrite -traces_match_flip. } + destruct (after n tr2) as [tr2'|] eqn:Htr2eq; [|done]. + eapply (traces_match_after) in Hmatch as (tr1' & Htr1eq & Hmatch); [|done]. + specialize (Htr1 n). + rewrite {1}/pred_at in Htr1. + rewrite Htr1eq in Htr1. + destruct tr1' as [|s ℓ tr']; inversion Hmatch; simplify_eq; try by done. + - assert (P1 s None) as HP1 by by eapply (HP _ _ _ None). + destruct (Htr1 HP1) as [m Htr1']. + exists m. rewrite pred_at_sum. rewrite pred_at_sum in Htr1'. + destruct (after n tr1) as [tr1'|] eqn:Htr1eq'; [|done]. + eapply (traces_match_after) in Hmatch' as (tr2' & Htr2eq' & Hmatch'); [|done]. + rewrite Htr2eq'. + rewrite /pred_at. + rewrite /pred_at in Htr1'. + destruct (after m tr1') as [tr1''|] eqn:Htr1eq''; [|done]. + eapply (traces_match_after) in Hmatch' as (tr2'' & Htr2eq'' & Hmatch''); [|done]. + rewrite Htr2eq''. + destruct tr1''; inversion Hmatch''; simplify_eq; try by done. + + by eapply (HQ _ _ None None). + + by (eapply (HQ _ _ (Some _) _)). + - assert (P1 s (Some ℓ)) as HP1 by by (eapply (HP _ _ _ (Some _))). + destruct (Htr1 HP1) as [m Htr1']. + exists m. rewrite pred_at_sum. rewrite pred_at_sum in Htr1'. + destruct (after n tr1) as [tr1'|] eqn:Htr1eq'; [|done]. + eapply (traces_match_after) in Hmatch' as (tr2' & Htr2eq' & Hmatch'); [|done]. + rewrite Htr2eq'. + rewrite /pred_at. + rewrite /pred_at in Htr1'. + destruct (after m tr1') as [tr1''|] eqn:Htr1eq''; [|done]. + eapply (traces_match_after) in Hmatch' as (tr2'' & Htr2eq'' & Hmatch''); [|done]. + rewrite Htr2eq''. + destruct tr1''; inversion Hmatch''; simplify_eq; try by done. + + by eapply (HQ _ _ None None). + + by (eapply (HQ _ _ (Some _) _)). +Qed. + +Lemma traces_match_after_None {S1 S2 L1 L2} + (Rℓ: L1 -> L2 -> Prop) (Rs: S1 -> S2 -> Prop) + (trans1: S1 -> L1 -> S1 -> Prop) + (trans2: S2 -> L2 -> S2 -> Prop) + tr1 tr2 n : + traces_match Rℓ Rs trans1 trans2 tr1 tr2 -> + after n tr2 = None -> + after n tr1 = None. +Proof. + revert tr1 tr2. + induction n; intros tr1 tr2; [done|]. + move=> /= Hm Ha. + destruct tr1; first by inversion Hm. + inversion Hm; simplify_eq. by eapply IHn. +Qed. + +Fixpoint trace_take {S L} (n : nat) (tr : trace S L) : finite_trace S L := + match tr with + | ⟨s⟩ => {tr[s]} + | s -[ℓ]-> r => match n with + | 0 => {tr[s]} + | S n => (trace_take n r) :tr[ℓ]: s + end + end. + +Fixpoint trace_filter {S L} (f : S → L → Prop) + `{∀ s l, Decision (f s l)} + (tr : finite_trace S L) : finite_trace S L := + match tr with + | {tr[s]} => {tr[s]} + | tr :tr[ℓ]: s => if (bool_decide (f s ℓ)) + then trace_filter f tr :tr[ℓ]: s + else trace_filter f tr + end. + +Fixpoint count_labels {S L} (ft : finite_trace S L) : nat := + match ft with + | {tr[_]} => 0 + | ft' :tr[_]: _ => Datatypes.S (count_labels ft') + end. + +Lemma count_labels_sum {S L} (P : S → L → Prop) + `{∀ s l, Decision (P s l)} n m mtr mtr' : + after n mtr = Some mtr' → + count_labels (trace_filter P $ trace_take (n+m) mtr) = + count_labels ((trace_filter P $ trace_take n mtr)) + + count_labels ((trace_filter P $ trace_take m mtr')). +Proof. + revert mtr mtr'. + induction n=> /=; intros mtr mtr' Hafter. + { simplify_eq. by destruct mtr'. } + destruct mtr; [done|]. simpl. + case_bool_decide. + - simpl. f_equiv. by apply IHn. + - by apply IHn. +Qed. + +Lemma pred_at_impl {S L} (tr:trace S L) n (P Q : S → option L → Prop) : + (∀ s l, P s l → Q s l) → pred_at tr n P → pred_at tr n Q. +Proof. + rewrite /pred_at. intros HPQ HP. + destruct (after n tr); [|done]. + by destruct t; apply HPQ. +Qed. + +Lemma pred_at_neg {S L} (tr:trace S L) n (P : S → option L → Prop) : + is_Some (after n tr) → + ¬ pred_at tr n P ↔ pred_at tr n (λ s l, ¬ P s l). +Proof. + rewrite /pred_at. intros Hafter. split. + - intros HP. + destruct (after n tr). + + by destruct t. + + by apply is_Some_None in Hafter. + - intros HP. + destruct (after n tr). + + by destruct t. + + by apply is_Some_None in Hafter. +Qed. + +Lemma infinite_trace_after' {S T} n (tr : trace S T) : + infinite_trace tr -> ∃ tr', after n tr = Some tr' ∧ infinite_trace tr'. +Proof. + revert tr. + induction n; intros tr Hinf. + { exists tr. done. } + pose proof (IHn _ Hinf) as [tr' [Hafter Hinf']]. + pose proof (Hinf' 1) as [tr'' Htr']. + exists tr''. + replace (Datatypes.S n) with (n + 1) by lia. + rewrite after_sum'. rewrite Hafter. split; [done|]. + intros n'. + specialize (Hinf' (Datatypes.S n')). + destruct tr'; [done|]. + simpl in *. simplify_eq. done. +Qed. + +Fixpoint finite_trace_to_trace {S L} (tr : finite_trace S L) : trace S L := + match tr with + | {tr[s]} => ⟨s⟩ + | tr :tr[ℓ]: s => s -[ℓ]-> (finite_trace_to_trace tr) + end. + +Definition trace_now {S T} (tr : trace S T) P := pred_at tr 0 P. +Definition trace_always {S T} (tr : trace S T) P := ∀ n, pred_at tr n P. +Definition trace_eventually {S T} (tr : trace S T) P := ∃ n, pred_at tr n P. +Definition trace_until {S T} (tr : trace S T) P Q := + ∃ n, pred_at tr n Q ∧ ∀ m, m < n → pred_at tr m P. + +Lemma pred_at_after_is_Some {S T} (tr : trace S T) n P : + pred_at tr n P → is_Some $ after n tr. +Proof. rewrite /pred_at. by case_match. Qed. + +Lemma after_is_Some_le {S T} (tr : trace S T) n m : + m ≤ n → is_Some $ after n tr → is_Some $ after m tr. +Proof. + revert tr m. + induction n; intros tr m Hle. + { intros. assert (m = 0) as -> by lia. done. } + intros. + destruct m; [done|]. + simpl in *. + destruct tr; [done|]. + apply IHn. lia. done. +Qed. + +Lemma trace_eventually_until {S T} (tr : trace S T) P : + trace_eventually tr P → trace_until tr (λ s l, ¬ P s l) P. +Proof. + intros [n Hn]. + induction n as [n IHn] using lt_wf_ind. + assert ((∀ m, m < n → pred_at tr m (λ s l, ¬ P s l)) ∨ + ¬ (∀ m, m < n → pred_at tr m (λ s l, ¬ P s l))) as [HP|HP]; + [|by eexists _|]. + { apply ExcludedMiddle. } + eapply not_forall_exists_not in HP as [n' HP]. + apply Classical_Prop.imply_to_and in HP as [Hlt HP]. + apply pred_at_neg in HP; last first. + { eapply after_is_Some_le; [|by eapply pred_at_after_is_Some]. lia. } + eapply pred_at_impl in HP; last first. + { intros s l H. apply NNP_P. apply H. } + specialize (IHn n' Hlt HP) as [n'' [H' H'']]. + exists n''. done. +Qed. diff --git a/flake.lock b/flake.lock index f6ca995..1e880b2 100644 --- a/flake.lock +++ b/flake.lock @@ -5,11 +5,11 @@ "systems": "systems" }, "locked": { - "lastModified": 1692799911, - "narHash": "sha256-3eihraek4qL744EvQXsK1Ha6C3CR7nnT8X2qWap4RNk=", + "lastModified": 1710146030, + "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", "owner": "numtide", "repo": "flake-utils", - "rev": "f9e7cf818399d17d347f847525c5a5a8032e4e44", + "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", "type": "github" }, "original": { @@ -20,11 +20,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1693158576, - "narHash": "sha256-aRTTXkYvhXosGx535iAFUaoFboUrZSYb1Ooih/auGp0=", + "lastModified": 1710806803, + "narHash": "sha256-qrxvLS888pNJFwJdK+hf1wpRCSQcqA6W5+Ox202NDa0=", "owner": "nixos", "repo": "nixpkgs", - "rev": "a999c1cc0c9eb2095729d5aa03e0d8f7ed256780", + "rev": "b06025f1533a1e07b6db3e75151caa155d1c7eb3", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 6c235b3..98709ab 100644 --- a/flake.nix +++ b/flake.nix @@ -18,10 +18,10 @@ with pkgs; { devShell = mkShell rec { - buildInputs = with coqPackages_8_17; [ + buildInputs = with coqPackages_8_19; [ coq - - # coq-lsp.packages.${system}.coq-lsp + coq-lsp + coq-elpi ]; }; } diff --git a/trillium/events/event.v b/trillium/events/event.v index 63287b7..8744102 100644 --- a/trillium/events/event.v +++ b/trillium/events/event.v @@ -307,7 +307,7 @@ Section properties. eapply extend_not_observed; [eauto|eauto|by apply trace_has_events_of_trace]. Qed. - Lemma events_of_trace_app (ex : execution_trace Λ) (l : list (olocale Λ * cfg Λ)) : + Lemma events_of_trace_app (ex : execution_trace Λ) (l : list (ex_label Λ * cfg Λ)) : valid_exec (ex +trl+ l) → ∃ evs, length evs ≤ length l ∧ @@ -347,7 +347,11 @@ Section properties. rewrite Nat.sub_diag //. Qed. - Lemma events_of_trace_app_map (ex : execution_trace Λ) (l : list (olocale Λ * cfg Λ)) : + (* TODO: Move this *) + Global Instance ex_label_inhabited : Inhabited (ex_label Λ). + Proof. Admitted. + + Lemma events_of_trace_app_map (ex : execution_trace Λ) (l : list (ex_label Λ * cfg Λ)) : valid_exec (ex +trl+ l) → ∃ evs, length evs ≤ length l ∧ @@ -378,10 +382,10 @@ Section properties. Implicit Types obs : EventObservation Λ. Implicit Types ex : execution_trace Λ. - Lemma events_of_trace_extend_triggered ex tp1 tp2 K e1 e2 efs σ1 σ2 oζ : + Lemma events_of_trace_extend_triggered ex tp1 tp2 K e1 e2 α efs σ1 σ2 oζ : valid_exec ex → trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) → - head_step e1 σ1 e2 σ2 efs → + head_step e1 σ1 α e2 σ2 efs → EV e1 σ1 e2 σ2 → events_of_trace EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) = events_of_trace EV ex ++ [mkEventObservation e1 σ1 e2 σ2]. @@ -408,10 +412,10 @@ Section properties. exfalso; eapply HnEV; eauto. Qed. - Lemma events_of_trace_extend_not_triggered ex tp1 tp2 K e1 e2 efs σ1 σ2 oζ: + Lemma events_of_trace_extend_not_triggered ex tp1 tp2 K e1 e2 α efs σ1 σ2 oζ: valid_exec ex → trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) → - head_step e1 σ1 e2 σ2 efs → + head_step e1 σ1 α e2 σ2 efs → ¬ EV e1 σ1 e2 σ2 → events_of_trace EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) = events_of_trace EV ex. diff --git a/trillium/prelude/relations.v b/trillium/prelude/relations.v new file mode 100644 index 0000000..e5c9639 --- /dev/null +++ b/trillium/prelude/relations.v @@ -0,0 +1,15 @@ +From Coq.Unicode Require Import Utf8. +From stdpp Require Import base tactics. + +Notation rel A B := (A → B → Prop). + +Definition rel_compose {A B C} (R : rel A B) (S : rel B C) : rel A C := + λ a c, ∃ b, R a b ∧ S b c. + +#[global] Instance rel_equiv {A B} : Equiv (rel A B) := λ R1 R2, ∀ a b, R1 a b ↔ R2 a b. + +Infix ">>" := rel_compose (at level 20, right associativity). + +Lemma rel_compose_assoc {A B C D} (R : rel A B) (S : rel B C) (T : rel C D) : + R >> (S >> T) ≡ (R >> S) >> T. +Proof. unfold rel_compose. intros a d; naive_solver. Qed. diff --git a/trillium/program_logic/adequacy.v b/trillium/program_logic/adequacy.v index 2c115f6..f335e73 100644 --- a/trillium/program_logic/adequacy.v +++ b/trillium/program_logic/adequacy.v @@ -41,12 +41,12 @@ Notation posts_of t Φs := (zip_with (λ x y, (x, y)) t Φs)), vΦ.2 vΦ.1)%I. Definition config_wp `{!irisG Λ M Σ} : iProp Σ := - □ ∀ ex atr c1 σ2 , + □ ∀ ex atr c1 lbl σ2 , ⌜valid_exec ex⌝ → ⌜trace_ends_in ex c1⌝ → - ⌜config_step c1.2 σ2⌝ → + ⌜config_step c1.2 lbl σ2⌝ → state_interp ex atr ={⊤,∅}=∗ |={∅}▷=>^(S $ trace_length ex) |={∅,⊤}=> - ∃ δ2 ℓ, state_interp (trace_extend ex None (c1.1, σ2)) + ∃ δ2 ℓ, state_interp (trace_extend ex (inr lbl) (c1.1, σ2)) (trace_extend atr ℓ δ2). #[global] Instance config_wp_persistent `{!irisG Λ M Σ} : Persistent config_wp. @@ -71,7 +71,7 @@ Definition Gsim_pre Σ {Λ} (M : Model) (s : stuckness) Proof. rewrite /Gsim_pre=> n wp wp' HGsm ex sm. repeat (f_contractive || f_equiv). - repeat (eapply dist_lt; try apply HGsm). auto. + repeat (eapply dist_lt; try apply HGsm). auto. Qed. Definition Gsim Σ {Λ} (M : Model) (s : stuckness) @@ -221,11 +221,11 @@ Section locales_helpers. locale_step c oζ c' -> locales_equiv c.1 (take (length c.1) c'.1). Proof. - intros H. inversion H as [? ? e1 ? e2 ? efs t1 t2|]; simplify_eq; simpl. + intros H. inversion H as [? ? e1 ? ? e2 ? efs t1 t2|]; simplify_eq; simpl. - replace (t1 ++ e2 :: t2 ++ efs) with ((t1 ++ e2 :: t2) ++ efs); last by list_simplifier. replace (length (t1 ++ e1 :: t2)) with (length (t1 ++ e2 :: t2)); last first. { rewrite !app_length //=. } - rewrite take_app. apply locales_equiv_middle. + rewrite take_app_length. apply locales_equiv_middle. eapply locale_step_preserve =>//. - rewrite take_ge =>//. apply locales_equiv_refl. Qed. @@ -371,6 +371,46 @@ Section from_locale. by eapply locale_injective. Qed. + + Lemma from_locale_from_elem_of es tp ζ (e : expr Λ): + from_locale_from es tp ζ = Some e → ∃ i, tp !! i = Some e. + Proof. + revert es. + induction tp as [|e' tp IHtp]; [done|]. + intros es Hlocale. + rewrite /from_locale in Hlocale. + simpl in *. + case_decide. + - simplify_eq. exists 0%nat. rewrite lookup_cons. done. + - specialize (IHtp (es ++ [e']) Hlocale) as [i Hi]. + exists (S i). done. + Qed. + + Lemma from_locale_elem_of tp ζ e : + from_locale tp ζ = Some e → ∃ i, tp !! i = Some e. + Proof. apply from_locale_from_elem_of. Qed. + + Lemma from_locale_from_elem_of' es tp ζ e : + from_locale_from es tp ζ = Some e → + ∃ i, tp !! i = Some e ∧ locale_of (es ++ take i tp) e = ζ. + Proof. + revert es. + induction tp as [|e' tp IHtp]; [done|]. + intros es Hlocale. + rewrite /from_locale in Hlocale. + simpl in *. + case_decide. + - simplify_eq. exists 0%nat. rewrite lookup_cons. + rewrite right_id. done. + - specialize (IHtp (es ++ [e']) Hlocale) as [i [Hlookup Hi]]. + exists (S i). simpl. split; [done|]. + rewrite cons_middle assoc. done. + Qed. + + Lemma from_locale_elem_of' tp ζ e : + from_locale tp ζ = Some e → ∃ i, tp !! i = Some e ∧ locale_of (take i tp) e = ζ. + Proof. apply from_locale_from_elem_of'. Qed. + End from_locale. (* TODO: Move *) @@ -400,11 +440,6 @@ Section locales_utils. (λ '(t, e), locale_of t e) <$> (prefixes_from tp0 tp). Notation locales_of_list tp := (locales_of_list_from [] tp). - Lemma locales_of_list_from_cons es' (e : expr Λ) es : - locales_of_list_from es' (e :: es) = - locale_of es' e :: locales_of_list_from (es' ++ [e]) es. - Proof. done. Qed. - Lemma locales_of_list_equiv (tp0 tp0' tp1 tp2 : list $ expr Λ) : locales_equiv_from tp0 tp0' tp1 tp2 ↔ locales_of_list_from tp0 tp1 = locales_of_list_from tp0' tp2. @@ -614,16 +649,16 @@ Notation locales_equiv_prefix tp1 tp2 := (locales_equiv_prefix_from [] tp1 tp2). Section adequacy_helper_lemmas. Context `{!irisG Λ M Σ}. - Lemma wp_take_step s Φ ex atr tp1 e1 tp2 σ1 e2 σ2 efs ζ: + Lemma wp_take_step s Φ ex atr tp1 e1 tp2 α σ1 e2 σ2 efs ζ: valid_exec ex → - prim_step e1 σ1 e2 σ2 efs → + prim_step e1 σ1 α e2 σ2 efs → trace_ends_in ex (tp1 ++ e1 :: tp2, σ1) → locale_of tp1 e1 = ζ -> state_interp ex atr -∗ WP e1 @ s; ζ; ⊤ {{ v, Φ v } } ={⊤,∅}=∗ |={∅}▷=>^(S $ trace_length ex) |={∅,⊤}=> ∃ δ' ℓ, - state_interp (trace_extend ex (Some ζ) (tp1 ++ e2 :: tp2 ++ efs, σ2)) + state_interp (trace_extend ex (inl (ζ,α)) (tp1 ++ e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ') ∗ WP e2 @ s; ζ; ⊤ {{ v, Φ v } } ∗ ([∗ list] i↦ef ∈ efs, @@ -690,7 +725,7 @@ Section adequacy_helper_lemmas. Proof. iIntros (Hsame Hexvalid Hex) "HSI Ht". rewrite assoc. - rewrite (wptp_from_same_locales t0') =>//. + iDestruct (wptp_from_same_locales with "Ht") as "Ht"=>//. iApply fupd_plain_keep_r; iFrame. iIntros "[HSI Ht]". iIntros (e He). @@ -845,9 +880,9 @@ Section adequacy_helper_lemmas. (* TODO: factorize the two halves *) rewrite big_sepL2_alt; iSplit. - iIntros "H". iSplit. - { rewrite drop_app_alt // map_length !prefixes_from_length //. } + { rewrite drop_app_length // map_length !prefixes_from_length //. } iInduction efs as [|ef efs] "IH" forall (t); first done. - rewrite /= !drop_app_alt //=. + rewrite /= !drop_app_length //=. iDestruct "H" as "[H1 H]". rewrite (right_id [] (++)). iFrame. replace (map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from (t ++ [ef]) efs)) @@ -857,10 +892,10 @@ Section adequacy_helper_lemmas. iIntros "!>" (k e Hin) "H". by list_simplifier. + list_simplifier. replace (t ++ ef :: efs) with ((t ++ [ef]) ++ efs); last by list_simplifier. - rewrite drop_app_alt //. + rewrite drop_app_length //. - iIntros "[_ H]". iInduction efs as [|ef efs] "IH" forall (t); first done. - rewrite /= !drop_app_alt //=. + rewrite /= !drop_app_length //=. iDestruct "H" as "[H1 H]". rewrite (right_id [] (++)). iFrame. replace (map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from (t ++ [ef]) efs)) @@ -870,7 +905,7 @@ Section adequacy_helper_lemmas. iIntros "!>" (k e Hin) "H". by list_simplifier. + list_simplifier. replace (t ++ ef :: efs) with ((t ++ [ef]) ++ efs); last by list_simplifier. - rewrite drop_app_alt //. + rewrite drop_app_length //. Qed. Lemma take_step s Φs ex atr c c' oζ: @@ -890,7 +925,7 @@ Section adequacy_helper_lemmas. Proof. iIntros (Hexvalid Hexe Hstep) "config_wp HSI Hc1". inversion Hstep as - [ρ1 ρ2 e1 σ1 e2 σ2 efs t1 t2 -> -> Hpstep | ρ1 ρ2 σ1 σ2 t -> -> Hcfgstep]. + [ρ1 ρ2 e1 σ1 α e2 σ2 efs t1 t2 -> -> Hpstep | ρ1 ρ2 σ1 lbl σ2 t -> -> Hcfgstep]. - rewrite /= !prefixes_from_app. iDestruct (big_sepL2_app_inv_l with "Hc1") as (Φs1 Φs2') "[-> [Ht1 Het2]]". @@ -909,7 +944,7 @@ Section adequacy_helper_lemmas. iIntros "!#" (i e Hin) "Hwp". list_simplifier. erewrite locale_equiv; first by iFrame. apply locales_equiv_middle. erewrite locale_step_preserve =>//. } - assert (valid_exec (ex :tr[Some (locale_of t1 e1)]: (t1 ++ e2 :: t2 ++ efs, σ2))). + assert (valid_exec (ex :tr[inl (locale_of t1 e1,α)]: (t1 ++ e2 :: t2 ++ efs, σ2))). { econstructor; eauto. } iMod (wptp_not_stuck_same _ _ σ2 _ _ [] with "HSI Hefs") as "[HSI [Hefs %]]"; [done| | ]. { list_simplifier. done. } @@ -948,7 +983,7 @@ Section adequacy_helper_lemmas. iApply (step_fupdN_wand with "[Hcfg]"); first by iApply "Hcfg". iIntros "Hcfg". iMod "Hcfg" as (δ2 ℓ) "HSI". - assert (valid_exec (ex :tr[None]: ((t, σ1).1, σ2))). + assert (valid_exec (ex :tr[inr lbl]: ((t, σ1).1, σ2))). { econstructor; eauto. } iMod (wptp_not_stuck _ _ σ2 _ _ _ [] with "HSI Hc1") as "[HSI [Hc1 %]]"; [apply locales_equiv_refl|done|by list_simplifier|]. @@ -1004,7 +1039,7 @@ Qed. Lemma fupd_to_bupd_soundness_no_lc' `{!invGpreS Σ} (Q : iProp Σ) `{!Plain Q} : (∀ `{Hinv: !invGS_gen HasNoLc Σ}, fupd_to_bupd ⊤ -∗ Q) → ⊢ Q. -Proof. by iIntros; iApply bupd_plain; iApply fupd_to_bupd_soundness_no_lc. Qed. +Proof. by iIntros; iApply bupd_elim; iApply fupd_to_bupd_soundness_no_lc. Qed. Theorem wp_strong_adequacy_multiple_helper Σ Λ M `{!invGpreS Σ} (s: stuckness) (ξ : execution_trace Λ → auxiliary_trace M → Prop) @@ -1047,7 +1082,7 @@ Proof. iApply fupd_to_bupd_soundness_no_lc'. iIntros (Hinv) "HFtB". rewrite fupd_to_bupd_unfold /fupd_to_bupd_aux. - iApply bupd_plain. + iApply bupd_elim. iApply "HFtB". iPoseProof (Hwp Hinv) as "Hwp". iMod "Hwp" as (stateI trace_inv Φs fork_post) @@ -1139,7 +1174,7 @@ Proof. clear Hn. rewrite -> fupd_to_bupd_unfold; rewrite /fupd_to_bupd_aux. iApply except_0_later. - iApply bupd_plain. + iApply bupd_elim. iApply "HFtB". iMod "Hstp"; simpl. iMod "Hstp". @@ -1148,7 +1183,7 @@ Proof. rewrite (fupd_to_bupd_unfold (∅ : coPset)); rewrite /fupd_to_bupd_aux. iNext. iApply except_0_later. - iApply bupd_plain. + iApply bupd_elim. iApply "HFtB". iMod "Hstp". iModIntro. @@ -1157,7 +1192,7 @@ Proof. iInduction n as [|n] "IHlen"; simpl; last first. { rewrite (fupd_to_bupd_unfold (∅ : coPset)); rewrite /fupd_to_bupd_aux. iApply except_0_later. - iApply bupd_plain. + iApply bupd_elim. iApply "HFtB". iMod "Hstp". iModIntro. @@ -1165,7 +1200,7 @@ Proof. rewrite (fupd_to_bupd_unfold (∅ : coPset)); rewrite /fupd_to_bupd_aux. iNext. iApply except_0_later. - iApply bupd_plain. + iApply bupd_elim. iApply "HFtB". iMod "Hstp". iModIntro. @@ -1174,7 +1209,7 @@ Proof. iApply ("IHlen" with "Hstep HTI Hstp"); done. } rewrite (fupd_to_bupd_unfold (∅ : coPset)); rewrite /fupd_to_bupd_aux. iApply except_0_later. - iApply bupd_plain. + iApply bupd_elim. iApply "HFtB". iMod "Hstp" as "(% & H)". iDestruct "H" as (δ'' ℓ) "(HSI & Hpost & Hback)"; simpl in *. @@ -1219,7 +1254,7 @@ Proof. - rewrite -app_assoc Hlocales. rewrite -> (fupd_to_bupd_unfold (⊤ : coPset)); rewrite /fupd_to_bupd_aux. iApply except_0_later. - iApply bupd_plain. + iApply bupd_elim. iApply "HFtB". iDestruct "Hback" as "(Hpost & Hwptp)". iDestruct ("H" with "Hpost") as "[? Hξ]". @@ -1231,7 +1266,7 @@ Proof. iExists _, _. rewrite -> (fupd_to_bupd_unfold (⊤ : coPset)); rewrite /fupd_to_bupd_aux. iApply except_0_later. - iApply bupd_plain. + iApply bupd_elim. iApply "HFtB". iMod ("IH" with "[] [] Hstep HSI [HTI] [Hback]") as "IH'". - iPureIntro; split_and!. @@ -1577,7 +1612,7 @@ Proof. destruct (decide (Forall (λ e, is_Some (to_val e)) t2)) as [|Ht2]; [by left|]. apply (not_Forall_Exists _), Exists_exists in Ht2; destruct Ht2 as (e2&?&He2). destruct (adequate_not_stuck NotStuck es σ1 φs Had ex t2 σ2 e2) - as [?|(e3&σ3&efs&?)]; + as [?|(α&e3&σ3&efs&?)]; rewrite ?eq_None_not_Some; auto. { exfalso. eauto. } destruct (elem_of_list_split t2 e2) as (t2'&t2''&->); auto. diff --git a/trillium/program_logic/ectx_language.v b/trillium/program_logic/ectx_language.v index 1b77a87..b0aac8a 100644 --- a/trillium/program_logic/ectx_language.v +++ b/trillium/program_logic/ectx_language.v @@ -11,13 +11,17 @@ file for doing that. *) Section ectx_language_mixin. Context {expr val ectx state : Type}. Context {locale : Type}. + Context {action : Type}. + Context {config_label : Type}. Context (of_val : val → expr). Context (to_val : expr → option val). Context (empty_ectx : ectx). Context (comp_ectx : ectx → ectx → ectx). Context (fill : ectx → expr → expr). - Context (head_step : expr → state → expr → state → list expr → Prop). - Context (locale_of : list expr -> expr -> locale). + Context (head_step : expr → state → option action → expr → state → list expr → Prop). + Context (config_step : state → config_label → state → Prop). + Context (locale_of : list expr → expr → locale). + Context (config_enabled : config_label → state → Prop). Notation locales_equiv t0 t0' := (Forall2 (λ '(t, e) '(t', e'), locale_of t e = locale_of t' e') (prefixes t0) (prefixes t0')). @@ -25,8 +29,8 @@ Section ectx_language_mixin. Record EctxLanguageMixin := { mixin_to_of_val v : to_val (of_val v) = Some v; mixin_of_to_val e v : to_val e = Some v → of_val v = e; - mixin_val_head_stuck e1 σ1 e2 σ2 efs : - head_step e1 σ1 e2 σ2 efs → to_val e1 = None; + mixin_val_head_stuck e1 σ1 α e2 σ2 efs : + head_step e1 σ1 α e2 σ2 efs → to_val e1 = None; mixin_fill_empty e : fill empty_ectx e = e; mixin_fill_comp K1 K2 e : fill K1 (fill K2 e) = fill (comp_ectx K1 K2) e; @@ -45,23 +49,25 @@ Section ectx_language_mixin. This implies there can be only one head redex, see [head_redex_unique]. *) - mixin_step_by_val K' K_redex e1' e1_redex σ1 e2 σ2 efs : + mixin_step_by_val K' K_redex e1' e1_redex σ1 α e2 σ2 efs : fill K' e1' = fill K_redex e1_redex → to_val e1' = None → - head_step e1_redex σ1 e2 σ2 efs → + head_step e1_redex σ1 α e2 σ2 efs → ∃ K'', K_redex = comp_ectx K' K''; (** If [fill K e] takes a head step, then either [e] is a value or [K] is the empty evaluation context. In other words, if [e] is not a value wrapping it in a context does not add new head redex positions. *) - mixin_head_ctx_step_val K e σ1 e2 σ2 efs : - head_step (fill K e) σ1 e2 σ2 efs → is_Some (to_val e) ∨ K = empty_ectx; - mixin_locale_step e1 e2 t1 σ1 σ2 efs: head_step e1 σ1 e2 σ2 efs -> + mixin_head_ctx_step_val K e σ1 α e2 σ2 efs : + head_step (fill K e) σ1 α e2 σ2 efs → is_Some (to_val e) ∨ K = empty_ectx; + mixin_locale_step e1 e2 t1 σ1 α σ2 efs: head_step e1 σ1 α e2 σ2 efs -> locale_of t1 e1 = locale_of t1 e2; mixin_locale_fill e K t1: locale_of t1 (fill K e) = locale_of t1 e; mixin_locale_equiv t t' e: locales_equiv t t' -> locale_of t e = locale_of t' e; mixin_locale_injective tp0 e0 tp1 tp e: (tp, e) ∈ prefixes_from (tp0 ++ [e0]) tp1 -> locale_of tp0 e0 ≠ locale_of tp e; + (* mixin_config_enabled σ lbl : *) + (* (∃ σ', config_step σ lbl σ') ↔ config_enabled lbl σ; *) }. End ectx_language_mixin. @@ -71,32 +77,36 @@ Structure ectxLanguage := EctxLanguage { ectx : Type; state : Type; locale : Type; + action : Type; + config_label : Type; of_val : val → expr; to_val : expr → option val; empty_ectx : ectx; comp_ectx : ectx → ectx → ectx; fill : ectx → expr → expr; - head_step : expr → state → expr → state → list expr → Prop; - config_step : state → state → Prop; - locale_of : list expr -> expr -> locale; + head_step : expr → state → option action → expr → state → list expr → Prop; + config_step : state → config_label → state → Prop; + locale_of : list expr → expr → locale; + (* config_enabled : config_label → state → Prop; *) ectx_language_mixin : - EctxLanguageMixin of_val to_val empty_ectx comp_ectx fill head_step locale_of + EctxLanguageMixin of_val to_val empty_ectx comp_ectx fill head_step (* config_step *) locale_of (* config_enabled *) }. Bind Scope expr_scope with expr. Bind Scope val_scope with val. -Arguments EctxLanguage {_ _ _ _ _ _ _ _ _ _} _ _. +Arguments EctxLanguage {_ _ _ _ _ _ _ _ _ _ _ _} _ _ _. Arguments of_val {_} _. Arguments to_val {_} _. Arguments empty_ectx {_}. Arguments comp_ectx {_} _ _. Arguments fill {_} _ _. Arguments head_step {_} _ _ _ _ _. -Arguments config_step {_} _ _. +Arguments config_step {_} _ _ _. Arguments locale_of {_} _ _. +(* Arguments config_enabled {_} _ _. *) Notation locales_equiv t0 t0' := (Forall2 (λ '(t, e) '(t', e'), locale_of t e = locale_of t' e') (prefixes t0) (prefixes t0')). @@ -109,7 +119,7 @@ Section ectx_language. Implicit Types K : ectx Λ. (* Only project stuff out of the mixin that is not also in language *) - Lemma val_head_stuck e1 σ1 e2 σ2 efs : head_step e1 σ1 e2 σ2 efs → to_val e1 = None. + Lemma val_head_stuck e1 σ1 α e2 σ2 efs : head_step e1 σ1 α e2 σ2 efs → to_val e1 = None. Proof. apply ectx_language_mixin. Qed. Lemma fill_empty e : fill empty_ectx e = e. Proof. apply ectx_language_mixin. Qed. @@ -124,20 +134,20 @@ Section ectx_language. fill K e = fill K' e' → (∃ K'', K' = comp_ectx K K'') ∨ (∃ K'', K = comp_ectx K' K''). Proof. apply ectx_language_mixin. Qed. - Lemma step_by_val K' K_redex e1' e1_redex σ1 e2 σ2 efs : + Lemma step_by_val K' K_redex e1' e1_redex σ1 α e2 σ2 efs : fill K' e1' = fill K_redex e1_redex → to_val e1' = None → - head_step e1_redex σ1 e2 σ2 efs → + head_step e1_redex σ1 α e2 σ2 efs → ∃ K'', K_redex = comp_ectx K' K''. Proof. apply ectx_language_mixin. Qed. - Lemma head_ctx_step_val K e σ1 e2 σ2 efs : - head_step (fill K e) σ1 e2 σ2 efs → is_Some (to_val e) ∨ K = empty_ectx. + Lemma head_ctx_step_val K e σ1 α e2 σ2 efs : + head_step (fill K e) σ1 α e2 σ2 efs → is_Some (to_val e) ∨ K = empty_ectx. Proof. apply ectx_language_mixin. Qed. Definition head_reducible (e : expr Λ) (σ : state Λ) := - ∃ e' σ' efs, head_step e σ e' σ' efs. + ∃ α e' σ' efs, head_step e σ α e' σ' efs. Definition head_irreducible (e : expr Λ) (σ : state Λ) := - ∀ e' σ' efs, ¬head_step e σ e' σ' efs. + ∀ α e' σ' efs, ¬head_step e σ α e' σ' efs. Definition head_stuck (e : expr Λ) (σ : state Λ) := to_val e = None ∧ head_irreducible e σ. @@ -149,33 +159,33 @@ Section ectx_language. Definition sub_redexes_are_values (e : expr Λ) := ∀ K e', e = fill K e' → to_val e' = None → K = empty_ectx. - Inductive prim_step (e1 : expr Λ) (σ1 : state Λ) + Inductive prim_step (e1 : expr Λ) (σ1 : state Λ) (α : option (action Λ)) (e2 : expr Λ) (σ2 : state Λ) (efs : list (expr Λ)) : Prop := Ectx_step K e1' e2' : e1 = fill K e1' → e2 = fill K e2' → - head_step e1' σ1 e2' σ2 efs → prim_step e1 σ1 e2 σ2 efs. + head_step e1' σ1 α e2' σ2 efs → prim_step e1 σ1 α e2 σ2 efs. - Lemma Ectx_step' K e1 σ1 e2 σ2 efs : - head_step e1 σ1 e2 σ2 efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. + Lemma Ectx_step' K e1 σ1 α e2 σ2 efs : + head_step e1 σ1 α e2 σ2 efs → prim_step (fill K e1) σ1 α (fill K e2) σ2 efs. Proof. econstructor; eauto. Qed. Lemma fill_not_val K e : to_val e = None → to_val (fill K e) = None. Proof. rewrite !eq_None_not_Some. eauto using fill_val. Qed. Definition ectx_lang_mixin : - LanguageMixin of_val to_val prim_step locale_of comp_ectx empty_ectx fill. + LanguageMixin of_val to_val prim_step (* config_step *) locale_of (* config_enabled *) comp_ectx empty_ectx fill. Proof. split. - apply ectx_language_mixin. - apply ectx_language_mixin. - - intros ????? [??? -> -> ?%val_head_stuck]. + - intros ?????? [??? -> -> ?%val_head_stuck]. apply eq_None_not_Some. by intros ?%fill_val%eq_None_not_Some. - intros K; split_and!. + eauto using fill_not_val. - + intros ????? [K' e1' e2' Heq1 Heq2 Hstep]. + + intros ?????? [K' e1' e2' Heq1 Heq2 Hstep]. exists (comp_ectx K K') e1' e2'; rewrite ?Heq1 ?Heq2 ?fill_comp; done. - + intros e1 σ1 e2 σ2 efs Hnval [K'' e1'' e2'' Heq1 -> Hstep]. - destruct (step_by_val K K'' e1 e1'' σ1 e2'' σ2 efs) as [K' ->]; eauto. + + intros e1 σ1 α e2 σ2 efs Hnval [K'' e1'' e2'' Heq1 -> Hstep]. + destruct (step_by_val K K'' e1 e1'' σ1 α e2'' σ2 efs) as [K' ->]; eauto. rewrite -fill_comp in Heq1; apply (inj (fill _)) in Heq1. exists (fill K' e2''); rewrite -fill_comp; split; auto. econstructor; eauto. @@ -183,25 +193,27 @@ Section ectx_language. - intros ? ? ?; rewrite fill_comp; done. - apply fill_inj. - apply fill_positive. - - intros e1 e2 t1 σ1 σ2 efs Hpstep. inversion Hpstep; simplify_eq. + - intros e1 e2 α t1 σ1 σ2 efs Hpstep. inversion Hpstep; simplify_eq. do 2 (erewrite mixin_locale_fill; last apply ectx_language_mixin). eapply mixin_locale_step; first apply ectx_language_mixin. done. - apply ectx_language_mixin. - apply ectx_language_mixin. - apply ectx_language_mixin. + (* - apply ectx_language_mixin. *) Qed. Canonical Structure ectx_lang : language := - Language (config_step := config_step) prim_step empty_ectx fill ectx_lang_mixin. + Language prim_step config_step (* (config_enabled := config_enabled) *) + empty_ectx fill ectx_lang_mixin. Definition head_atomic (a : atomicity) (e : expr Λ) : Prop := - ∀ σ e' σ' efs, - head_step e σ e' σ' efs → + ∀ σ α e' σ' efs, + head_step e σ α e' σ' efs → if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e'). Definition head_stutteringatomic (a : atomicity) (e : expr Λ) : Prop := - ∀ σ e' σ' efs, - head_step e σ e' σ' efs → + ∀ σ α e' σ' efs, + head_step e σ α e' σ' efs → (e' = e ∧ σ' = σ ∧ efs = []) ∨ if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e'). @@ -220,35 +232,35 @@ Section ectx_language. head_reducible e' σ → K = comp_ectx K' empty_ectx ∧ e = e'. Proof. - intros Heq (e2 & σ2 & efs & Hred) (e2' & σ2' & efs' & Hred'). + intros Heq (α & e2 & σ2 & efs & Hred) (α' & e2' & σ2' & efs' & Hred'). edestruct (step_by_val K' K e' e) as [K'' HK]; [by eauto using val_head_stuck..|]. subst K. move: Heq. rewrite -fill_comp. intros <-%(inj (fill _)). - destruct (head_ctx_step_val _ _ _ _ _ _ Hred') as [[]%not_eq_None_Some|HK'']. + destruct (head_ctx_step_val _ _ _ _ _ _ _ Hred') as [[]%not_eq_None_Some|HK'']. { by eapply val_head_stuck. } subst K''. rewrite fill_empty. done. Qed. - Lemma head_prim_step e1 σ1 e2 σ2 efs : - head_step e1 σ1 e2 σ2 efs → prim_step e1 σ1 e2 σ2 efs. + Lemma head_prim_step e1 σ1 α e2 σ2 efs : + head_step e1 σ1 α e2 σ2 efs → prim_step e1 σ1 α e2 σ2 efs. Proof. apply Ectx_step with empty_ectx; by rewrite ?fill_empty. Qed. - Lemma head_step_not_stuck e σ e' σ' efs : head_step e σ e' σ' efs → not_stuck e σ. + Lemma head_step_not_stuck e σ α e' σ' efs : head_step e σ α e' σ' efs → not_stuck e σ. Proof. rewrite /not_stuck /reducible /=. eauto 10 using head_prim_step. Qed. - Lemma fill_prim_step K e1 σ1 e2 σ2 efs : - prim_step e1 σ1 e2 σ2 efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. + Lemma fill_prim_step K e1 σ1 α e2 σ2 efs : + prim_step e1 σ1 α e2 σ2 efs → prim_step (fill K e1) σ1 α (fill K e2) σ2 efs. Proof. destruct 1 as [K' e1' e2' -> ->]. rewrite !fill_comp. by econstructor. Qed. Lemma fill_reducible K e σ : reducible e σ → reducible (fill K e) σ. Proof. - intros (e'&σ'&efs&?). exists (fill K e'), σ', efs. + intros (α&e'&σ'&efs&?). exists α, (fill K e'), σ', efs. by apply fill_prim_step. Qed. Lemma head_prim_reducible e σ : head_reducible e σ → reducible e σ. - Proof. intros (e'&σ'&efs&?). eexists e', σ', efs. by apply head_prim_step. Qed. + Proof. intros (α&e'&σ'&efs&?). eexists α, e', σ', efs. by apply head_prim_step. Qed. Lemma head_prim_fill_reducible e K σ : head_reducible e σ → reducible (fill K e) σ. Proof. intro. by apply fill_reducible, head_prim_reducible. Qed. @@ -260,7 +272,7 @@ Section ectx_language. Lemma prim_head_reducible e σ : reducible e σ → sub_redexes_are_values e → head_reducible e σ. Proof. - intros (e'&σ'&efs&[K e1' e2' -> -> Hstep]) ?. + intros (α&e'&σ'&efs&[K e1' e2' -> -> Hstep]) ?. assert (K = empty_ectx) as -> by eauto 10 using val_head_stuck. rewrite fill_empty /head_reducible; eauto. Qed. @@ -280,7 +292,7 @@ Section ectx_language. Lemma ectx_language_atomic a e : head_atomic a e → sub_redexes_are_values e → Atomic a e. Proof. - intros Hatomic_step Hatomic_fill σ e' σ' efs [K e1' e2' -> -> Hstep]. + intros Hatomic_step Hatomic_fill σ α e' σ' efs [K e1' e2' -> -> Hstep]. assert (K = empty_ectx) as -> by eauto 10 using val_head_stuck. rewrite fill_empty. eapply Hatomic_step. by rewrite fill_empty. Qed. @@ -288,18 +300,18 @@ Section ectx_language. Lemma ectx_language_stutteringatomic a e : head_stutteringatomic a e → sub_redexes_are_values e → StutteringAtomic a e. Proof. - intros Hatomic_step Hatomic_fill σ e' σ' efs [K e1' e2' -> -> Hstep]. + intros Hatomic_step Hatomic_fill σ α e' σ' efs [K e1' e2' -> -> Hstep]. assert (K = empty_ectx) as -> by eauto 10 using val_head_stuck. revert Hatomic_step; rewrite !fill_empty; intros Hatomic_step. eapply Hatomic_step; done. Qed. - Lemma head_reducible_prim_step_ctx K e1 σ1 e2 σ2 efs : + Lemma head_reducible_prim_step_ctx K e1 σ1 α e2 σ2 efs : head_reducible e1 σ1 → - prim_step (fill K e1) σ1 e2 σ2 efs → - ∃ e2', e2 = fill K e2' ∧ head_step e1 σ1 e2' σ2 efs. + prim_step (fill K e1) σ1 α e2 σ2 efs → + ∃ e2', e2 = fill K e2' ∧ head_step e1 σ1 α e2' σ2 efs. Proof. - intros (e2''&σ2''&efs''&HhstepK) [K' e1' e2' HKe1 -> Hstep]. + intros (α''&e2''&σ2''&efs''&HhstepK) [K' e1' e2' HKe1 -> Hstep]. edestruct (step_by_val K) as [K'' ?]; eauto using val_head_stuck; simplify_eq/=. rewrite -fill_comp in HKe1; simplify_eq. @@ -309,10 +321,10 @@ Section ectx_language. by rewrite !fill_empty. Qed. - Lemma head_reducible_prim_step e1 σ1 e2 σ2 efs : + Lemma head_reducible_prim_step e1 σ1 α e2 σ2 efs : head_reducible e1 σ1 → - prim_step e1 σ1 e2 σ2 efs → - head_step e1 σ1 e2 σ2 efs. + prim_step e1 σ1 α e2 σ2 efs → + head_step e1 σ1 α e2 σ2 efs. Proof. intros. edestruct (head_reducible_prim_step_ctx empty_ectx) as (?&?&?); @@ -322,16 +334,16 @@ Section ectx_language. Record pure_head_step (e1 e2 : expr Λ) := { pure_head_step_safe σ1 : head_reducible e1 σ1; - pure_head_step_det σ1 e2' σ2 efs : - head_step e1 σ1 e2' σ2 efs → σ2 = σ1 ∧ e2' = e2 ∧ efs = [] + pure_head_step_det σ1 α e2' σ2 efs : + head_step e1 σ1 α e2' σ2 efs → σ2 = σ1 ∧ α = None ∧ e2' = e2 ∧ efs = [] }. Lemma pure_head_step_pure_step e1 e2 : pure_head_step e1 e2 → pure_step e1 e2. Proof. intros [Hp1 Hp2]. split. - - intros σ. destruct (Hp1 σ) as (e2' & σ2 & efs & ?). - eexists e2', σ2, efs. by apply head_prim_step. - - intros σ1 e2' σ2 efs ?%head_reducible_prim_step; eauto. + - intros σ. destruct (Hp1 σ) as (α & e2' & σ2 & efs & ?). + eexists α, e2', σ2, efs. by apply head_prim_step. + - intros σ1 α e2' σ2 efs ?%head_reducible_prim_step; eauto. Qed. (** This is not an instance because HeapLang's [wp_pure] tactic already takes @@ -344,11 +356,11 @@ Section ectx_language. PureExec φ n (fill K e1) (fill K e2). Proof. apply: pure_exec_ctx. Qed. - Lemma head_locale_step K e1 e2 tp1 tp2 efs σ1 σ2 : - head_step e1 σ1 e2 σ2 efs → + Lemma head_locale_step K e1 e2 α tp1 tp2 efs σ1 σ2 : + head_step e1 σ1 α e2 σ2 efs → locale_step (tp1 ++ fill K e1 :: tp2, σ1) - (Some (locale_of tp1 e1)) + (inl (locale_of tp1 e1, α)) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2). Proof. intros Hstep. rewrite -(locale_fill _ K). econstructor =>//. @@ -368,7 +380,7 @@ work. Note that this trick no longer works when we switch to canonical projections because then the pattern match [let '...] will be desugared into projections. *) Definition LanguageOfEctx (Λ : ectxLanguage) : language := - let '@EctxLanguage E V C St Loc of_val to_val empty comp fill head config loc_of mix := Λ in - @Language E V C St Loc of_val to_val _ config loc_of comp empty fill + let '@EctxLanguage E V C St Loc locale action of_val to_val empty comp fill head config loc_of (* config_enabled *) mix := Λ in + @Language E V C St Loc locale action of_val to_val _ config loc_of (* config_enabled *) comp empty fill (@ectx_lang_mixin - (@EctxLanguage E V C St Loc of_val to_val empty comp fill head config loc_of mix)). + (@EctxLanguage E V C St Loc locale action of_val to_val empty comp fill head config loc_of (* config_enabled *) mix)). diff --git a/trillium/program_logic/ectx_lifting.v b/trillium/program_logic/ectx_lifting.v index f0ef2d4..110bf44 100644 --- a/trillium/program_logic/ectx_lifting.v +++ b/trillium/program_logic/ectx_lifting.v @@ -25,10 +25,10 @@ Lemma wp_lift_head_step_fupd {s E Φ} e1 ζ: ⌜locale_of tp1 (ectx_fill K e1) = ζ⌝ -∗ state_interp extr atr ={E,∅}=∗ ⌜head_reducible e1 σ1⌝ ∗ - ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={∅}=∗ ▷ |={∅,E}=> + ∀ α e2 σ2 efs, ⌜head_step e1 σ1 α e2 σ2 efs⌝ ={∅}=∗ ▷ |={∅,E}=> ∃ δ2 ℓ, state_interp - (trace_extend extr (Some ζ) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) + (trace_extend extr (inl (ζ,α)) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ2) ∗ WP e2 @ s; ζ; E {{ Φ }} ∗ [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ @@ -40,7 +40,7 @@ Proof. iMod ("H" with "[//] [//] [//] Hsi") as "[% H]". iModIntro. iSplit; first by destruct s; eauto. - iIntros (e2 σ2 efs ?). + iIntros (α e2 σ2 efs ?). iApply "H"; eauto. Qed. @@ -51,10 +51,10 @@ Lemma wp_lift_head_step {s E Φ} e1 ζ: ⌜trace_ends_in extr (tp1 ++ fill K e1 :: tp2, σ1)⌝ → state_interp extr atr ={E,∅}=∗ ⌜head_reducible e1 σ1⌝ ∗ - ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={∅,E}=∗ + ▷ ∀ α e2 σ2 efs, ⌜head_step e1 σ1 α e2 σ2 efs⌝ ={∅,E}=∗ ∃ δ2 ℓ, state_interp - (trace_extend extr (Some ζ) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) + (trace_extend extr (inl (ζ,α)) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ2) ∗ WP e2 @ s; ζ; E {{ Φ }} ∗ [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ @@ -63,7 +63,7 @@ Lemma wp_lift_head_step {s E Φ} e1 ζ: Proof. iIntros (?) "H". iApply wp_lift_head_step_fupd; [done|]. iIntros (?????????) "?". iMod ("H" with "[//] [//] [$]") as "[$ H]". - iIntros "!>" (e2 σ2 efs ?) "!> !>". + iIntros "!>" (α e2 σ2 efs ?) "!> !>". iApply "H"; done. Qed. @@ -99,10 +99,10 @@ Lemma wp_lift_atomic_head_step_fupd {s E1 E2 Φ} e1 ζ: ⌜locale_of tp1 e1 = ζ⌝ → state_interp extr atr ={E1}=∗ ⌜head_reducible e1 σ1⌝ ∗ - ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={E1}[E2]▷=∗ + ∀ α e2 σ2 efs, ⌜head_step e1 σ1 α e2 σ2 efs⌝ ={E1}[E2]▷=∗ ∃ δ2 ℓ, state_interp - (trace_extend extr (Some ζ) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) + (trace_extend extr (inl (ζ,α)) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ2) ∗ from_option Φ False (to_val e2) ∗ [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ @@ -113,7 +113,7 @@ Proof. iIntros (?????????) "Hsi". iMod ("H" with "[//] [//] [//] Hsi") as "[% H]". iModIntro. iSplit; first by destruct s; auto. - iIntros (e2 σ2 efs Hstep). + iIntros (α e2 σ2 efs Hstep). iApply "H"; eauto. Qed. @@ -125,10 +125,10 @@ Lemma wp_lift_atomic_head_step {s E Φ} e1 ζ: ⌜locale_of tp1 e1 = ζ⌝ → state_interp extr atr ={E}=∗ ⌜head_reducible e1 σ1⌝ ∗ - ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={E}=∗ + ▷ ∀ α e2 σ2 efs, ⌜head_step e1 σ1 α e2 σ2 efs⌝ ={E}=∗ ∃ δ2 ℓ, state_interp - (trace_extend extr (Some ζ) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) + (trace_extend extr (inl (ζ,α)) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ2) ∗ from_option Φ False (to_val e2) ∗ [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ @@ -138,7 +138,7 @@ Proof. iIntros (?) "H". iApply wp_lift_atomic_step; eauto. iIntros (?????????) "Hsi". iMod ("H" with "[//] [//] [//] Hsi") as "[% H]". iModIntro. - iSplit; first by destruct s; auto. iNext. iIntros (e2 σ2 efs Hstep). + iSplit; first by destruct s; auto. iNext. iIntros (α e2 σ2 efs Hstep). iApply "H"; eauto. Qed. @@ -150,11 +150,11 @@ Lemma wp_lift_atomic_head_step_no_fork_fupd {s E1 E2 Φ} e1 ζ: ⌜locale_of tp1 e1 = ζ⌝ → state_interp extr atr ={E1}=∗ ⌜head_reducible e1 σ1⌝ ∗ - ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={E1}[E2]▷=∗ + ∀ α e2 σ2 efs, ⌜head_step e1 σ1 α e2 σ2 efs⌝ ={E1}[E2]▷=∗ ∃ δ2 ℓ, ⌜efs = [] ⌝∗ state_interp - (trace_extend extr (Some ζ) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) + (trace_extend extr (inl (ζ,α)) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ2) ∗ from_option Φ False (to_val e2)) ⊢ WP e1 @ s; ζ; E1 {{ Φ }}. @@ -163,8 +163,8 @@ Proof. iIntros (?????????) "Hsi". iMod ("H" with "[//] [//] [//] Hsi") as "[$ H]". iModIntro. - iIntros (v2 σ2 efs Hstep). - iMod ("H" $! v2 σ2 efs with "[# //]") as "H". + iIntros (α v2 σ2 efs Hstep). + iMod ("H" $! α v2 σ2 efs with "[# //]") as "H". iIntros "!> !>". iMod "H" as (st' ℓ) "(-> & ? & ?) /=". iModIntro; iExists _, _. iFrame. @@ -178,10 +178,10 @@ Lemma wp_lift_atomic_head_step_no_fork {s E Φ} e1 ζ: ⌜locale_of tp1 e1 = ζ⌝ → state_interp extr atr ={E}=∗ ⌜head_reducible e1 σ1⌝ ∗ - ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={E}=∗ + ▷ ∀ α e2 σ2 efs, ⌜head_step e1 σ1 α e2 σ2 efs⌝ ={E}=∗ ∃ δ2 ℓ, ⌜efs = []⌝ ∗ state_interp - (trace_extend extr (Some ζ) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) + (trace_extend extr (inl (ζ,α)) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ2) ∗ from_option Φ False (to_val e2)) ⊢ WP e1 @ s; ζ; E {{ Φ }}. @@ -190,8 +190,8 @@ Proof. iIntros (?????????) "Hsi". iMod ("H" with "[//] [//] [//] Hsi") as "[$ H]". iModIntro. - iNext; iIntros (v2 σ2 efs Hstep). - iMod ("H" $! v2 σ2 efs with "[//]") as (st' ℓ) "(-> & ? & ?) /=". + iNext; iIntros (α v2 σ2 efs Hstep). + iMod ("H" $! α v2 σ2 efs with "[//]") as (st' ℓ) "(-> & ? & ?) /=". iModIntro; iExists _, _. iFrame. Qed. @@ -200,8 +200,8 @@ Lemma wp_lift_pure_det_head_step_no_fork `{!AllowsPureStep M Σ} {s E E' Φ} e1 e2 ζ: to_val e1 = None → (∀ σ1, head_reducible e1 σ1) → - (∀ σ1 e2' σ2 efs', - head_step e1 σ1 e2' σ2 efs' → σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) → + (∀ α σ1 e2' σ2 efs', + head_step e1 σ1 α e2' σ2 efs' → σ2 = σ1 ∧ α = None ∧ e2' = e2 ∧ efs' = []) → (|={E}[E']▷=> WP e2 @ s; ζ; E {{ Φ }}) ⊢ WP e1 @ s; ζ; E {{ Φ }}. Proof using Hinh. intros. rewrite -(wp_lift_pure_det_step_no_fork e1 e2); eauto. @@ -212,8 +212,8 @@ Lemma wp_lift_pure_det_head_step_no_fork' `{!AllowsPureStep M Σ} {s E Φ} e1 e2 ζ: to_val e1 = None → (∀ σ1, head_reducible e1 σ1) → - (∀ σ1 e2' σ2 efs', - head_step e1 σ1 e2' σ2 efs' → σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) → + (∀ α σ1 e2' σ2 efs', + head_step e1 σ1 α e2' σ2 efs' → σ2 = σ1 ∧ α = None ∧ e2' = e2 ∧ efs' = []) → ▷ WP e2 @ s; ζ; E {{ Φ }} ⊢ WP e1 @ s; ζ; E {{ Φ }}. Proof using Hinh. intros. rewrite -[(WP e1 @ s; _; _ {{ _ }})%I]wp_lift_pure_det_head_step_no_fork //. diff --git a/trillium/program_logic/ectxi_language.v b/trillium/program_logic/ectxi_language.v index 247ffe2..b421645 100644 --- a/trillium/program_logic/ectxi_language.v +++ b/trillium/program_logic/ectxi_language.v @@ -26,13 +26,14 @@ Below you can find the relevant parts: *) Section ectxi_language_mixin. - Context {expr val ectx_item state locale : Type}. + Context {expr val ectx_item state locale action config_label : Type}. Context (of_val : val → expr). Context (to_val : expr → option val). Context (fill_item : ectx_item → expr → expr). - Context (head_step : expr → state → expr → state → list expr → Prop). - Context (config_step : state → state → Prop). - Context (locale_of : list expr -> expr -> locale). + Context (head_step : expr → state → option action → expr → state → list expr → Prop). + Context (config_step : state → config_label → state → Prop). + Context (locale_of : list expr → expr → locale). + (* Context (config_enabled : config_label → state → Prop). *) Notation locales_equiv t0 t0' := (Forall2 (λ '(t, e) '(t', e'), locale_of t e = locale_of t' e') (prefixes t0) (prefixes t0')). @@ -40,7 +41,7 @@ Section ectxi_language_mixin. Record EctxiLanguageMixin := { mixin_to_of_val v : to_val (of_val v) = Some v; mixin_of_to_val e v : to_val e = Some v → of_val v = e; - mixin_val_stuck e1 σ1 e2 σ2 efs : head_step e1 σ1 e2 σ2 efs → to_val e1 = None; + mixin_val_stuck e1 σ1 α e2 σ2 efs : head_step e1 σ1 α e2 σ2 efs → to_val e1 = None; mixin_fill_item_val Ki e : is_Some (to_val (fill_item Ki e)) → is_Some (to_val e); (** [fill_item] is always injective on the expression for a fixed @@ -56,15 +57,17 @@ Section ectxi_language_mixin. [ectx_language], an empty context is impossible here). In other words, if [e] is not a value then wrapping it in a context does not add new head redex positions. *) - mixin_head_ctx_step_val Ki e σ1 e2 σ2 efs : - head_step (fill_item Ki e) σ1 e2 σ2 efs → is_Some (to_val e); + mixin_head_ctx_step_val Ki e σ1 α e2 σ2 efs : + head_step (fill_item Ki e) σ1 α e2 σ2 efs → is_Some (to_val e); - mixin_locale_step e1 e2 t1 σ1 σ2 efs: head_step e1 σ1 e2 σ2 efs -> + mixin_locale_step e1 e2 t1 σ1 α σ2 efs: head_step e1 σ1 α e2 σ2 efs -> locale_of t1 e1 = locale_of t1 e2; mixin_locale_fill e K t1: locale_of t1 (fill_item K e) = locale_of t1 e; mixin_locale_equiv t t' e: locales_equiv t t' -> locale_of t e = locale_of t' e; mixin_locale_injective tp0 e0 tp1 tp e: (tp, e) ∈ prefixes_from (tp0 ++ [e0]) tp1 -> locale_of tp0 e0 ≠ locale_of tp e; + (* mixin_config_enabled σ lbl : *) + (* (∃ σ', config_step σ lbl σ') ↔ config_enabled lbl σ; *) }. End ectxi_language_mixin. @@ -74,28 +77,32 @@ Structure ectxiLanguage := EctxiLanguage { ectx_item : Type; state : Type; locale : Type; + action : Type; + config_label : Type; of_val : val → expr; to_val : expr → option val; fill_item : ectx_item → expr → expr; - head_step : expr → state → expr → state → list expr → Prop; - config_step : state → state → Prop; - locale_of : list expr -> expr -> locale; + head_step : expr → state → option action → expr → state → list expr → Prop; + config_step : state → config_label → state → Prop; + locale_of : list expr → expr → locale; + (* config_enabled : config_label → state → Prop; *) ectxi_language_mixin : - EctxiLanguageMixin of_val to_val fill_item head_step locale_of + EctxiLanguageMixin of_val to_val fill_item head_step (* config_step *) locale_of (* config_enabled *) }. Bind Scope expr_scope with expr. Bind Scope val_scope with val. -Arguments EctxiLanguage {_ _ _ _ _ _ _ _} _ _. +Arguments EctxiLanguage {_ _ _ _ _ _ _ _ _ _} _ _ _ _. Arguments of_val {_} _. Arguments to_val {_} _. Arguments fill_item {_} _ _. Arguments head_step {_} _ _ _ _ _. -Arguments config_step {_} _ _. +Arguments config_step {_} _ _ _. Arguments locale_of {_} _ _. +(* Arguments config_enabled {_} _ _. *) Section ectxi_language. Context {Λ : ectxiLanguage}. @@ -111,8 +118,8 @@ Section ectxi_language. to_val e1 = None → to_val e2 = None → fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2. Proof. apply ectxi_language_mixin. Qed. - Lemma head_ctx_step_val Ki e σ1 e2 σ2 efs : - head_step (fill_item Ki e) σ1 e2 σ2 efs → is_Some (to_val e). + Lemma head_ctx_step_val Ki e σ1 α e2 σ2 efs : + head_step (fill_item Ki e) σ1 α e2 σ2 efs → is_Some (to_val e). Proof. apply ectxi_language_mixin. Qed. Definition fill (K : ectx) (e : expr Λ) : expr Λ := foldl (flip fill_item) e K. @@ -121,7 +128,7 @@ Section ectxi_language. Proof. apply foldl_app. Qed. Definition ectxi_lang_ectx_mixin : - EctxLanguageMixin of_val to_val [] (flip (++)) fill head_step locale_of. + EctxLanguageMixin of_val to_val [] (flip (++)) fill head_step (* config_step *) locale_of (* config_enabled *). Proof. assert (fill_val : ∀ K e, is_Some (to_val (fill K e)) → is_Some (to_val e)). { intros K. induction K as [|Ki K IH]=> e //=. by intros ?%IH%fill_item_val. } @@ -148,7 +155,7 @@ Section ectxi_language. apply IHK in Hes as [[Kx ->]|[Kx ->]]; [| |done|done]. + left; eexists; rewrite -assoc; done. + right; eexists; rewrite -assoc; done. - - intros K K' e1 e1' σ1 e2 σ2 efs Hfill Hred Hstep; revert K' Hfill. + - intros K K' e1 e1' α σ1 e2 σ2 efs Hfill Hred Hstep; revert K' Hfill. induction K as [|Ki K IH] using rev_ind=> /= K' Hfill; eauto using app_nil_r. destruct K' as [|Ki' K' _] using @rev_ind; simplify_eq/=. { rewrite fill_app in Hstep. apply head_ctx_step_val in Hstep. @@ -159,7 +166,7 @@ Section ectxi_language. apply fill_not_val. revert Hstep. apply ectxi_language_mixin. } simplify_eq. destruct (IH K') as [K'' ->]; auto. exists K''. by rewrite assoc. - - intros K e1 σ1 e2 σ2 efs. + - intros K e1 σ1 α e2 σ2 efs. destruct K as [|Ki K _] using rev_ind; simpl; first by auto. rewrite fill_app /=. intros ?%head_ctx_step_val; eauto using fill_val. @@ -168,9 +175,10 @@ Section ectxi_language. intros e t1. rewrite IH. apply ectxi_language_mixin. - apply ectxi_language_mixin. - apply ectxi_language_mixin. + (* - apply ectxi_language_mixin. *) Qed. - Canonical Structure ectxi_lang_ectx := EctxLanguage head_step config_step locale_of ectxi_lang_ectx_mixin. + Canonical Structure ectxi_lang_ectx := EctxLanguage head_step config_step locale_of (* config_enabled *) ectxi_lang_ectx_mixin. Canonical Structure ectxi_lang := LanguageOfEctx ectxi_lang_ectx. Lemma fill_not_val K e : to_val e = None → to_val (fill K e) = None. @@ -192,7 +200,7 @@ Coercion ectxi_lang_ectx : ectxiLanguage >-> ectxLanguage. Coercion ectxi_lang : ectxiLanguage >-> language. Definition EctxLanguageOfEctxi (Λ : ectxiLanguage) : ectxLanguage := - let '@EctxiLanguage E V C St L of_val to_val fill head config locale_of mix := Λ in - @EctxLanguage E V (list C) St L of_val to_val _ _ _ _ config locale_of + let '@EctxiLanguage E V C St L action config_label of_val to_val fill head config locale_of (* config_enabled *) mix := Λ in + @EctxLanguage E V (list C) St L action config_label of_val to_val _ _ _ _ config locale_of (* config_enabled *) (@ectxi_lang_ectx_mixin - (@EctxiLanguage E V C St L of_val to_val fill head config locale_of mix)). + (@EctxiLanguage E V C St L action config_label of_val to_val fill head config locale_of (* config_enabled *) mix)). diff --git a/trillium/program_logic/language.v b/trillium/program_logic/language.v index 357715c..fcf1107 100644 --- a/trillium/program_logic/language.v +++ b/trillium/program_logic/language.v @@ -57,14 +57,17 @@ Notation prefixes l := (prefixes_from [] l). Section language_mixin. Context {expr val ectx state : Type}. Context {locale : Type}. + Context {action : Type}. + Context {config_label : Type}. Context (of_val : val → expr). Context (to_val : expr → option val). - Context (prim_step : expr → state → expr → state → list expr → Prop). - Context (config_step : state → state → Prop). + Context (prim_step : expr → state → option action → expr → state → list expr → Prop). + Context (config_step : state → config_label → state → Prop). Context (locale_of : list expr -> expr -> locale). + (* Context (config_enabled : config_label → state → Prop). *) (** Evaluation contexts: we need to include them in the definition of the language because they are used in the program logic for forming @@ -79,15 +82,15 @@ Section language_mixin. Record LanguageMixin := { mixin_to_of_val v : to_val (of_val v) = Some v; mixin_of_to_val e v : to_val e = Some v → of_val v = e; - mixin_val_stuck e σ e' σ' efs : prim_step e σ e' σ' efs → to_val e = None; + mixin_val_stuck e σ α e' σ' efs : prim_step e σ α e' σ' efs → to_val e = None; mixin_is_eval_ctx K : (∀ e, to_val e = None → to_val (ectx_fill K e) = None) ∧ - (∀ e1 σ1 e2 σ2 efs, - prim_step e1 σ1 e2 σ2 efs → - prim_step (ectx_fill K e1) σ1 (ectx_fill K e2) σ2 efs) ∧ - (∀ e1' σ1 e2 σ2 efs, - to_val e1' = None → prim_step (ectx_fill K e1') σ1 e2 σ2 efs → - ∃ e2', e2 = ectx_fill K e2' ∧ prim_step e1' σ1 e2' σ2 efs); + (∀ e1 σ1 α e2 σ2 efs, + prim_step e1 σ1 α e2 σ2 efs → + prim_step (ectx_fill K e1) σ1 α (ectx_fill K e2) σ2 efs) ∧ + (∀ e1' σ1 α e2 σ2 efs, + to_val e1' = None → prim_step (ectx_fill K e1') σ1 α e2 σ2 efs → + ∃ e2', e2 = ectx_fill K e2' ∧ prim_step e1' σ1 α e2' σ2 efs); mixin_ectx_fill_emp e : ectx_fill ectx_emp e = e; mixin_ectx_comp_comp K K' e : ectx_fill (ectx_comp K K') e = ectx_fill K (ectx_fill K' e); @@ -96,32 +99,38 @@ Section language_mixin. to_val e = None → to_val e' = None → ectx_fill K e = ectx_fill K' e' → (∃ K'', K' = ectx_comp K K'') ∨ (∃ K'', K = ectx_comp K' K''); - mixin_locale_step e1 e2 t1 σ1 σ2 efs: prim_step e1 σ1 e2 σ2 efs -> - locale_of t1 e1 = locale_of t1 e2; + mixin_locale_step e1 α e2 t1 σ1 σ2 efs: prim_step e1 σ1 α e2 σ2 efs -> + locale_of t1 e1 = locale_of t1 e2; mixin_locale_fill e K t1: locale_of t1 (ectx_fill K e) = locale_of t1 e; mixin_locale_equiv t t' e: locales_equiv t t' -> locale_of t e = locale_of t' e; mixin_locale_injective tp0 e0 tp1 tp e: (tp, e) ∈ prefixes_from (tp0 ++ [e0]) tp1 -> locale_of tp0 e0 ≠ locale_of tp e; + (* Might need something like this to prove fair derivation for generic + programs and models *) + (* mixin_config_enabled σ lbl : *) + (* (∃ σ', config_step σ lbl σ') ↔ config_enabled lbl σ; *) }. End language_mixin. - Structure language := Language { expr : Type; val : Type; ectx : Type; state : Type; locale : Type; + action : Type; + config_label : Type; of_val : val → expr; to_val : expr → option val; - prim_step : expr → state → expr → state → list expr → Prop; - config_step : state → state → Prop; - locale_of : list expr -> expr -> locale; + prim_step : expr → state → option action → expr → state → list expr → Prop; + config_step : state → config_label → state → Prop; + locale_of : list expr → expr → locale; + (* config_enabled : config_label → state → Prop; *) ectx_comp : ectx → ectx → ectx; ectx_emp : ectx; ectx_fill : ectx → expr → expr; language_mixin : - LanguageMixin of_val to_val prim_step locale_of ectx_comp ectx_emp ectx_fill + LanguageMixin of_val to_val prim_step (* config_step*) locale_of (* config_enabled *) ectx_comp ectx_emp ectx_fill }. Declare Scope expr_scope. @@ -132,15 +141,16 @@ Declare Scope val_scope. Delimit Scope val_scope with V. Bind Scope val_scope with val. -Arguments Language {_ _ _ _ _ _ _} _ {_ _ _} _. +Arguments Language {_ _ _ _ _ _ _ _ _} prim_step config_step {_ _ (* _ *)} _ _ _. Arguments of_val {_} _. Arguments to_val {_} _. Arguments prim_step {_} _ _ _ _ _. -Arguments config_step {_} _ _. +Arguments config_step {_} _ _ _. Arguments ectx_comp {_} _ _. Arguments ectx_emp {_}. Arguments ectx_fill {_} _ _. Arguments locale_of {_} _ _. +(* Arguments config_enabled {_} _ _. *) Notation locales_equiv t0 t0' := (Forall2 (λ '(t, e) '(t', e'), locale_of t e = locale_of t' e') (prefixes t0) (prefixes t0')). @@ -156,12 +166,12 @@ Inductive atomicity := StronglyAtomic | WeaklyAtomic. Record is_an_eval_ctx {Λ : language} (K : expr Λ → expr Λ) := { is_an_eval_ctx_fill_not_val e : to_val e = None → to_val (K e) = None; - is_an_eval_ctx_fill_step e1 σ1 e2 σ2 efs : - prim_step e1 σ1 e2 σ2 efs → - prim_step (K e1) σ1 (K e2) σ2 efs; - is_an_eval_ctx_fill_step_inv e1' σ1 e2 σ2 efs : - to_val e1' = None → prim_step (K e1') σ1 e2 σ2 efs → - ∃ e2', e2 = K e2' ∧ prim_step e1' σ1 e2' σ2 efs + is_an_eval_ctx_fill_step e1 σ1 α e2 σ2 efs : + prim_step e1 σ1 α e2 σ2 efs → + prim_step (K e1) σ1 α (K e2) σ2 efs; + is_an_eval_ctx_fill_step_inv e1' σ1 α e2 σ2 efs : + to_val e1' = None → prim_step (K e1') σ1 α e2 σ2 efs → + ∃ e2', e2 = K e2' ∧ prim_step e1' σ1 α e2' σ2 efs }. Global Arguments is_an_eval_ctx_fill_not_val {_ _} _. @@ -178,7 +188,7 @@ Section language. Proof. apply language_mixin. Qed. Lemma of_to_val e v : to_val e = Some v → of_val v = e. Proof. apply language_mixin. Qed. - Lemma val_stuck e σ e' σ' efs : prim_step e σ e' σ' efs → to_val e = None. + Lemma val_stuck e σ α e' σ' efs : prim_step e σ α e' σ' efs → to_val e = None. Proof. apply language_mixin. Qed. Lemma is_eval_ctx K : is_an_eval_ctx (ectx_fill K). Proof. split; apply language_mixin. Qed. @@ -198,13 +208,13 @@ Section language. Lemma fill_not_val K e : to_val e = None → to_val (ectx_fill K e) = None. Proof. apply is_an_eval_ctx_fill_not_val, is_eval_ctx. Qed. - Lemma fill_step K e1 σ1 e2 σ2 efs : - prim_step e1 σ1 e2 σ2 efs → - prim_step (ectx_fill K e1) σ1 (ectx_fill K e2) σ2 efs. + Lemma fill_step K e1 σ1 α e2 σ2 efs : + prim_step e1 σ1 α e2 σ2 efs → + prim_step (ectx_fill K e1) σ1 α (ectx_fill K e2) σ2 efs. Proof. apply is_an_eval_ctx_fill_step, is_eval_ctx. Qed. - Lemma fill_step_inv K e1' σ1 e2 σ2 efs : - to_val e1' = None → prim_step (ectx_fill K e1') σ1 e2 σ2 efs → - ∃ e2', e2 = ectx_fill K e2' ∧ prim_step e1' σ1 e2' σ2 efs. + Lemma fill_step_inv K e1' σ1 α e2 σ2 efs : + to_val e1' = None → prim_step (ectx_fill K e1') σ1 α e2 σ2 efs → + ∃ e2', e2 = ectx_fill K e2' ∧ prim_step e1' σ1 α e2' σ2 efs. Proof. apply is_an_eval_ctx_fill_step_inv, is_eval_ctx. Qed. @@ -213,14 +223,14 @@ Section language. Proof. erewrite !mixin_locale_fill; [done | apply language_mixin]. Qed. - Lemma locale_step_preserve e1 e2 σ1 σ2 t1 efs: - prim_step e1 σ1 e2 σ2 efs -> + Lemma locale_step_preserve e1 e2 α σ1 σ2 t1 efs: + prim_step e1 σ1 α e2 σ2 efs -> locale_of t1 e1 = locale_of t1 e2. Proof. intros ?. eapply mixin_locale_step; [apply language_mixin|done]. Qed. - Lemma locale_fill_step e1 e2 σ1 σ2 t1 efs K: - prim_step e1 σ1 e2 σ2 efs -> + Lemma locale_fill_step e1 e2 α σ1 σ2 t1 efs K: + prim_step e1 σ1 α e2 σ2 efs -> locale_of t1 (ectx_fill K e1) = locale_of t1 (ectx_fill K e2). Proof. erewrite !locale_fill. intros ?. by eapply locale_step_preserve. @@ -229,12 +239,12 @@ Section language. Proof. apply language_mixin. Qed. Lemma locale_injective tp0 e0 tp1 tp e : (tp, e) ∈ prefixes_from (tp0 ++ [e0]) tp1 -> locale_of tp0 e0 ≠ locale_of tp e. - Proof. eapply language_mixin. Qed. + Proof. eapply language_mixin. Qed. Definition reducible (e : expr Λ) (σ : state Λ) := - ∃ e' σ' efs, prim_step e σ e' σ' efs. + ∃ α e' σ' efs, prim_step e σ α e' σ' efs. Definition irreducible (e : expr Λ) (σ : state Λ) := - ∀ e' σ' efs, ¬prim_step e σ e' σ' efs. + ∀ α e' σ' efs, ¬prim_step e σ α e' σ' efs. Definition stuck (e : expr Λ) (σ : state Λ) := to_val e = None ∧ irreducible e σ. Definition not_stuck (e : expr Λ) (σ : state Λ) := @@ -252,13 +262,13 @@ Section language. in case `e` reduces to a stuck non-value, there is no proof that the invariants have been established again. *) Class Atomic (a : atomicity) (e : expr Λ) : Prop := - atomic σ e' σ' efs : - prim_step e σ e' σ' efs → + atomic σ α e' σ' efs : + prim_step e σ α e' σ' efs → if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e'). Class StutteringAtomic (a : atomicity) (e : expr Λ) : Prop := - stutteringatomic σ e' σ' efs : - prim_step e σ e' σ' efs → + stutteringatomic σ α e' σ' efs : + prim_step e σ α e' σ' efs → (e' = e ∧ σ' = σ ∧ efs = []) ∨ if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e'). @@ -271,29 +281,31 @@ Section language. Qed. Inductive step (ρ1 : cfg Λ) (ρ2 : cfg Λ) : Prop := - | step_atomic e1 σ1 e2 σ2 efs t1 t2 : + | step_atomic e1 σ1 α e2 σ2 efs t1 t2 : ρ1 = (t1 ++ e1 :: t2, σ1) → ρ2 = (t1 ++ e2 :: t2 ++ efs, σ2) → - prim_step e1 σ1 e2 σ2 efs → + prim_step e1 σ1 α e2 σ2 efs → step ρ1 ρ2 - | step_state σ1 σ2 t : + | step_state σ1 lbl σ2 t : ρ1 = (t, σ1) → ρ2 = (t, σ2) → - config_step σ1 σ2 → + config_step σ1 lbl σ2 → step ρ1 ρ2. Hint Constructors step : core. - Inductive locale_step: cfg Λ -> option(locale Λ) -> cfg Λ -> Prop := - | locale_step_atomic ρ1 ρ2 e1 σ1 e2 σ2 efs t1 t2 : + Definition locale_label Λ : Type := locale Λ * option (action Λ). + + Inductive locale_step: cfg Λ -> (locale_label Λ + config_label Λ) -> cfg Λ -> Prop := + | locale_step_atomic ρ1 ρ2 e1 σ1 α e2 σ2 efs t1 t2 : ρ1 = (t1 ++ e1 :: t2, σ1) → ρ2 = (t1 ++ e2 :: t2 ++ efs, σ2) → - prim_step e1 σ1 e2 σ2 efs → - locale_step ρ1 (Some $ locale_of t1 e1) ρ2 - | locale_step_state ρ1 ρ2 σ1 σ2 t : + prim_step e1 σ1 α e2 σ2 efs → + locale_step ρ1 (inl $ (locale_of t1 e1, α)) ρ2 + | locale_step_state ρ1 ρ2 σ1 lbl σ2 t : ρ1 = (t, σ1) → ρ2 = (t, σ2) → - config_step σ1 σ2 → - locale_step ρ1 None ρ2. + config_step σ1 lbl σ2 → + locale_step ρ1 (inr $ lbl) ρ2. Hint Constructors locale_step : core. Inductive nsteps : nat → cfg Λ → cfg Λ → Prop := @@ -318,9 +330,9 @@ Section language. Lemma not_reducible e σ : ¬reducible e σ ↔ irreducible e σ. Proof. unfold reducible, irreducible. naive_solver. Qed. Lemma reducible_not_val e σ : reducible e σ → to_val e = None. - Proof. intros (?&?&?&?); eauto using val_stuck. Qed. + Proof. intros (?&?&?&?&?); eauto using val_stuck. Qed. Lemma val_irreducible e σ : is_Some (to_val e) → irreducible e σ. - Proof. intros [??] ??? ?%val_stuck. by destruct (to_val e). Qed. + Proof. intros [??] ???? ?%val_stuck. by destruct (to_val e). Qed. Global Instance of_val_inj : Inj (=) (=) (@of_val Λ). Proof. by intros v v' Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed. Lemma not_not_stuck e σ : ¬not_stuck e σ ↔ stuck e σ. @@ -338,7 +350,7 @@ Section language. Proof. unfold StutteringAtomic. destruct a; intros Hat; first tauto. - intros ? ? ? ? [|]%Hat; auto using val_irreducible. + intros ? ? ? ? ? [|]%Hat; auto using val_irreducible. Qed. Lemma reducible_fill K e σ : reducible e σ → reducible (ectx_fill K e) σ. @@ -349,7 +361,7 @@ Section language. Lemma reducible_fill_inv K e σ : to_val e = None → reducible (ectx_fill K e) σ → reducible e σ. Proof. - intros ? (e'&σ'&efs&Hstep); unfold reducible. + intros ? (α&e'&σ'&efs&Hstep); unfold reducible. apply fill_step_inv in Hstep as (e2' & _ & Hstep); eauto. Qed. Lemma irreducible_fill K e σ : @@ -377,7 +389,7 @@ Section language. t1 ≡ₚ t1' → step (t1,σ1) (t2,σ2) → ∃ t2', t2 ≡ₚ t2' ∧ step (t1',σ1) (t2',σ2). Proof. intros Ht Hs. - inversion Hs as [e1 σ1' e2 σ2' efs tl tr ?? Hstep|]; simplify_eq /=. + inversion Hs as [e1 σ1' α e2 σ2' efs tl tr ?? Hstep|]; simplify_eq /=. - move: Ht. rewrite -Permutation_middle (symmetry_iff (≡ₚ)). intros (tl'&tr'&->&Ht)%Permutation_cons_inv_r. exists (tl' ++ e2 :: tr' ++ efs); split; [|by econstructor]. @@ -386,9 +398,9 @@ Section language. econstructor 2; eauto. Qed. - Lemma step_insert i t2 σ2 e e' σ3 efs : + Lemma step_insert i t2 σ2 e α e' σ3 efs : t2 !! i = Some e → - prim_step e σ2 e' σ3 efs → + prim_step e σ2 α e' σ3 efs → step (t2, σ2) (<[i:=e']>t2 ++ efs, σ3). Proof. intros. @@ -400,8 +412,8 @@ Section language. Record pure_step (e1 e2 : expr Λ) := { pure_step_safe σ1 : reducible e1 σ1; - pure_step_det σ1 e2' σ2 efs : - prim_step e1 σ1 e2' σ2 efs → σ2 = σ1 ∧ e2' = e2 ∧ efs = [] + pure_step_det σ1 α e2' σ2 efs : + prim_step e1 σ1 α e2' σ2 efs → σ2 = σ1 ∧ α = None ∧ e2' = e2 ∧ efs = [] }. Notation pure_steps_tp := (Forall2 (rtc pure_step)). @@ -418,11 +430,11 @@ Section language. intros [Hred Hstep]. split. - unfold reducible in *. naive_solver eauto using fill_step. - - intros σ1 e2' σ2 efs Hpstep. - destruct (fill_step_inv K e1 σ1 e2' σ2 efs) + - intros σ1 α e2' σ2 efs Hpstep. + destruct (fill_step_inv K e1 σ1 α e2' σ2 efs) as (e2'' & -> & ?); [|exact Hpstep|]. - + destruct (Hred σ1) as (? & ? & ? & ?); eauto using val_stuck. - + edestruct (Hstep σ1 e2'' σ2 efs) as (-> & -> & ->); auto. + + destruct (Hred σ1) as (? & ? & ? & ? & ?); eauto using val_stuck. + + edestruct (Hstep σ1 α e2'' σ2 efs) as (-> & -> & -> & ->); auto. Qed. Lemma pure_step_nsteps_ctx K n e1 e2 : @@ -457,8 +469,8 @@ Section language. (∃ v, of_val v = e) → is_Some (to_val e). Proof. intros [v <-]. rewrite to_of_val. eauto. Qed. - Lemma prim_step_not_stuck e σ e' σ' efs : - prim_step e σ e' σ' efs → not_stuck e σ. + Lemma prim_step_not_stuck e σ α e' σ' efs : + prim_step e σ α e' σ' efs → not_stuck e σ. Proof. rewrite /not_stuck /reducible. eauto 10. Qed. Lemma rtc_pure_step_val `{!Inhabited (state Λ)} v e : @@ -467,39 +479,40 @@ Section language. intros ?; rewrite <- to_of_val. f_equal; symmetry; eapply rtc_nf; first done. intros [e' [Hstep _]]. - destruct (Hstep inhabitant) as (?&?&?&Hval%val_stuck). + destruct (Hstep inhabitant) as (?&?&?&?&Hval%val_stuck). by rewrite to_of_val in Hval. Qed. + (* FIXME: add a new case *) - (** Let thread pools [t1] and [t3] be such that each thread in [t1] makes - (zero or more) pure steps to the corresponding thread in [t3]. Furthermore, - let [t2] be a thread pool such that [t1] under state [σ1] makes a (single) - step to thread pool [t2] and state [σ2]. In this situation, either the step - from [t1] to [t2] corresponds to one of the pure steps between [t1] and [t3], - or, there is an [i] such that [i]th thread does not participate in the - pure steps between [t1] and [t3] and [t2] corresponds to taking a step in - the [i]th thread starting from [t1]. *) + (** Let thread pools [t1] and [t3] be such that each thread in [t1] makes *) + (* (zero or more) pure steps to the corresponding thread in [t3]. Furthermore, *) + (* let [t2] be a thread pool such that [t1] under state [σ1] makes a (single) *) + (* step to thread pool [t2] and state [σ2]. In this situation, either the step *) + (* from [t1] to [t2] corresponds to one of the pure steps between [t1] and [t3], *) + (* or, there is an [i] such that [i]th thread does not participate in the *) + (* pure steps between [t1] and [t3] and [t2] corresponds to taking a step in *) + (* the [i]th thread starting from [t1]. *) Lemma step_pure_step_tp t1 σ1 t2 σ2 t3 : step (t1, σ1) (t2, σ2) → pure_steps_tp t1 t3 → (σ1 = σ2 ∧ pure_steps_tp t2 t3) ∨ - (∃ i e efs e', + (∃ i e α efs e', t1 !! i = Some e ∧ t3 !! i = Some e ∧ t2 = <[i:=e']>t1 ++ efs ∧ - prim_step e σ1 e' σ2 efs) ∨ config_step σ1 σ2. + prim_step e σ1 α e' σ2 efs) ∨ (∃ lbl, config_step σ1 lbl σ2). Proof. intros Ht Hps. - inversion Ht as [e σ e' σ' efs t11 t12 ?? Hstep|]; simplify_eq/=. + inversion Ht as [e σ α e' σ' efs t11 t12 ?? Hstep|]; simplify_eq/=. - apply Forall2_app_inv_l in Hps as (t31&?&Hpsteps&(e''&t32&Hps&?&->)%Forall2_cons_inv_l&->). destruct Hps as [e|e1 e2 e3 [_ Hprs]]. + right; left. - exists (length t11), e, efs, e'; split_and!; last done. + exists (length t11), e, α, efs, e'; split_and!; last done. * by rewrite lookup_app_r // Nat.sub_diag. * apply Forall2_length in Hpsteps. by rewrite lookup_app_r Hpsteps // Nat.sub_diag. * by rewrite insert_app_r_alt // Nat.sub_diag /= -assoc_L. - + edestruct Hprs as (?&?&?); first done; simplify_eq. + + edestruct Hprs as (?&?&?&?); first done; simplify_eq. left; split; first done. rewrite right_id_L. eauto using Forall2_app. diff --git a/trillium/program_logic/lifting.v b/trillium/program_logic/lifting.v index 31e07b3..2cea77b 100644 --- a/trillium/program_logic/lifting.v +++ b/trillium/program_logic/lifting.v @@ -23,10 +23,10 @@ Lemma wp_lift_step_fupdN s E Φ e1 ζ: ⌜locale_of tp1 (ectx_fill K e1) = ζ⌝ -∗ state_interp extr atr ={E,∅}=∗ ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ - ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅}▷=∗^(S $ trace_length extr) |={∅,E}=> + ∀ α e2 σ2 efs, ⌜prim_step e1 σ1 α e2 σ2 efs⌝ ={∅}▷=∗^(S $ trace_length extr) |={∅,E}=> ∃ δ2 ℓ, state_interp - (trace_extend extr (Some ζ) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) + (trace_extend extr (inl (ζ,α)) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ2) ∗ WP e2 @ s; ζ; E {{ Φ }} ∗ [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ @@ -36,7 +36,7 @@ Proof. rewrite wp_unfold /wp_pre=>->. iIntros "H" (exre atr K tp1 tp2 σ1 Hexvald Hlocale Hexe) "Hsi". iMod ("H" with "[//] [//] [//] Hsi") as "[$ H]". - iIntros "!#" (e2 σ2 efs Hstep). + iIntros "!#" (α e2 σ2 efs Hstep). iMod ("H" with "[//]") as "H". iModIntro; iNext. iApply "H". @@ -50,17 +50,17 @@ Lemma wp_lift_step_fupd s E Φ e1 ζ: ⌜locale_of tp1 (ectx_fill K e1) = ζ⌝ -∗ state_interp extr atr ={E,∅}=∗ ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ - ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅}=∗ ▷ |={∅,E}=> + ∀ α e2 σ2 efs, ⌜prim_step e1 σ1 α e2 σ2 efs⌝ ={∅}=∗ ▷ |={∅,E}=> ∃ δ2 ℓ, state_interp - (trace_extend extr (Some ζ) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) + (trace_extend extr (inl (ζ,α)) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ2) ∗ WP e2 @ s; ζ; E {{ Φ }} ∗ [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ {{ fork_post (locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef) }}) ⊢ WP e1 @ s; ζ; E {{ Φ }}. Proof. - intros ?. rewrite -wp_lift_step_fupdN; [|done]. simpl. do 26 f_equiv. + intros ?. rewrite -wp_lift_step_fupdN; [|done]. simpl. do 28 f_equiv. rewrite -step_fupdN_intro; [|done]. rewrite -bi.laterN_intro. auto. Qed. @@ -76,7 +76,7 @@ Proof. iIntros "H" (ex atr K tp1 tp2 σ Hexvalid Hlocale Hex) "Hsi". iMod ("H" with "[//] [//] Hsi") as %[? Hirr]. iModIntro. iSplit; first done. - iIntros (e2 σ2 efs ?). by case: (Hirr e2 σ2 efs). + iIntros (α e2 σ2 efs ?). by case: (Hirr α e2 σ2 efs). Qed. (** Derived lifting lemmas. *) @@ -88,10 +88,10 @@ Lemma wp_lift_step s E Φ e1 ζ: ⌜locale_of tp1 (ectx_fill K e1) = ζ⌝ -∗ state_interp extr atr ={E,∅}=∗ ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ - ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅,E}=∗ + ▷ ∀ α e2 σ2 efs, ⌜prim_step e1 σ1 α e2 σ2 efs⌝ ={∅,E}=∗ ∃ δ2 ℓ, state_interp - (trace_extend extr (Some ζ) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) + (trace_extend extr (inl (ζ,α)) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ2) ∗ WP e2 @ s; ζ; E {{ Φ }} ∗ [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ @@ -106,8 +106,8 @@ Qed. Lemma wp_lift_pure_step_no_fork `{!AllowsPureStep M Σ} `{!Inhabited (state Λ)} s E E' Φ e1 ζ: (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) → - (∀ σ1 e2 σ2 efs, prim_step e1 σ1 e2 σ2 efs → σ2 = σ1 ∧ efs = []) → - (|={E}[E']▷=> ∀ e2 efs σ, ⌜prim_step e1 σ e2 σ efs⌝ → WP e2 @ s; ζ; E {{ Φ }}) + (∀ σ1 α e2 σ2 efs, prim_step e1 σ1 α e2 σ2 efs → σ2 = σ1 ∧ α = None ∧ efs = []) → + (|={E}[E']▷=> ∀ e2 efs σ, ⌜prim_step e1 σ None e2 σ efs⌝ → WP e2 @ s; ζ; E {{ Φ }}) ⊢ WP e1 @ s; ζ; E {{ Φ }}. Proof. iIntros (Hsafe Hstep) "H". iApply wp_lift_step. @@ -116,8 +116,8 @@ Proof. iMod fupd_mask_subseteq as "Hclose"; last iModIntro; first by set_solver. iSplit. { iPureIntro. destruct s; done. } - iNext. iIntros (e2 σ2 efs ?). - destruct (Hstep σ1 e2 σ2 efs) as (<- & ->); auto. + iNext. iIntros (α e2 σ2 efs ?). + destruct (Hstep σ1 α e2 σ2 efs) as (<- & -> & ->); auto. iMod "Hclose" as "_". iMod "H". iMod (allows_pure_step with "Hsi") as "Hsi"; [done|done|done| |]. { econstructor 1; [done| |by apply fill_step]; by rewrite app_nil_r. } @@ -135,7 +135,7 @@ Proof. iIntros (Hstuck). iApply wp_lift_stuck. - destruct(to_val e) as [v|] eqn:He; last done. rewrite -He. by case: (Hstuck inhabitant). - - iIntros (ex atr K ? tp1 tp2 σ) "_". + - iIntros (ex atr K tp1 tp2 σ ? ?) "_". iMod (fupd_mask_subseteq ∅) as "_"; first set_solver; eauto. Qed. @@ -149,10 +149,10 @@ Lemma wp_lift_atomic_step_fupd {s E1 E2 Φ} e1 ζ: ⌜locale_of tp1 e1 = ζ⌝ → state_interp extr atr ={E1}=∗ ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ - ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={E1}[E2]▷=∗ + ∀ α e2 σ2 efs, ⌜prim_step e1 σ1 α e2 σ2 efs⌝ ={E1}[E2]▷=∗ ∃ δ2 ℓ, state_interp - (trace_extend extr (Some ζ) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) + (trace_extend extr (inl (ζ,α)) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ2) ∗ from_option Φ False (to_val e2) ∗ [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ @@ -165,8 +165,8 @@ Proof. iMod ("H" with "[//] [//] [] Hsi") as "[$ H]". { iPureIntro. by erewrite <-locale_fill. } iMod (fupd_mask_subseteq ∅) as "Hclose"; first set_solver. - iIntros "!>" (e2 σ2 efs ?). iMod "Hclose" as "_". - iMod ("H" $! e2 σ2 efs with "[#]") as "H"; [done|]. + iIntros "!>" (α e2 σ2 efs ?). iMod "Hclose" as "_". + iMod ("H" $! α e2 σ2 efs with "[#]") as "H"; [done|]. iMod (fupd_mask_subseteq ∅) as "Hclose"; [set_solver|]. iIntros "!> !>". iMod "Hclose" as "_". iMod "H" as (st' ℓ) "(? & HQ & $)". destruct (to_val e2) eqn:?; last by iExFalso. @@ -183,10 +183,10 @@ Lemma wp_lift_atomic_step {s E Φ} e1 ζ: ⌜locale_of tp1 e1 = ζ⌝ → state_interp extr atr ={E}=∗ ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ - ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={E}=∗ + ▷ ∀ α e2 σ2 efs, ⌜prim_step e1 σ1 α e2 σ2 efs⌝ ={E}=∗ ∃ δ2 ℓ, state_interp - (trace_extend extr (Some ζ) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) + (trace_extend extr (inl (ζ,α)) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ2) ∗ from_option Φ False (to_val e2) ∗ [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ @@ -202,14 +202,14 @@ Qed. Lemma wp_lift_pure_det_step_no_fork `{!AllowsPureStep M Σ} `{!Inhabited (state Λ)} {s E E' Φ} e1 e2 ζ: (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) → - (∀ σ1 e2' σ2 efs', prim_step e1 σ1 e2' σ2 efs' → - σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) → + (∀ σ1 α e2' σ2 efs', prim_step e1 σ1 α e2' σ2 efs' → + σ2 = σ1 ∧ α = None ∧ e2' = e2 ∧ efs' = []) → (|={E}[E']▷=> WP e2 @ s; ζ; E {{ Φ }}) ⊢ WP e1 @ s; ζ; E {{ Φ }}. Proof. iIntros (? Hpuredet) "H". iApply (wp_lift_pure_step_no_fork s E E'); try done. { naive_solver. } iApply (step_fupd_wand with "H"); iIntros "H". - iIntros (e' efs' σ (?&->&?)%Hpuredet); auto. + iIntros (e' efs' σ (?&Hα&->&?)%Hpuredet); auto. Qed. Lemma wp_pure_step_fupd @@ -222,7 +222,7 @@ Proof. iInduction Hexec as [e|n e1 e2 e3 [Hsafe ?]] "IH"; simpl; first done. iApply wp_lift_pure_det_step_no_fork. - intros σ. specialize (Hsafe σ). destruct s; eauto using reducible_not_val. - - done. + - intros. apply pure_step_det. done. - by iApply (step_fupd_wand with "Hwp"). Qed. diff --git a/trillium/program_logic/traces.v b/trillium/program_logic/traces.v index 99f4fd3..1ac54eb 100644 --- a/trillium/program_logic/traces.v +++ b/trillium/program_logic/traces.v @@ -3,7 +3,9 @@ From trillium.program_logic Require Import language. Import InfListNotations. -Definition execution_trace Λ := finite_trace (cfg Λ) (option (locale Λ)). +Definition ex_label Λ : Type := (locale_label Λ + config_label Λ). + +Definition execution_trace Λ := finite_trace (cfg Λ) (ex_label Λ). Record Model : Type := MkModel { mstate:> Type; @@ -13,7 +15,7 @@ Record Model : Type := MkModel { Arguments mtrans {_} _ _ _. -Notation olocale Λ := (option (locale Λ)). +(* Notation olocale Λ := (option (locale Λ)). *) Notation auxiliary_trace m := (finite_trace m.(mstate) m.(mlabel)). @@ -22,7 +24,8 @@ Section execution_trace. Implicit Types c : cfg Λ. - Definition valid_exec (ex : execution_trace Λ) : Prop := trace_steps locale_step ex. + Definition valid_exec (ex : execution_trace Λ) : Prop := + trace_steps locale_step ex. Lemma valid_singleton_exec c : valid_exec (trace_singleton c). Proof. constructor. Qed. @@ -47,7 +50,7 @@ Section system_trace. Implicit Types ex : execution_trace Λ. Implicit Types atr : auxiliary_trace M. - Implicit Types ζ : olocale Λ. + Implicit Types ζ : ex_label Λ. Implicit Types ℓ : mlabel M. Inductive valid_system_trace : execution_trace Λ → auxiliary_trace M → Prop := @@ -111,7 +114,7 @@ End system_trace. Section simulation. Context {Λ : language} {M : Model}. - Variable (labels_match : olocale Λ → mlabel M → Prop). + Variable (labels_match : ex_label Λ → mlabel M → Prop). Implicit Types ex : execution_trace Λ. Implicit Types atr : auxiliary_trace M. @@ -218,7 +221,7 @@ Section simulation. End simulation. -Definition inf_execution_trace Λ := inflist (olocale Λ * cfg Λ). +Definition inf_execution_trace Λ := inflist (ex_label Λ * cfg Λ). Section inf_execution_trace. Context {Λ : language}. @@ -267,6 +270,24 @@ Lemma valid_inf_system_trace_inv {Λ M} Ψ ex atr. Proof. by inversion 1. Qed. +Lemma valid_inf_system_trace_mono {Λ M} + (Φ Ψ : execution_trace Λ → auxiliary_trace M → Prop) ex atr iex itr : + (∀ ex atr, Φ ex atr → Ψ ex atr) → + valid_inf_system_trace Φ ex atr iex itr → + valid_inf_system_trace Ψ ex atr iex itr. +Proof. + intros Himpl. revert ex atr iex itr. cofix CH. intros ex atr iex itr. + destruct iex as [|[??]], itr as [|[??]]. + - intros Hval. clear CH. constructor. inversion Hval. naive_solver. + - clear CH. intros Hval. inversion Hval. + - clear CH. intros Hval. inversion Hval. + - intros Hval. + econstructor=>//. + + apply Himpl. by inversion Hval; simplify_eq. + + inversion Hval; simplify_eq. unfold trace_ends_in in *. naive_solver. + + inversion Hval; simplify_eq. by apply CH. +Qed. + Section simulation. Context {Λ : language} {M : Model} (φ : execution_trace Λ → auxiliary_trace M → Prop). @@ -274,7 +295,7 @@ Section simulation. Implicit Types ex : execution_trace Λ. Implicit Types iex : inf_execution_trace Λ. Implicit Types atr : auxiliary_trace M. - Implicit Types ζ : olocale Λ. + Implicit Types ζ : ex_label Λ. Implicit Types ℓ : mlabel M. Lemma valid_system_trace_start_or_contract ex atr : @@ -295,7 +316,7 @@ Section simulation. (ex : execution_trace Λ) (atr : auxiliary_trace M) (Hcsm : continued_simulation φ ex atr) (c : cfg Λ) - (ζ: olocale Λ) + (ζ: ex_label Λ) (iex : inf_execution_trace Λ) (Hvex : valid_inf_exec ex (inf_exec_prepend ζ c iex)) : ∃ δℓ, continued_simulation φ (trace_extend ex ζ c) (trace_extend atr δℓ.2 δℓ.1). @@ -308,7 +329,7 @@ Section simulation. (ex : execution_trace Λ) (atr : auxiliary_trace M) (Hcsm : continued_simulation φ ex atr) (c : cfg Λ) - (ζ: olocale Λ) + (ζ: ex_label Λ) (iex : inf_execution_trace Λ) (Hvex : valid_inf_exec ex (inf_exec_prepend ζ c iex)) : (M * mlabel M)%type := @@ -321,7 +342,7 @@ Section simulation. (ex : execution_trace Λ) (atr : auxiliary_trace M) (Hcsm : continued_simulation φ ex atr) (c : cfg Λ) - (ζ: olocale Λ) + (ζ: ex_label Λ) (iex : inf_execution_trace Λ) (Hvex : valid_inf_exec ex (inf_exec_prepend ζ c iex)) : continued_simulation diff --git a/trillium/program_logic/weakestpre.v b/trillium/program_logic/weakestpre.v index e1df9ce..6f350ed 100644 --- a/trillium/program_logic/weakestpre.v +++ b/trillium/program_logic/weakestpre.v @@ -185,11 +185,11 @@ Definition wp_pre `{!irisG Λ AS Σ} (s : stuckness) ⌜trace_ends_in extr (tp1 ++ ectx_fill K e1 :: tp2, σ1)⌝ -∗ state_interp extr atr ={E,∅}=∗ ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ - ∀ e2 σ2 efs, - ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅}▷=∗^(S $ trace_length extr) |={∅,E}=> + ∀ α e2 σ2 efs, + ⌜prim_step e1 σ1 α e2 σ2 efs⌝ ={∅}▷=∗^(S $ trace_length extr) |={∅,E}=> ∃ δ2 ℓ, state_interp - (trace_extend extr (Some ζ) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) + (trace_extend extr (inl (ζ,α)) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ2) ∗ wp E ζ e2 Φ ∗ [∗ list] i ↦ ef ∈ efs, @@ -200,7 +200,7 @@ Definition wp_pre `{!irisG Λ AS Σ} (s : stuckness) #[local] Instance wp_pre_contractive `{!irisG Λ AS Σ} s : Contractive (wp_pre s). Proof. rewrite /wp_pre=> n wp wp' Hwp E e1 ζ Φ /=. - do 26 (f_contractive || f_equiv). + do 28 (f_contractive || f_equiv). induction trace_length as [|k IH]; simpl. - repeat (f_contractive || f_equiv); apply Hwp. - by rewrite -IH. @@ -249,7 +249,7 @@ Qed. Proper (pointwise_relation _ (dist_later n) ==> dist n) (wp (PROP:=iProp Σ) s E ζ e). Proof. intros He Φ Ψ HΦ. rewrite !wp_unfold /wp_pre He /=. - do 27 (f_contractive || f_equiv). + do 29 (f_contractive || f_equiv). induction trace_length as [|k IHk]; simpl; [|by rewrite IHk]. by repeat f_equiv. Qed. @@ -260,7 +260,7 @@ Proof. Qed. Lemma wp_value_inv' s E ζ Φ v : WP of_val v @ s; ζ; E {{ Φ }} -∗ |~{E}~| Φ v. -Proof. by rewrite wp_unfold /wp_pre to_of_val pre_step_unseal. Qed. +Proof. rewrite wp_unfold /wp_pre to_of_val pre_step_unseal. by eauto. Qed. Lemma wp_strong_mono s1 s2 E1 E2 ζ e Φ Ψ : s1 ⊑ s2 → E1 ⊆ E2 → @@ -275,7 +275,7 @@ Proof. iMod (fupd_mask_subseteq E1) as "Hclose"; first done. iMod ("H" with "[//] [//] [//] [$]") as "[% H]". iModIntro. iSplit; [by iPureIntro; destruct s1, s2|]. - iIntros (e2 σ2 efs Hstep). simpl. + iIntros (α e2 σ2 efs Hstep). simpl. iMod ("H" with "[//]") as "H". iIntros "!> !>". iMod "H" as "H". iIntros "!>". iApply (step_fupdN_wand with "[H]"); first by iApply "H". @@ -359,8 +359,8 @@ Proof. iMod "Hmsk". iModIntro. iSplitL "Hnstuck"; first done. - iIntros (e2 σ2 efs Hstep). - destruct (stutteringatomic _ _ _ _ Hstep) as [(?&?&?)|Hs]; simplify_eq/=. + iIntros (α e2 σ2 efs Hstep). + destruct (stutteringatomic _ _ _ _ _ Hstep) as [(?&?&?)|Hs]; simplify_eq/=. - iModIntro; iNext. iMod (allows_stuttering with "Hsi") as "Hsi"; [done|done|done| |]. { econstructor 1; [done| |by apply fill_step]; by rewrite app_nil_r. } @@ -389,7 +389,7 @@ Proof. apply fill_step; done. } { by erewrite <-locale_fill_step. } { done. } - iDestruct "H" as %(? & ? & ? & ?%Hs); done. + iDestruct "H" as %(? & ? & ? & ? & ?%Hs); done. + destruct Hs as [v <-%of_to_val]. rewrite !wp_unfold /wp_pre to_of_val. iMod (pre_step_elim with "Hσ H") as "[Hσ >H]". @@ -411,13 +411,13 @@ Lemma wp_stutteringatomic_take_step state_interp extr atr ={E2}=∗ ∃ Q R, state_interp extr atr ∗ - (∀ c2 δ2 ℓ, + (∀ α c2 δ2 ℓ, ∃ δ', state_interp - (trace_extend extr (Some ζ') c2) + (trace_extend extr (inl (ζ', α)) c2) (trace_extend atr ℓ δ2) ∗ Q ={E2}=∗ state_interp - (trace_extend extr (Some ζ') c2) + (trace_extend extr (inl (ζ',α)) c2) (trace_extend atr stuttering_label δ') ∗ R) ∗ (state_interp extr atr ={E2}=∗ state_interp extr atr ∗ Q) ∗ WP e @ s; ζ; E2 {{ v, R ={E2,E1}=∗ Φ v }}) ⊢ WP e @ s; ζ; E1 {{ Φ }}. @@ -444,7 +444,7 @@ Proof. [set_solver|done|]. iModIntro. iSplit; first done. - iIntros (e2 σ2 efs Hstep). + iIntros (α e2 σ2 efs Hstep). pose proof Hstep as [(?&?&?)|HSA]%stutteringatomic; simplify_eq/=. - iModIntro; iNext. iMod (allows_stuttering with "Hsi") as "Hsi"; [done|done|done| |]. @@ -466,7 +466,7 @@ Proof. iApply (step_fupdN_wand with "[H]"); first by iApply "H". iIntros "H". iMod "H" as (δ3 ℓ) "(Hsi & H & Hefs)". - iDestruct ("Hupdate" $! (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2) δ3 ℓ) + iDestruct ("Hupdate" $! α (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2) δ3 ℓ) as (δ') "Hupdate". iMod ("Hupdate" with "[$HQ $Hsi]") as "(Hsi & HR)". destruct s. @@ -505,8 +505,8 @@ Proof. iMod ("H" with "[//] [//] [//] Hsi") as "[% H]". iModIntro. iSplit; first by iPureIntro. - iIntros (e2 σ2 efs Hstep). - pose proof (atomic _ _ _ _ Hstep) as Hs; simplify_eq/=. + iIntros (α e2 σ2 efs Hstep). + pose proof (atomic _ _ _ _ _ Hstep) as Hs; simplify_eq/=. iMod ("H" with "[//]") as "H". iIntros "!>!>". iMod "H" as "H". iIntros "!>". iApply (step_fupdN_wand with "[H]"); first by iApply "H". @@ -522,7 +522,7 @@ Proof. econstructor; [done|done|]. apply fill_step; done. } { by erewrite <-locale_fill_step. } - iDestruct "H" as %(? & ? & ? & ?%Hs); done. + iDestruct "H" as %(? & ? & ? & ? & ?%Hs); done. - destruct Hs as [v <-%of_to_val]. rewrite !wp_unfold /wp_pre to_of_val. iMod (pre_step_elim with "Hσ H") as "[Hσ >H]"; iModIntro. @@ -542,13 +542,13 @@ Lemma wp_atomic_take_step state_interp extr atr ={E2}=∗ ∃ Q R, state_interp extr atr ∗ - (∀ c2 δ2 ℓ, + (∀ α c2 δ2 ℓ, ∃ δ' ℓ', state_interp - (trace_extend extr (Some ζ') c2) + (trace_extend extr (inl (ζ',α)) c2) (trace_extend atr ℓ δ2) ∗ Q ={E2}=∗ state_interp - (trace_extend extr (Some ζ') c2) + (trace_extend extr (inl (ζ',α)) c2) (trace_extend atr ℓ' δ') ∗ R) ∗ (state_interp extr atr ={E2}=∗ state_interp extr atr ∗ Q) ∗ WP e @ s; ζ; E2 {{ v, R ={E2,E1}=∗ Φ v }}) ⊢ WP e @ s; ζ; E1 {{ Φ }}. @@ -563,14 +563,14 @@ Proof. iMod ("H" with "[//] [//] [//] Hsi") as "[% H]". iModIntro. iSplit; first by iPureIntro. - iIntros (e2 σ2 efs Hstep). - pose proof (atomic _ _ _ _ Hstep) as Hs; simplify_eq/=. + iIntros (α e2 σ2 efs Hstep). + pose proof (atomic _ _ _ _ _ Hstep) as Hs; simplify_eq/=. iMod ("H" with "[//]") as "H". iIntros "!>!>". iMod "H" as "H". iIntros "!>". iApply (step_fupdN_wand with "[H]"); first by iApply "H". iIntros "H". iMod "H" as (δ3 ℓ) "(Hsi & H & Hefs)". - iDestruct ("Hupdate" $! (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2) δ3 ℓ) + iDestruct ("Hupdate" $! α (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2) δ3 ℓ) as (δ' ℓ') "Hupdate". iMod ("Hupdate" with "[$HQ $Hsi]") as "(Hsi & HR)". destruct s. @@ -621,7 +621,7 @@ Proof. { iDestruct "H" as "[Hn _]". iMod ("Hn" with "Hσ") as %?. lia. } iDestruct "H" as "[_ [>HP Hwp]]". iMod ("Hwp" with "[//] [//] [//] [$]") as "[$ H]". iMod "HP". - iIntros "!>" (e2 σ2 efs Hstep). iMod ("H" $! e2 σ2 efs with "[% //]") as "H". + iIntros "!>" (α e2 σ2 efs Hstep). iMod ("H" $! α e2 σ2 efs with "[% //]") as "H". iIntros "!>!>". iMod "H". iMod "HP". iModIntro. revert n Hn. generalize (trace_length extr)=>n0 n Hn. iInduction n as [|n] "IH" forall (n0 Hn). @@ -679,7 +679,7 @@ Proof. rewrite Heqn. iMod ("H" with "[//] [//] [//] Hσ") as (Hstuck) "H". iModIntro. iSplit; [done|]. - iIntros (????). + iIntros (?????). iDestruct ("H" with "[//]") as "H"=> /=. iMod "H". iIntros "!>!>". iMod "H". iIntros "!>". iApply (step_fupdN_wand with "H"). @@ -725,8 +725,8 @@ Proof. { rewrite ectx_comp_comp; done. } iModIntro; iSplit. { iPureIntro. destruct s; first apply reducible_fill; done. } - iIntros (e2 σ2 efs Hstep). - destruct (fill_step_inv K e σ1 e2 σ2 efs) as (e2'&->&?); + iIntros (α e2 σ2 efs Hstep). + destruct (fill_step_inv K e σ1 α e2 σ2 efs) as (e2'&->&?); [done|done|]. iMod ("H" with "[//]") as "H". iIntros "!>!>". iMod "H" as "H". iIntros "!>".