├── .gitattributes ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── _CoqProject ├── cgraphs.opam └── theories ├── cgraphs ├── README.pdf ├── bi.v ├── cgraph.v ├── genericinv.v ├── mapexcl.v ├── multiset.v ├── seplogic.v ├── uforests.v ├── upred.v └── util.v ├── lambdabar ├── README.md ├── compiler.v ├── definitions.v ├── invariant.v ├── langdef.v ├── langtools.v ├── letmacro.v ├── rtypesystem.v ├── sessions.v └── theorems.v ├── locks ├── lambdalock │ ├── definitions.v │ ├── invariant.v │ ├── langdef.v │ ├── langtools.v │ ├── letmacro.v │ ├── rtypesystem.v │ └── theorems.v ├── lambdalockpp │ ├── definitions.v │ ├── invariant.v │ ├── langdef.v │ ├── langtools.v │ ├── letmacro.v │ ├── plan.md │ ├── rtypesystem.v │ └── theorems.v └── paper_locks_annotated.pdf ├── multiparty ├── README.md ├── binary.v ├── definitions.v ├── globaltypes.v ├── invariant.v ├── langdef.v ├── mutil.v ├── paper_multiparty_annotated.pdf ├── progress.v ├── rtypesystem.v ├── theorems.v └── ycombinator.v └── sessiontypes ├── invariant.v ├── langdef.v ├── progress.v ├── rtypesystem.v ├── safety.v └── ycombinator.v /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | *.aux 3 | *.glob 4 | *.v# 5 | *.vo 6 | *.crashcoqide 7 | *.d 8 | *.coq 9 | *.conf 10 | *.cache 11 | .DS_Store 12 | *.vok 13 | *.vos 14 | *.rej 15 | *.zip 16 | .vscode 17 | *.sh -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | All files in this development are distributed under the terms of the 3-clause BSD 2 | license (https://opensource.org/licenses/BSD-3-Clause), included below. 3 | 4 | Copyright: Connectivity graphs developers and contributors 5 | 6 | ------------------------------------------------------------------------------ 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions are met: 10 | * Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | * Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | * Neither the name of the copyright holder nor the names of its contributors 16 | may be used to endorse or promote products derived from this software 17 | without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 23 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 24 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 26 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Forward most targets to Coq makefile (with some trick to make this phony) 2 | %: Makefile.coq phony 3 | +@make -f Makefile.coq $@ 4 | 5 | all: Makefile.coq 6 | +@make -f Makefile.coq all 7 | .PHONY: all 8 | 9 | clean: Makefile.coq 10 | +@make -f Makefile.coq clean 11 | find theories tests \( -name "*.d" -o -name "*.vo" -o -name "*.aux" -o -name "*.cache" -o -name "*.glob" -o -name "*.vio" \) -print -delete || true 12 | rm -f Makefile.coq .lia.cache 13 | .PHONY: clean 14 | 15 | # Create Coq Makefile. 16 | Makefile.coq: _CoqProject Makefile 17 | "$(COQBIN)coq_makefile" -f _CoqProject -o Makefile.coq 18 | 19 | # Install build-dependencies 20 | build-dep/opam: opam Makefile 21 | @echo "# Creating build-dep package." 22 | @mkdir -p build-dep 23 | @sed build-dep/opam 24 | @fgrep builddep build-dep/opam >/dev/null || (echo "sed failed to fix the package name" && exit 1) # sanity check 25 | 26 | build-dep: build-dep/opam phony 27 | @# We want opam to not just instal the build-deps now, but to also keep satisfying these 28 | @# constraints. Otherwise, `opam upgrade` may well update some packages to versions 29 | @# that are incompatible with our build requirements. 30 | @# To achieve this, we create a fake opam package that has our build-dependencies as 31 | @# dependencies, but does not actually install anything itself. 32 | @echo "# Pinning build-dep package." && \ 33 | if opam --version | grep "^1\." -q; then \ 34 | BUILD_DEP_PACKAGE="$$(egrep "^name:" build-dep/opam | sed 's/^name: *"\(.*\)" */\1/')" && \ 35 | opam pin add -k path $(OPAMFLAGS) "$$BUILD_DEP_PACKAGE".dev build-dep && \ 36 | opam reinstall $(OPAMFLAGS) "$$BUILD_DEP_PACKAGE"; \ 37 | else \ 38 | opam install $(OPAMFLAGS) build-dep/; \ 39 | fi 40 | 41 | # Some files that do *not* need to be forwarded to Makefile.coq 42 | Makefile: ; 43 | _CoqProject: ; 44 | opam: ; 45 | 46 | # Phony wildcard targets 47 | phony: ; 48 | .PHONY: phony 49 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Connectivity Graphs Coq Development 2 | 3 | This is the repository for the Connectivity Graphs Coq development. 4 | The source repository can be found at https://github.com/julesjacobs/cgraphs 5 | 6 | The individual components of this repository are in the subfolders of the `theories` folder: 7 | * theories/cgraphs: the generic connectivity graphs library on which the other developments are based. 8 | * theories/multiparty: deadlock freedom for MPGV multiparty session types. 9 | * theories/sessiontypes: deadlock freedom for binary session types. 10 | * theories/lambdabar: deadlock freedom for a language with synchronous barriers. 11 | * theories/locks: deadlock freedom for a language with locks. 12 | 13 | The subfolders contain documentation for each of the individual developments. 14 | 15 | To build the code, install the opam package manager, and then execute the following in the root folder: 16 | 17 | opam repo add coq-released https://coq.inria.fr/opam/released 18 | opam install . 19 | 20 | Alternatively, install the following dependencies: 21 | * Coq 22 | * std++ 23 | * Iris 24 | (see cgraphs.opam for versions) 25 | 26 | These can be installed by running: 27 | 28 | opam repo add coq-released https://coq.inria.fr/opam/released 29 | opam install coq-iris 30 | 31 | You can then compile this project with `make`. -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -Q theories cgraphs 2 | # We sometimes want to locally override notation (e.g. in proofmode/base.v, bi/embedding.v), and there 3 | # is no good way to do that with scopes. 4 | -arg -w -arg -notation-overridden 5 | # non-canonical projections (https://github.com/coq/coq/pull/10076) do not exist yet in 8.9. 6 | -arg -w -arg -redundant-canonical-projection 7 | # change_no_check does not exist yet in 8.9. 8 | -arg -w -arg -convert_concl_no_check 9 | # "Declare Scope" does not exist yet in 8.9. 10 | -arg -w -arg -undeclared-scope 11 | -arg -w -arg -cannot-define-projection 12 | # We have ambiguous paths and so far it is not even clear what they are (https://gitlab.mpi-sws.org/iris/iris/issues/240). 13 | -arg -w -arg -ambiguous-paths 14 | -arg -native-compiler -arg no 15 | 16 | theories/cgraphs/multiset.v 17 | theories/cgraphs/util.v 18 | theories/cgraphs/mapexcl.v 19 | theories/cgraphs/uforests.v 20 | theories/cgraphs/upred.v 21 | theories/cgraphs/bi.v 22 | theories/cgraphs/seplogic.v 23 | theories/cgraphs/cgraph.v 24 | theories/cgraphs/genericinv.v 25 | 26 | # theories/sessiontypes/langdef.v 27 | # theories/sessiontypes/rtypesystem.v 28 | # theories/sessiontypes/invariant.v 29 | # theories/sessiontypes/progress.v 30 | # theories/sessiontypes/safety.v 31 | # theories/sessiontypes/ycombinator.v 32 | # 33 | # theories/multiparty/mutil.v 34 | # theories/multiparty/langdef.v 35 | # theories/multiparty/definitions.v 36 | # theories/multiparty/rtypesystem.v 37 | # theories/multiparty/invariant.v 38 | # theories/multiparty/progress.v 39 | # theories/multiparty/ycombinator.v 40 | # theories/multiparty/globaltypes.v 41 | # theories/multiparty/binary.v 42 | # theories/multiparty/theorems.v 43 | # 44 | # theories/lambdabar/langtools.v 45 | # theories/lambdabar/langdef.v 46 | # theories/lambdabar/definitions.v 47 | # theories/lambdabar/rtypesystem.v 48 | # theories/lambdabar/invariant.v 49 | # theories/lambdabar/theorems.v 50 | # theories/lambdabar/sessions.v 51 | # theories/lambdabar/letmacro.v 52 | # theories/lambdabar/compiler.v 53 | 54 | # theories/locks/lambdalock/langtools.v 55 | # theories/locks/lambdalock/langdef.v 56 | # theories/locks/lambdalock/definitions.v 57 | # theories/locks/lambdalock/rtypesystem.v 58 | # theories/locks/lambdalock/invariant.v 59 | # theories/locks/lambdalock/theorems.v 60 | # theories/locks/lambdalock/letmacro.v 61 | # 62 | # theories/locks/lambdalockpp/langtools.v 63 | # theories/locks/lambdalockpp/langdef.v 64 | # theories/locks/lambdalockpp/definitions.v 65 | # theories/locks/lambdalockpp/rtypesystem.v 66 | # theories/locks/lambdalockpp/invariant.v 67 | # theories/locks/lambdalockpp/theorems.v 68 | # theories/locks/lambdalockpp/letmacro.v -------------------------------------------------------------------------------- /cgraphs.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "cgraphs" 3 | version: "0.1" 4 | synopsis: "Deadlock freedom by type checking" 5 | description: """ 6 | Coq mechanization of deadlock freedom proofs using connectivity graphs. 7 | Connectivity graphs are used to show that for various *concurrent* languages, 8 | well-typed programs don't get stuck (= don't deadlock). 9 | """ 10 | maintainer: "Jules Jacobs " 11 | authors: "Jules Jacobs , Robbert Krebbers " 12 | bug-reports: "https://github.com/julesjacobs/cgraphs" 13 | license: "BSD-3-Clause" 14 | homepage: "https://github.com/julesjacobs/cgraphs" 15 | depends: [ "coq-iris" {>= "3.4.0"} ] 16 | build: [ 17 | [make] 18 | ] 19 | dev-repo: "git+https://github.com/julesjacobs/cgraphs.git" 20 | url { 21 | src: "git+https://github.com/julesjacobs/cgraphs.git#v0.1" 22 | } 23 | -------------------------------------------------------------------------------- /theories/cgraphs/README.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/julesjacobs/cgraphs/HEAD/theories/cgraphs/README.pdf -------------------------------------------------------------------------------- /theories/cgraphs/bi.v: -------------------------------------------------------------------------------- 1 | From iris.bi Require Export derived_connectives. 2 | From cgraphs.cgraphs Require Export upred. 3 | From iris.prelude Require Import options. 4 | From iris Require Import bi.extensions. 5 | Import uPred_primitive. 6 | 7 | (** BI instances for [uPred], and re-stating the remaining primitive laws in 8 | terms of the BI interface. This file does *not* unseal. *) 9 | 10 | Notation "⌜⌜ p ⌝⌝" := ( ⌜ p ⌝)%I : bi_scope. 11 | 12 | Local Existing Instance entails_po. 13 | 14 | Lemma uPred_bi_mixin (M : ucmra) : 15 | BiMixin 16 | uPred_entails uPred_emp uPred_pure uPred_and uPred_or uPred_impl 17 | (@uPred_forall M) (@uPred_exist M) uPred_sep uPred_wand 18 | uPred_persistently. 19 | Proof. 20 | split. 21 | - exact: entails_po. 22 | - exact: equiv_spec. 23 | - exact: pure_ne. 24 | - exact: and_ne. 25 | - exact: or_ne. 26 | - exact: impl_ne. 27 | - exact: forall_ne. 28 | - exact: exist_ne. 29 | - exact: sep_ne. 30 | - exact: wand_ne. 31 | - exact: persistently_ne. 32 | - exact: pure_intro. 33 | - exact: pure_elim'. 34 | - exact: and_elim_l. 35 | - exact: and_elim_r. 36 | - exact: and_intro. 37 | - exact: or_intro_l. 38 | - exact: or_intro_r. 39 | - exact: or_elim. 40 | - exact: impl_intro_r. 41 | - exact: impl_elim_l'. 42 | - exact: @forall_intro. 43 | - exact: @forall_elim. 44 | - exact: @exist_intro. 45 | - exact: @exist_elim. 46 | - exact: sep_mono. 47 | - exact: emp_sep_1. 48 | - exact: emp_sep_2. 49 | - exact: sep_comm'. 50 | - exact: sep_assoc'. 51 | - exact: wand_intro_r. 52 | - exact: wand_elim_l'. 53 | - exact: persistently_mono. 54 | - exact: persistently_idemp_2. 55 | - exact: persistently_emp_2. 56 | - exact: persistently_and_2. 57 | - exact: @persistently_exist_1. 58 | - exact: persistently_absorbing. 59 | - exact: persistently_and_sep_elim. 60 | Qed. 61 | 62 | Definition uPred_later {M : ucmra} (P : uPred M) := P. 63 | 64 | Lemma uPred_bi_later_mixin (M : ucmra) : 65 | BiLaterMixin 66 | uPred_entails uPred_pure uPred_or uPred_impl 67 | (@uPred_forall M) (@uPred_exist M) uPred_sep uPred_persistently uPred_later. 68 | Proof. 69 | eapply bi_later_mixin_id; eauto. 70 | apply uPred_bi_mixin. 71 | Qed. 72 | 73 | Canonical Structure uPredI (M : ucmra) : bi := 74 | {| bi_ofe_mixin := ofe_mixin_of (uPred M); 75 | bi_bi_mixin := uPred_bi_mixin M; 76 | bi_bi_later_mixin := uPred_bi_later_mixin M |}. 77 | 78 | Global Instance uPred_pure_forall M : BiPureForall (uPredI M). 79 | Proof. exact: @pure_forall_2. Qed. 80 | 81 | (** Re-state/export lemmas about Iris-specific primitive connectives (own, valid) *) 82 | 83 | Module uPred. 84 | 85 | Section restate. 86 | Context {M : ucmra}. 87 | Implicit Types φ : Prop. 88 | Implicit Types P Q : uPred M. 89 | Implicit Types A : Type. 90 | 91 | (* Force implicit argument M *) 92 | Notation "P ⊢ Q" := (bi_entails (PROP:=uPredI M) P%I Q%I). 93 | Notation "P ⊣⊢ Q" := (equiv (A:=uPredI M) P%I Q%I). 94 | 95 | 96 | (** Consistency/soundness statement *) 97 | Lemma pure_soundness φ : (⊢@{uPredI M} ⌜ φ ⌝) → φ. 98 | Proof. apply pure_soundness. Qed. 99 | 100 | Global Instance ownM_proper : Proper ((≡) ==> (≡)) (@uPred_ownM M). 101 | Proof. apply ownM_proper. Qed. 102 | 103 | Lemma ownM_unit : uPred_ownM ε ⊣⊢ emp. 104 | Proof. apply ownM_unit. Qed. 105 | 106 | Lemma ownM_op (a1 a2 : M) : 107 | uPred_ownM (a1 ⋅ a2) ⊣⊢ uPred_ownM a1 ∗ uPred_ownM a2. 108 | Proof. apply ownM_op. Qed. 109 | 110 | Lemma ownM_valid (x : M) : 111 | uPred_ownM x ⊢ ⌜ ✓ x ⌝. 112 | Proof. apply ownM_valid. Qed. 113 | 114 | End restate. 115 | 116 | (** New unseal tactic that also unfolds the BI layer. 117 | This is used by [base_logic.bupd_alt]. 118 | TODO: Can we get rid of this? *) 119 | Ltac unseal := (* Coq unfold is used to circumvent bug #5699 in rewrite /foo *) 120 | unfold bi_emp, bi_pure, 121 | bi_and, bi_or, bi_impl, bi_forall, bi_exist, 122 | bi_sep, bi_wand, bi_persistently, bi_later; simpl; 123 | unfold uPred_later; simpl; 124 | uPred_primitive.unseal. 125 | 126 | End uPred. 127 | 128 | (* Should go to upred primitive *) 129 | Section upred_lemmas. 130 | Context {A : ucmra}. 131 | Implicit Types P Q : uPred A. 132 | Arguments uPred_holds {_} !_/. 133 | Lemma owned_emp_helper (x : A) : ✓ x -> (uPred_ownM x ⊢ emp) -> x ≡ ε. 134 | Proof. 135 | uPred.unseal. intros ? [HH]. apply HH; simpl; done. 136 | Qed. 137 | 138 | Lemma uPred_emp_holds x : 139 | (emp%I : uPred A) x <-> x ≡ ε. 140 | Proof. by uPred.unseal. Qed. 141 | Lemma uPred_emp_holds_L `{!LeibnizEquiv A} x : 142 | (emp%I : uPred A) x <-> x = ε. 143 | Proof. unfold_leibniz. apply uPred_emp_holds. Qed. 144 | 145 | Lemma uPred_ownM_holds x y : 146 | (uPred_ownM x : uPred A) y <-> x ≡ y. 147 | Proof. 148 | by uPred.unseal. 149 | Qed. 150 | Lemma uPred_ownM_holds_L `{!LeibnizEquiv A} x y : 151 | (uPred_ownM x : uPred A) y <-> x = y. 152 | Proof. 153 | unfold_leibniz. apply uPred_ownM_holds. 154 | Qed. 155 | 156 | Lemma uPred_sep_holds P Q x : 157 | (P ∗ Q)%I x <-> ∃ x1 x2, x ≡ x1 ⋅ x2 ∧ P x1 ∧ Q x2. 158 | Proof. by uPred.unseal. Qed. 159 | Lemma uPred_sep_holds_L `{!LeibnizEquiv A} P Q x : 160 | (P ∗ Q)%I x <-> ∃ x1 x2, x = x1 ⋅ x2 ∧ P x1 ∧ Q x2. 161 | Proof. unfold_leibniz. apply uPred_sep_holds. Qed. 162 | 163 | Lemma uPred_and_holds P Q x : 164 | (P ∧ Q)%I x <-> P x ∧ Q x. 165 | Proof. by uPred.unseal. Qed. 166 | Lemma uPred_pure_holds φ x : 167 | (⌜ φ ⌝ : uPred A)%I x <-> φ. 168 | Proof. by uPred.unseal. Qed. 169 | Lemma uPred_exists_holds {B} (Φ : B -> uPred A) x : 170 | (∃ b, Φ b)%I x <-> ∃ b, Φ b x. 171 | Proof. by uPred.unseal. Qed. 172 | Lemma uPred_forall_holds {B} (Φ : B -> uPred A) x : 173 | (∀ b, Φ b)%I x <-> ∀ b, Φ b x. 174 | Proof. by uPred.unseal. Qed. 175 | Lemma uPred_affinely_pure_holds φ x : 176 | (⌜⌜ φ ⌝⌝ : uPred A)%I x <-> x ≡ ε ∧ φ. 177 | Proof. rewrite /bi_affinely uPred_and_holds uPred_pure_holds uPred_emp_holds. done. Qed. 178 | Lemma uPred_affinely_pure_holds_L `{!LeibnizEquiv A} φ x : 179 | (⌜⌜ φ ⌝⌝ : uPred A)%I x <-> x = ε ∧ φ. 180 | Proof. unfold_leibniz. apply uPred_affinely_pure_holds. Qed. 181 | Lemma uPred_false_holds x : 182 | (False : uPred A)%I x -> False. 183 | Proof. by uPred.unseal. Qed. 184 | End upred_lemmas. -------------------------------------------------------------------------------- /theories/cgraphs/mapexcl.v: -------------------------------------------------------------------------------- 1 | From iris.algebra Require Import excl gmap. 2 | 3 | Definition map_Excl `{Countable K} {V} (m : gmap K V) : gmap K (excl V) := 4 | Excl <$> m. 5 | 6 | Global Instance : Params (@map_Excl) 4 := {}. 7 | 8 | Section map_Excl. 9 | Context `{Countable K} {V : ofe}. 10 | Implicit Type m : gmap K V. 11 | 12 | Global Instance map_excl_proper : Proper ((≡) ==> (≡)) (map_Excl (K:=K) (V:=V)). 13 | Proof. solve_proper. Qed. 14 | 15 | Lemma map_Excl_valid m : ✓ (map_Excl m). 16 | Proof. intros i. rewrite /map_Excl lookup_fmap. destruct (m !! i); done. Qed. 17 | Lemma map_Excl_empty : map_Excl ∅ = (ε : gmap K (excl V)). 18 | Proof. rewrite /map_Excl fmap_empty. done. Qed. 19 | Lemma map_Excl_empty_inv m : map_Excl m ≡ ∅ -> m = ∅. 20 | Proof. 21 | rewrite /map_Excl. intros G. 22 | apply map_empty_equiv_eq in G. 23 | eapply fmap_empty_iff. done. 24 | Qed. 25 | 26 | Lemma map_Excl_injective m1 m2 : 27 | map_Excl m1 ≡ map_Excl m2 -> m1 ≡ m2. 28 | Proof. 29 | rewrite /map_Excl. 30 | intros Hm i. 31 | specialize (Hm i). 32 | rewrite !lookup_fmap in Hm. 33 | destruct (m1 !! i),(m2 !! i); simpl in *; inversion Hm; subst; try done. 34 | inversion H2. subst. rewrite H3. done. 35 | Qed. 36 | Lemma map_Excl_insert m k v : 37 | map_Excl (<[ k := v ]> m) = <[ k := Excl v ]> $ map_Excl m. 38 | Proof. 39 | rewrite /map_Excl fmap_insert //. 40 | Qed. 41 | Lemma map_Excl_insert_op m k v : 42 | m !! k = None -> 43 | map_Excl (<[ k := v ]> m) = {[ k := Excl v ]} ⋅ map_Excl m. 44 | Proof. 45 | intros HH. 46 | rewrite /map_Excl fmap_insert insert_singleton_op // 47 | lookup_fmap HH //. 48 | Qed. 49 | Lemma map_Excl_union m1 m2 : 50 | m1 ##ₘ m2 -> map_Excl (m1 ∪ m2) ≡ map_Excl m1 ⋅ map_Excl m2. 51 | Proof. 52 | induction m1 using map_ind; intros; decompose_map_disjoint. 53 | - by rewrite map_Excl_empty !left_id_L. 54 | - assert ((m ∪ m2) !! i = None). 55 | { rewrite lookup_union H0 H1 //. } 56 | rewrite -insert_union_l !map_Excl_insert_op // IHm1 // assoc //. 57 | Qed. 58 | Lemma map_Excl_valid_op m1 m2 : ✓ (map_Excl m1 ⋅ map_Excl m2) ↔ m1 ##ₘ m2. 59 | Proof. 60 | split; last first. 61 | { intros. rewrite -map_Excl_union //. apply map_Excl_valid. } 62 | induction m1 as [|k x m1 Hm1 IH] using map_ind. 63 | { intros _. apply map_disjoint_empty_l. } 64 | rewrite map_Excl_insert_op // -assoc. intros Hvalid. 65 | apply map_disjoint_insert_l_2; last by eapply IH, cmra_valid_op_r. 66 | apply eq_None_not_Some; intros [x' Hm2]. 67 | move: (Hvalid k). 68 | by rewrite !lookup_op /map_Excl lookup_singleton !lookup_fmap Hm1 Hm2. 69 | Qed. 70 | Lemma map_Excl_singleton_op_inv m me k x : 71 | map_Excl m ≡ {[ k := Excl x ]} ⋅ me -> 72 | ∃ m', m ≡ <[ k := x ]> m' ∧ me ≡ map_Excl m' ∧ m' !! k = None. 73 | Proof. 74 | rewrite /map_Excl. intros HH. 75 | exists (delete k m). 76 | assert (m !! k ≡ Some x). 77 | { specialize (HH k). 78 | revert HH. rewrite lookup_fmap lookup_op lookup_singleton. 79 | case: (m!!k); case:(me!!k); simpl; intros; inversion HH; subst; 80 | inversion H2; subst. rewrite H3. done. } 81 | split_and!. 82 | - intros i. 83 | destruct (decide (k = i)); subst. 84 | + rewrite lookup_insert //. 85 | + rewrite lookup_insert_ne // lookup_delete_ne //. 86 | - intros i. 87 | specialize (HH i). 88 | destruct (decide (k = i)); subst. 89 | + rewrite lookup_fmap lookup_delete. 90 | revert HH. rewrite !lookup_fmap lookup_op lookup_singleton H0 /=. 91 | case: (me !! i); eauto. 92 | intros a HH. inversion HH. subst. inversion H3. 93 | + rewrite lookup_fmap lookup_delete_ne //. 94 | revert HH. rewrite lookup_fmap lookup_op lookup_singleton_ne //. 95 | case: (me !! i); simpl; intros; inversion HH; subst; eauto. 96 | rewrite H3. done. 97 | - rewrite lookup_delete //. 98 | Qed. 99 | Lemma map_Excl_union_inv m me1 me2 : 100 | map_Excl m ≡ me1 ⋅ me2 -> 101 | ∃ m1 m2, m ≡ m1 ∪ m2 ∧ me1 ≡ map_Excl m1 ∧ me2 ≡ map_Excl m2 ∧ m1 ##ₘ m2. 102 | Proof. 103 | revert m. induction me1 as [|k xe me1 Hx IH] using map_ind; intros m. 104 | - rewrite left_id_L. intros Hr1. 105 | exists ∅,m. 106 | rewrite left_id_L map_Excl_empty. split_and!; try solve_map_disjoint. 107 | - rewrite insert_singleton_op // -assoc. 108 | destruct xe as [x|]. 109 | + intros (m' & Hr1 & ? & ?)%map_Excl_singleton_op_inv. 110 | setoid_rewrite Hr1. 111 | destruct (IH m') as (m1 & m2 & Hr2 & Hr3 & Hr4 & ?); first done. 112 | exists (<[ k := x]> m1),m2. 113 | assert (m' !! k ≡ None) as H1'. { rewrite H1 //. } 114 | rewrite ->Hr2 in H1'. 115 | apply None_equiv_eq in H1'. 116 | apply lookup_union_None in H1' as []. 117 | repeat split. 118 | * rewrite Hr2. rewrite insert_union_l //. 119 | * rewrite map_Excl_insert_op //. rewrite Hr3 //. 120 | * done. 121 | * by apply map_disjoint_insert_l. 122 | + intros Hm. assert (✓ (ExclBot : excl V)) as []. 123 | eapply (singleton_valid k), (cmra_valid_op_l _ (me1 ⋅ me2)). 124 | rewrite -Hm. apply map_Excl_valid. 125 | Qed. 126 | Lemma map_Excl_disjoint m1 m2 : 127 | m1 ##ₘ m2 <-> map_Excl m1 ##ₘ map_Excl m2. 128 | Proof. 129 | split; first apply map_disjoint_fmap. 130 | unfold map_Excl. intros G ?. specialize (G i). 131 | rewrite !lookup_fmap in G. 132 | destruct (m1 !! i),(m2 !! i); done. 133 | Qed. 134 | Lemma map_Excl_singleton (a : K) (b : V) : 135 | map_Excl {[ a := b ]} = {[ a := Excl b ]}. 136 | Proof. 137 | rewrite /map_Excl map_fmap_singleton //. 138 | Qed. 139 | Lemma map_Excl_singleton_inv a b m : 140 | map_Excl m ≡ {[ a := Excl b ]} -> m ≡ {[ a := b ]}. 141 | Proof. 142 | intros HH. 143 | intros i. 144 | specialize (HH i). 145 | destruct (decide (i = a)); subst. 146 | - rewrite lookup_singleton. rewrite lookup_fmap in HH. 147 | rewrite lookup_singleton in HH. 148 | inversion HH. subst. inversion H2. subst. 149 | destruct (m !! a) eqn:E; simpl in *. 150 | + inversion HH; subst. 151 | inversion H5; subst. rewrite H6. done. 152 | + inversion HH. 153 | - rewrite lookup_singleton_ne //. 154 | rewrite lookup_singleton_ne // in HH. 155 | unfold map_Excl in HH. 156 | rewrite lookup_fmap in HH. 157 | inversion HH. symmetry in H1. 158 | apply fmap_None in H1. rewrite H1 //. 159 | Qed. 160 | End map_Excl. -------------------------------------------------------------------------------- /theories/cgraphs/seplogic.v: -------------------------------------------------------------------------------- 1 | From stdpp Require Export gmap. 2 | From iris.bi Require Export interface. 3 | From iris.algebra Require Import excl gmap auth. 4 | From iris.proofmode Require Export tactics. 5 | Require Export cgraphs.cgraphs.bi. 6 | Require Export cgraphs.cgraphs.util. 7 | Require Export cgraphs.cgraphs.mapexcl. 8 | Require Export cgraphs.cgraphs.multiset. 9 | 10 | Notation heapT_UR V L := (gmapUR V (exclR L)). 11 | Notation hProp V L := (uPred (heapT_UR V L)). 12 | Notation hPropI V L := (uPredI (heapT_UR V L)). 13 | 14 | Definition own `{Countable V} {L:ofe} (Σ : gmap V L) : hProp V L := 15 | uPred_ownM (map_Excl Σ). 16 | 17 | Global Instance : Params (@own) 4 := {}. 18 | 19 | Definition own_out `{Countable V} {L:ofe} (v : V) (l : L) := own {[ v := l ]}. 20 | 21 | Global Instance : Params (@own) 5 := {}. 22 | 23 | Definition holds `{Countable V} {L:ofe} (P : hProp V L) (Σ : gmap V L) := 24 | uPred_holds P (map_Excl Σ). 25 | 26 | Global Instance : Params (@holds) 4 := {}. 27 | 28 | Section seplogic. 29 | Context `{Countable V}. 30 | Context {L : ofe}. 31 | 32 | Implicit Types P Q : hProp V L. 33 | 34 | Global Instance own_proper : Proper ((≡) ==> (≡)) (own (V:=V) (L:=L)). 35 | Proof. solve_proper. Qed. 36 | 37 | Global Instance own_out_proper v : Proper ((≡) ==> (≡)) (own_out (V:=V) (L:=L) v). 38 | Proof. solve_proper. Qed. 39 | 40 | Lemma own_empty : own ∅ ⊣⊢@{hPropI V L} emp. 41 | Proof. 42 | unfold own. rewrite map_Excl_empty. apply uPred.ownM_unit. 43 | Qed. 44 | 45 | Lemma own_union Σ1 Σ2 : own Σ1 ∗ own Σ2 ⊢@{hPropI V L} own (Σ1 ∪ Σ2). 46 | Proof. 47 | rewrite /own. iIntros "H". iDestruct (uPred.ownM_op with "H") as "H". 48 | iDestruct (uPred_primitive.ownM_valid with "H") as %valid. 49 | rewrite map_Excl_union; first done. by apply map_Excl_valid_op. 50 | Qed. 51 | 52 | Global Instance holds_proper : Proper ((⊣⊢) ==> (≡) ==> (iff)) (holds (V:=V) (L:=L)). 53 | Proof. 54 | intros P1 P2 HP m1 m2 Hm. 55 | trans (holds P1 m2). 56 | - apply uPred_proper. by rewrite Hm. 57 | - apply HP. apply map_Excl_valid. 58 | Qed. 59 | 60 | Lemma sep_holds P Q Σ : 61 | holds (P ∗ Q) Σ <-> ∃ Σ1 Σ2, Σ ≡ Σ1 ∪ Σ2 ∧ Σ1 ##ₘ Σ2 ∧ holds P Σ1 ∧ holds Q Σ2. 62 | Proof. 63 | unfold holds. 64 | rewrite uPred_sep_holds. split. 65 | - intros (?&?&HH&?&?). apply map_Excl_union_inv in HH. 66 | destruct HH as (?&?&?&?&?&?). setoid_rewrite H2. 67 | exists x1,x2. 68 | split_and!; eauto. 69 | + rewrite <-H3; done. 70 | + rewrite <-H4; done. 71 | - intros (?&?&?&?&?&?). subst. eexists _,_. split_and!; eauto. 72 | rewrite H0. apply map_Excl_union. done. 73 | Qed. 74 | 75 | Lemma sep_combine P Q Σ1 Σ2 : 76 | holds P Σ1 -> holds Q Σ2 -> Σ1 ##ₘ Σ2 -> holds (P ∗ Q) (Σ1 ∪ Σ2). 77 | Proof. 78 | intros. 79 | apply sep_holds. 80 | eauto 6. 81 | Qed. 82 | 83 | Lemma emp_holds Σ : 84 | holds (L:=L) (V:=V) emp Σ <-> Σ ≡ ∅. 85 | Proof. 86 | unfold holds. rewrite uPred_emp_holds. split. 87 | - intros HH. apply map_Excl_empty_inv in HH. 88 | eapply map_empty_equiv_eq. done. 89 | - intros ->. rewrite map_Excl_empty. done. 90 | Qed. 91 | 92 | Lemma pure_holds Σ φ: 93 | holds (L:=L) (V:=V) ⌜ φ ⌝ Σ <-> φ. 94 | Proof. 95 | unfold holds. rewrite uPred_pure_holds. done. 96 | Qed. 97 | 98 | Lemma affinely_pure_holds Σ φ: 99 | holds (L:=L) (V:=V) ⌜⌜ φ ⌝⌝ Σ <-> Σ ≡ ∅ ∧ φ. 100 | Proof. 101 | unfold holds. rewrite uPred_affinely_pure_holds. split. 102 | - intros []. split; eauto. eapply map_empty_equiv_eq. apply map_Excl_empty_inv. done. 103 | - intros []. split; eauto. rewrite H0. rewrite map_Excl_empty //. 104 | Qed. 105 | 106 | Lemma exists_holds {B} (Φ : B -> hProp V L) Σ : 107 | holds (∃ b, Φ b) Σ <-> ∃ b, holds (Φ b) Σ. 108 | Proof. 109 | unfold holds. rewrite uPred_exists_holds. done. 110 | Qed. 111 | 112 | Lemma forall_holds {B} (Φ : B -> hProp V L) Σ : 113 | holds (∀ b, Φ b) Σ <-> ∀ b, holds (Φ b) Σ. 114 | Proof. 115 | unfold holds. rewrite uPred_forall_holds. done. 116 | Qed. 117 | 118 | Lemma and_holds (P Q : hProp V L) Σ : 119 | holds (P ∧ Q) Σ <-> holds P Σ ∧ holds Q Σ. 120 | Proof. 121 | rewrite /holds uPred_and_holds. done. 122 | Qed. 123 | 124 | Lemma own_holds (Σ1 Σ2 : gmap V L) : 125 | holds (own Σ1) Σ2 <-> Σ1 ≡ Σ2. 126 | Proof. 127 | unfold holds, own. simpl. 128 | rewrite uPred_ownM_holds. 129 | split. 130 | - eapply map_Excl_injective. 131 | - by intros ->. 132 | Qed. 133 | 134 | Lemma pure_sep_holds φ P Σ : 135 | holds (⌜⌜ φ ⌝⌝ ∗ P) Σ <-> φ ∧ holds P Σ. 136 | Proof. 137 | rewrite sep_holds. 138 | split. 139 | - intros (?&?&->&?&HH&?). 140 | apply affinely_pure_holds in HH as [Q1 Q2]. 141 | rewrite Q1. 142 | split; eauto. 143 | rewrite left_id. eauto. 144 | - intros []. 145 | eexists ∅,Σ. 146 | rewrite left_id. 147 | split; eauto. split; first solve_map_disjoint. 148 | split; eauto. 149 | apply affinely_pure_holds. split; eauto. 150 | Qed. 151 | 152 | Lemma holds_entails P Q Σ : 153 | holds P Σ -> (P ⊢ Q) -> holds Q Σ. 154 | Proof. 155 | unfold holds. 156 | intros. eapply uPred_in_entails; eauto. 157 | apply map_Excl_valid. 158 | Qed. 159 | 160 | Fixpoint unexcl (l : list (V * exclR L)) : list (V * L) := 161 | match l with 162 | | [] => [] 163 | | (v,Excl x)::r => (v,x)::unexcl r 164 | | _::r => unexcl r 165 | end. 166 | 167 | Lemma elem_of_unexcl (l : list (V * exclR L)) (x : V * L) : 168 | x ∈ unexcl l <-> (x.1, Excl x.2) ∈ l. 169 | Proof. 170 | induction l; simpl. 171 | - rewrite !elem_of_nil. done. 172 | - destruct a. destruct c; 173 | rewrite !elem_of_cons !IHl; last set_solver. 174 | split; intros []; simplify_eq; simpl; eauto. 175 | destruct x; eauto. 176 | Qed. 177 | 178 | Lemma map_eq' : ∀ (m1 m2 : gmap V (exclR L)), (∀ i, m1 !! i = m2 !! i) -> m1 = m2. 179 | Proof. apply map_eq. Qed. 180 | 181 | Lemma valid_map_Excl_inv (x : heapT_UR V L) : ✓ x -> ∃ Σ, x = map_Excl Σ. 182 | Proof. 183 | unfold heapT_UR in *. 184 | unfold valid. unfold cmra_valid. simpl. 185 | unfold ucmra_valid. 186 | unfold gmap_valid_instance. unfold valid. 187 | unfold cmra_valid. simpl. 188 | unfold option_valid_instance. unfold valid. 189 | unfold cmra_valid. simpl. 190 | unfold excl_valid_instance. 191 | intros HH. 192 | exists (list_to_map (unexcl (map_to_list x))). 193 | apply map_eq'. intros i. 194 | rewrite lookup_fmap. 195 | specialize (HH i). 196 | destruct (list_to_map (unexcl (map_to_list x)) !! i) eqn:E. 197 | - apply elem_of_list_to_map_2 in E. simpl. 198 | apply elem_of_unexcl in E. simpl in *. 199 | revert E. 200 | rewrite elem_of_map_to_list'. intros. simpl in *. done. 201 | - apply not_elem_of_list_to_map_2 in E. simpl. 202 | rewrite ->elem_of_list_fmap in E. 203 | setoid_rewrite elem_of_unexcl in E. 204 | destruct (x !! i) eqn:F; eauto. 205 | rewrite F in HH. 206 | destruct c eqn:G; try done. 207 | exfalso. 208 | apply E. eexists (i,o). simpl. 209 | split; eauto. 210 | rewrite elem_of_map_to_list'. simpl. done. 211 | Qed. 212 | 213 | Lemma entails_holds P Q : 214 | (∀ Σ, holds P Σ -> holds Q Σ) -> P ⊢ Q. 215 | Proof. 216 | intros HH. 217 | eapply Build_uPred_entails. 218 | intros. 219 | apply valid_map_Excl_inv in H0 as [Σ ->]. 220 | unfold holds in *. eauto. 221 | Qed. 222 | 223 | Lemma false_holds (Σ : gmap V L) : 224 | holds (False%I) Σ -> False. 225 | Proof. apply uPred_false_holds. Qed. 226 | 227 | Definition own_dom A : hProp V L := ∃ Σ, ⌜⌜ A = dom Σ ⌝⌝ ∗ own Σ. 228 | 229 | Lemma own_dom_empty : own_dom ∅ ⊣⊢ emp. 230 | Proof. 231 | iSplit; unfold own_dom; iIntros "H". 232 | - iDestruct "H" as (? Q) "H". 233 | symmetry in Q. apply dom_empty_iff_L in Q as ->. 234 | by iApply own_empty. 235 | - iExists ∅. rewrite own_empty dom_empty_L //. 236 | Qed. 237 | 238 | Lemma own_dom_singleton k v : own {[ k := v ]} ⊢ own_dom {[ k ]}. 239 | Proof. 240 | iIntros "H". iExists {[ k := v ]}. 241 | rewrite dom_singleton_L. iFrame. done. 242 | Qed. 243 | 244 | Lemma own_dom_union A B : own_dom A ∗ own_dom B ⊢ own_dom (A ∪ B). 245 | Proof. 246 | iIntros "[H1 H2]". 247 | iDestruct "H1" as (Σ1 H1) "H1". 248 | iDestruct "H2" as (Σ2 H2) "H2". subst. 249 | iExists (Σ1 ∪ Σ2). rewrite dom_union_L. iSplit; eauto. 250 | iApply own_union. iFrame. 251 | Qed. 252 | End seplogic. -------------------------------------------------------------------------------- /theories/cgraphs/upred.v: -------------------------------------------------------------------------------- 1 | From iris.algebra Require Export cmra. 2 | From iris.bi Require Import notation. 3 | 4 | Record uPred (M : ucmra) : Type := UPred { 5 | uPred_holds :> M → Prop; 6 | uPred_proper : Proper ((≡) ==> iff) uPred_holds 7 | }. 8 | Bind Scope bi_scope with uPred. 9 | Arguments uPred_holds {_} _%I _ : simpl never. 10 | Add Printing Constructor uPred. 11 | Global Instance: Params (@uPred_holds) 2 := {}. 12 | Global Existing Instance uPred_proper. 13 | 14 | Section ofe. 15 | Context {M : ucmra}. 16 | 17 | Inductive uPred_equiv' (P Q : uPred M) : Prop := 18 | { uPred_in_equiv : ∀ x, ✓ x → P x ↔ Q x }. 19 | Instance uPred_equiv : Equiv (uPred M) := uPred_equiv'. 20 | 21 | Instance uPred_equivalence : Equivalence uPred_equiv. 22 | Proof. 23 | split. 24 | + by intros P; split=> x ?. 25 | + by intros P Q HPQ; split=> x ?; symmetry; apply HPQ. 26 | + intros P Q Q' HP HQ; split=> x ?. 27 | by trans (Q x);[apply HP|apply HQ]. 28 | Qed. 29 | 30 | Canonical Structure uPredO : ofe := discreteO (uPred M). 31 | End ofe. 32 | Arguments uPredO : clear implicits. 33 | 34 | (** logical entailement *) 35 | Inductive uPred_entails {M} (P Q : uPred M) : Prop := 36 | { uPred_in_entails : ∀ x, ✓ x → P x → Q x }. 37 | 38 | (** logical connectives *) 39 | Program Definition uPred_emp_def {M} : uPred M := 40 | {| uPred_holds x := x ≡ ε |}. 41 | Solve Obligations with solve_proper. 42 | 43 | Definition uPred_emp_aux : seal (@uPred_emp_def). Proof. by eexists. Qed. 44 | Definition uPred_emp := uPred_emp_aux.(unseal). 45 | Arguments uPred_emp {M}. 46 | Definition uPred_emp_eq : 47 | @uPred_emp = @uPred_emp_def := uPred_emp_aux.(seal_eq). 48 | 49 | Definition uPred_pure_def {M} (φ : Prop) : uPred M := 50 | {| uPred_holds x := φ |}. 51 | Definition uPred_pure_aux : seal (@uPred_pure_def). Proof. by eexists. Qed. 52 | Definition uPred_pure := uPred_pure_aux.(unseal). 53 | Arguments uPred_pure {M}. 54 | Definition uPred_pure_eq : 55 | @uPred_pure = @uPred_pure_def := uPred_pure_aux.(seal_eq). 56 | 57 | Program Definition uPred_and_def {M} (P Q : uPred M) : uPred M := 58 | {| uPred_holds x := P x ∧ Q x |}. 59 | Solve Obligations with solve_proper. 60 | Definition uPred_and_aux : seal (@uPred_and_def). Proof. by eexists. Qed. 61 | Definition uPred_and := uPred_and_aux.(unseal). 62 | Arguments uPred_and {M}. 63 | Definition uPred_and_eq: @uPred_and = @uPred_and_def := uPred_and_aux.(seal_eq). 64 | 65 | Program Definition uPred_or_def {M} (P Q : uPred M) : uPred M := 66 | {| uPred_holds x := P x ∨ Q x |}. 67 | Solve Obligations with solve_proper. 68 | Definition uPred_or_aux : seal (@uPred_or_def). Proof. by eexists. Qed. 69 | Definition uPred_or := uPred_or_aux.(unseal). 70 | Arguments uPred_or {M}. 71 | Definition uPred_or_eq: @uPred_or = @uPred_or_def := uPred_or_aux.(seal_eq). 72 | 73 | Program Definition uPred_impl_def {M} (P Q : uPred M) : uPred M := 74 | {| uPred_holds x := P x → Q x |}. 75 | Next Obligation. 76 | intros M P Q x1 x2 Hx. by rewrite Hx. 77 | Qed. 78 | Definition uPred_impl_aux : seal (@uPred_impl_def). Proof. by eexists. Qed. 79 | Definition uPred_impl := uPred_impl_aux.(unseal). 80 | Arguments uPred_impl {M}. 81 | Definition uPred_impl_eq : 82 | @uPred_impl = @uPred_impl_def := uPred_impl_aux.(seal_eq). 83 | 84 | Program Definition uPred_forall_def {M A} (Ψ : A → uPred M) : uPred M := 85 | {| uPred_holds x := ∀ a, Ψ a x |}. 86 | Next Obligation. 87 | intros M P Q x1 x2 Hx. by setoid_rewrite Hx. 88 | Qed. 89 | Definition uPred_forall_aux : seal (@uPred_forall_def). Proof. by eexists. Qed. 90 | Definition uPred_forall := uPred_forall_aux.(unseal). 91 | Arguments uPred_forall {M A}. 92 | Definition uPred_forall_eq : 93 | @uPred_forall = @uPred_forall_def := uPred_forall_aux.(seal_eq). 94 | 95 | Program Definition uPred_exist_def {M A} (Ψ : A → uPred M) : uPred M := 96 | {| uPred_holds x := ∃ a, Ψ a x |}. 97 | Next Obligation. 98 | intros M P Q x1 x2 Hx. by setoid_rewrite Hx. 99 | Qed. 100 | Definition uPred_exist_aux : seal (@uPred_exist_def). Proof. by eexists. Qed. 101 | Definition uPred_exist := uPred_exist_aux.(unseal). 102 | Arguments uPred_exist {M A}. 103 | Definition uPred_exist_eq: @uPred_exist = @uPred_exist_def := uPred_exist_aux.(seal_eq). 104 | 105 | Program Definition uPred_sep_def {M} (P Q : uPred M) : uPred M := 106 | {| uPred_holds x := ∃ x1 x2, x ≡ x1 ⋅ x2 ∧ P x1 ∧ Q x2 |}. 107 | Solve Obligations with solve_proper. 108 | Definition uPred_sep_aux : seal (@uPred_sep_def). Proof. by eexists. Qed. 109 | Definition uPred_sep := uPred_sep_aux.(unseal). 110 | Arguments uPred_sep {M}. 111 | Definition uPred_sep_eq: @uPred_sep = @uPred_sep_def := uPred_sep_aux.(seal_eq). 112 | 113 | Program Definition uPred_wand_def {M} (P Q : uPred M) : uPred M := 114 | {| uPred_holds x := ∀ x', 115 | ✓ (x ⋅ x') → P x' → Q (x ⋅ x') |}. 116 | Next Obligation. 117 | intros M P Q x1 x2 Hx. by setoid_rewrite Hx. 118 | Qed. 119 | Definition uPred_wand_aux : seal (@uPred_wand_def). Proof. by eexists. Qed. 120 | Definition uPred_wand := uPred_wand_aux.(unseal). 121 | Arguments uPred_wand {M}. 122 | Definition uPred_wand_eq : 123 | @uPred_wand = @uPred_wand_def := uPred_wand_aux.(seal_eq). 124 | 125 | (* Core is strange in a linear setting, 126 | so we have substituted core x ↦ ε in the following definition. 127 | This is essentially plainly. *) 128 | Definition uPred_persistently_def {M} (P : uPred M) : uPred M := 129 | {| uPred_holds x := P ε |}. 130 | Definition uPred_persistently_aux : seal (@uPred_persistently_def). Proof. by eexists. Qed. 131 | Definition uPred_persistently := uPred_persistently_aux.(unseal). 132 | Arguments uPred_persistently {M}. 133 | Definition uPred_persistently_eq : 134 | @uPred_persistently = @uPred_persistently_def := uPred_persistently_aux.(seal_eq). 135 | 136 | Program Definition uPred_ownM_def {M : ucmra} (a : M) : uPred M := 137 | {| uPred_holds x := a ≡ x |}. 138 | Solve Obligations with solve_proper. 139 | Definition uPred_ownM_aux : seal (@uPred_ownM_def). Proof. by eexists. Qed. 140 | Definition uPred_ownM := uPred_ownM_aux.(unseal). 141 | Arguments uPred_ownM {M}. 142 | Definition uPred_ownM_eq : 143 | @uPred_ownM = @uPred_ownM_def := uPred_ownM_aux.(seal_eq). 144 | 145 | (** Primitive logical rules. 146 | These are not directly usable later because they do not refer to the BI 147 | connectives. *) 148 | Module uPred_primitive. 149 | Definition unseal_eqs := 150 | (uPred_emp_eq, uPred_pure_eq, uPred_and_eq, uPred_or_eq, uPred_impl_eq, uPred_forall_eq, 151 | uPred_exist_eq, uPred_sep_eq, uPred_wand_eq, 152 | uPred_persistently_eq, uPred_ownM_eq). 153 | Ltac unseal := 154 | rewrite !unseal_eqs /=. 155 | 156 | Section primitive. 157 | Context {M : ucmra}. 158 | Implicit Types φ : Prop. 159 | Implicit Types P Q : uPred M. 160 | Implicit Types A : Type. 161 | Arguments uPred_holds {_} !_ _ /. 162 | Local Hint Immediate uPred_in_entails : core. 163 | 164 | Notation "P ⊢ Q" := (@uPred_entails M P%I Q%I) : stdpp_scope. 165 | Notation "(⊢)" := (@uPred_entails M) (only parsing) : stdpp_scope. 166 | Notation "P ⊣⊢ Q" := (@uPred_equiv M P%I Q%I) : stdpp_scope. 167 | Notation "(⊣⊢)" := (@uPred_equiv M) (only parsing) : stdpp_scope. 168 | 169 | Notation "'emp'" := uPred_emp : bi_scope. 170 | Notation "'True'" := (uPred_pure True) : bi_scope. 171 | Notation "'False'" := (uPred_pure False) : bi_scope. 172 | Notation "'⌜' φ '⌝'" := (uPred_pure φ%type%stdpp) : bi_scope. 173 | Infix "∧" := uPred_and : bi_scope. 174 | Infix "∨" := uPred_or : bi_scope. 175 | Infix "→" := uPred_impl : bi_scope. 176 | Notation "∀ x .. y , P" := 177 | (uPred_forall (λ x, .. (uPred_forall (λ y, P)) ..)) : bi_scope. 178 | Notation "∃ x .. y , P" := 179 | (uPred_exist (λ x, .. (uPred_exist (λ y, P)) ..)) : bi_scope. 180 | Infix "∗" := uPred_sep : bi_scope. 181 | Infix "-∗" := uPred_wand : bi_scope. 182 | Notation " P" := (uPred_persistently P) : bi_scope. 183 | 184 | (** Entailment *) 185 | Lemma entails_po : PreOrder (⊢). 186 | Proof. 187 | split. 188 | - by intros P; split=> x ?. 189 | - intros P Q Q' HP HQ. split=> x ? ?. by apply HQ, HP. 190 | Qed. 191 | Lemma entails_anti_sym : AntiSymm (⊣⊢) (⊢). 192 | Proof. intros P Q HPQ HQP; split=> x n; by split; [apply HPQ|apply HQP]. Qed. 193 | Lemma equiv_spec P Q : (P ⊣⊢ Q) ↔ (P ⊢ Q) ∧ (Q ⊢ P). 194 | Proof. 195 | split. 196 | - intros HPQ; split; split=> x i; apply HPQ; done. 197 | - intros [??]. exact: entails_anti_sym. 198 | Qed. 199 | Lemma equiv_entails P Q : (P ⊣⊢ Q) ↔ (P ⊢ Q) ∧ (Q ⊢ P). 200 | Proof. 201 | split. 202 | - intros HPQ; split; split=> x i; by apply HPQ. 203 | - intros [??]. exact: entails_anti_sym. 204 | Qed. 205 | 206 | (** Non-expansiveness and setoid morphisms *) 207 | Lemma pure_ne n : Proper (iff ==> dist n) (@uPred_pure M). 208 | Proof. intros φ1 φ2 Hφ. unseal. split. intros ??. simpl. done. Qed. 209 | 210 | Lemma and_ne : NonExpansive2 (@uPred_and M). 211 | Proof. 212 | intros n P P' HP Q Q' HQ; unseal; split=> x ?. 213 | split; (intros [??]; split; [by apply HP|by apply HQ]). 214 | Qed. 215 | 216 | Lemma or_ne : NonExpansive2 (@uPred_or M). 217 | Proof. 218 | intros n P P' HP Q Q' HQ; split=> x ?. 219 | unseal; split; (intros [?|?]; [left; by apply HP|right; by apply HQ]). 220 | Qed. 221 | 222 | Lemma impl_ne : 223 | NonExpansive2 (@uPred_impl M). 224 | Proof. 225 | intros n P P' HP Q Q' HQ; split=> x ?. 226 | unseal; split; intros HPQ ?; apply HQ, HPQ, HP; eauto using cmra_validN_le. 227 | Qed. 228 | 229 | Lemma sep_ne : NonExpansive2 (@uPred_sep M). 230 | Proof. 231 | intros n P P' HP Q Q' HQ; split=> x ?. 232 | unseal; split; intros (x1&x2&?&?&?); ofe_subst x; 233 | exists x1, x2; split_and!; try (apply HP || apply HQ); setoid_subst; 234 | eauto using cmra_valid_op_l, cmra_valid_op_r. 235 | Qed. 236 | 237 | Lemma wand_ne : 238 | NonExpansive2 (@uPred_wand M). 239 | Proof. 240 | intros n P P' HP Q Q' HQ; split=> x ?; unseal; split; intros HPQ x' ??; 241 | apply HQ, HPQ, HP; eauto using cmra_valid_op_r. 242 | Qed. 243 | 244 | Lemma forall_ne A n : 245 | Proper (pointwise_relation _ (dist n) ==> dist n) (@uPred_forall M A). 246 | Proof. 247 | by intros Ψ1 Ψ2 HΨ; unseal; split=> n' x; split; intros HP a; apply HΨ. 248 | Qed. 249 | 250 | Lemma exist_ne A n : 251 | Proper (pointwise_relation _ (dist n) ==> dist n) (@uPred_exist M A). 252 | Proof. 253 | intros Ψ1 Ψ2 HΨ. 254 | unseal; split=> x ?; split; intros [a ?]; exists a; by apply HΨ. 255 | Qed. 256 | 257 | Lemma persistently_ne : NonExpansive (@uPred_persistently M). 258 | Proof. 259 | intros P1 P2 Hp H. 260 | unseal. split=> x?. simpl. split; apply H; eauto using ucmra_unit_valid. 261 | Qed. 262 | 263 | Lemma pure_proper : Proper (iff ==> (≡)) (@uPred_pure M). 264 | Proof. unseal. done. Qed. 265 | 266 | Lemma and_proper : Proper ((≡) ==> (≡) ==> (≡)) (@uPred_and M). 267 | Proof. 268 | unseal. intros ?? [] ?? []. split. naive_solver. 269 | Qed. 270 | 271 | Lemma or_proper : Proper ((≡) ==> (≡) ==> (≡)) (@uPred_or M). 272 | Proof. 273 | unseal. intros ?? [] ?? []. split. naive_solver. 274 | Qed. 275 | 276 | Lemma impl_proper : Proper ((≡) ==> (≡) ==> (≡)) (@uPred_impl M). 277 | Proof. 278 | unseal. intros ?? [] ?? []. split. naive_solver. 279 | Qed. 280 | 281 | Lemma sep_proper : Proper ((≡) ==> (≡) ==> (≡)) (@uPred_sep M). 282 | Proof. 283 | unseal. intros ?? [] ?? []. split. simpl. 284 | intros ??. split; intros (? & ? & ? & ? & ?). 285 | - setoid_subst. naive_solver (eauto using cmra_valid_op_l, cmra_valid_op_r). 286 | - setoid_subst. naive_solver (eauto using cmra_valid_op_l, cmra_valid_op_r). 287 | Qed. 288 | 289 | Lemma wand_proper : Proper ((≡) ==> (≡) ==> (≡)) (@uPred_wand M). 290 | Proof. 291 | unseal. intros ?? [] ?? []. split. naive_solver (eauto using cmra_valid_op_l, cmra_valid_op_r). 292 | Qed. 293 | 294 | Lemma forall_proper A : 295 | Proper (pointwise_relation _ (≡) ==> (≡)) (@uPred_forall M A). 296 | Proof. 297 | by intros Ψ1 Ψ2 HΨ; unseal; split=> n' x; split; intros HP a; apply HΨ. 298 | Qed. 299 | 300 | Lemma exist_proper A : 301 | Proper (pointwise_relation _ (≡) ==> (≡)) (@uPred_exist M A). 302 | Proof. 303 | intros Ψ1 Ψ2 HΨ. 304 | unseal; split=> x ?; split; intros [a ?]; exists a; by apply HΨ. 305 | Qed. 306 | 307 | Lemma persistently_proper : Proper ((≡) ==> (≡)) (@uPred_persistently M). 308 | Proof. 309 | intros ???. unseal. split. intros ??. simpl. destruct H as [H]. 310 | eauto using ucmra_unit_valid. 311 | Qed. 312 | 313 | Lemma ownM_proper : Proper ((≡) ==> (≡)) (@uPred_ownM M). 314 | Proof. 315 | intros ???. unseal. split=> ??. setoid_subst. done. 316 | Qed. 317 | 318 | 319 | (** Introduction and elimination rules *) 320 | Lemma pure_intro φ P : φ → P ⊢ ⌜φ⌝. 321 | Proof. by intros ?; unseal; split. Qed. 322 | Lemma pure_elim' φ P : (φ → True ⊢ P) → ⌜φ⌝ ⊢ P. 323 | Proof. unseal; intros HP; split=> x ??. by apply HP. Qed. 324 | Lemma pure_forall_2 {A} (φ : A → Prop) : (∀ x : A, ⌜φ x⌝) ⊢ ⌜∀ x : A, φ x⌝. 325 | Proof. by unseal. Qed. 326 | 327 | Lemma and_elim_l P Q : P ∧ Q ⊢ P. 328 | Proof. by unseal; split=> x ? [??]. Qed. 329 | Lemma and_elim_r P Q : P ∧ Q ⊢ Q. 330 | Proof. by unseal; split=> x ? [??]. Qed. 331 | Lemma and_intro P Q R : (P ⊢ Q) → (P ⊢ R) → P ⊢ Q ∧ R. 332 | Proof. intros HQ HR; unseal; split=> x ??; by split; [apply HQ|apply HR]. Qed. 333 | 334 | Lemma or_intro_l P Q : P ⊢ P ∨ Q. 335 | Proof. unseal; split=> x ??; left; auto. Qed. 336 | Lemma or_intro_r P Q : Q ⊢ P ∨ Q. 337 | Proof. unseal; split=> x ??; right; auto. Qed. 338 | Lemma or_elim P Q R : (P ⊢ R) → (Q ⊢ R) → P ∨ Q ⊢ R. 339 | Proof. 340 | intros HP HQ; unseal; split=> x ? [?|?]. 341 | - by apply HP. 342 | - by apply HQ. 343 | Qed. 344 | 345 | Lemma impl_intro_r P Q R : (P ∧ Q ⊢ R) → P ⊢ Q → R. 346 | Proof. 347 | unseal; intros HQ; split=> ????. 348 | apply HQ; naive_solver eauto using uPred_mono, cmra_included_includedN, cmra_validN_le. 349 | Qed. 350 | Lemma impl_elim_l' P Q R : (P ⊢ Q → R) → P ∧ Q ⊢ R. 351 | Proof. 352 | unseal; intros HP ; split=> x ? [??]. 353 | apply HP; auto. 354 | Qed. 355 | 356 | Lemma forall_intro {A} P (Ψ : A → uPred M): (∀ a, P ⊢ Ψ a) → P ⊢ ∀ a, Ψ a. 357 | Proof. unseal; intros HPΨ; split=> x ?? a; by apply HPΨ. Qed. 358 | Lemma forall_elim {A} {Ψ : A → uPred M} a : (∀ a, Ψ a) ⊢ Ψ a. 359 | Proof. unseal; split=> x ? HP; apply HP. Qed. 360 | 361 | Lemma exist_intro {A} {Ψ : A → uPred M} a : Ψ a ⊢ ∃ a, Ψ a. 362 | Proof. unseal; split=> x ??; by exists a. Qed. 363 | Lemma exist_elim {A} (Φ : A → uPred M) Q : (∀ a, Φ a ⊢ Q) → (∃ a, Φ a) ⊢ Q. 364 | Proof. unseal; intros HΦΨ; split=> x ? [a ?]; by apply HΦΨ with a. Qed. 365 | 366 | (** BI connectives *) 367 | Lemma sep_mono P P' Q Q' : (P ⊢ Q) → (P' ⊢ Q') → P ∗ P' ⊢ Q ∗ Q'. 368 | Proof. 369 | intros HQ HQ'; unseal. 370 | split; intros x ? (x1&x2&?&?&?); exists x1,x2; setoid_subst; split; 371 | eauto 7 using cmra_valid_op_l, cmra_valid_op_r, uPred_in_entails. 372 | Qed. 373 | Lemma emp_sep_1 P : P ⊢ emp ∗ P. 374 | Proof. 375 | unseal; split; intros x ??. exists ε, x. rewrite left_id; simpl; eauto. 376 | Qed. 377 | Lemma emp_sep_2 P : emp ∗ P ⊢ P. 378 | Proof. 379 | unseal; split; intros x ? (x1&x2&?&?&?); setoid_subst. 380 | by rewrite left_id. 381 | Qed. 382 | Lemma sep_comm' P Q : P ∗ Q ⊢ Q ∗ P. 383 | Proof. 384 | unseal; split; intros x ? (x1&x2&?&?&?); exists x2, x1; by rewrite (comm op). 385 | Qed. 386 | Lemma sep_assoc' P Q R : (P ∗ Q) ∗ R ⊢ P ∗ (Q ∗ R). 387 | Proof. 388 | unseal; split; intros x ? (x1&x2&Hx&(y1&y2&Hy&?&?)&?). 389 | exists y1, (y2 ⋅ x2); split_and?; auto. 390 | + by rewrite (assoc op) -Hy -Hx. 391 | + by exists y2, x2. 392 | Qed. 393 | Lemma wand_intro_r P Q R : (P ∗ Q ⊢ R) → P ⊢ Q -∗ R. 394 | Proof. 395 | unseal=> HPQR; split=> x ?? x' ??; apply HPQR; auto. 396 | exists x, x'; split_and?; auto. 397 | Qed. 398 | Lemma wand_elim_l' P Q R : (P ⊢ Q -∗ R) → P ∗ Q ⊢ R. 399 | Proof. 400 | unseal =>HPQR. split; intros x ? (?&?&?&?&?). setoid_subst. 401 | eapply HPQR; eauto using cmra_valid_op_l. 402 | Qed. 403 | 404 | (** Persistently *) 405 | Lemma persistently_mono P Q : (P ⊢ Q) → P ⊢ Q. 406 | Proof. intros HP; unseal; split=> x ? /=. apply HP, ucmra_unit_valid. Qed. 407 | 408 | Lemma persistently_idemp_2 P : P ⊢ P. 409 | Proof. unseal; split=> x ?? //. Qed. 410 | 411 | Lemma persistently_emp_2 : emp ⊢ emp. 412 | Proof. unseal; by split => n x ? /=. Qed. 413 | 414 | Lemma persistently_and_2 (P Q : uPred M) : ( P ∧ Q) ⊢ ( (P ∧ Q)). 415 | Proof. by unseal. Qed. 416 | 417 | 418 | Lemma persistently_forall_2 {A} (Ψ : A → uPred M) : (∀ a, Ψ a) ⊢ ( ∀ a, Ψ a). 419 | Proof. by unseal. Qed. 420 | Lemma persistently_exist_1 {A} (Ψ : A → uPred M) : ( ∃ a, Ψ a) ⊢ (∃ a, Ψ a). 421 | Proof. by unseal. Qed. 422 | 423 | Lemma persistently_absorbing P Q : P ∗ Q ⊢ P. 424 | Proof. unseal; split=> n x ? /=. naive_solver. Qed. 425 | 426 | Lemma persistently_and_sep_elim P Q : P ∧ Q ⊢ P ∗ Q. 427 | Proof. 428 | unseal; split=> x ? [??]; exists ε, x; simpl in *. by rewrite left_id. 429 | Qed. 430 | 431 | 432 | Lemma persistently_impl_persistently P Q : ( P → Q) ⊢ ( P → Q). 433 | Proof. 434 | unseal; split=> /= x ? HPQ x'. naive_solver. 435 | Qed. 436 | 437 | (** Own *) 438 | Lemma ownM_op (a1 a2 : M) : 439 | uPred_ownM (a1 ⋅ a2) ⊣⊢ uPred_ownM a1 ∗ uPred_ownM a2. 440 | Proof. 441 | unseal; split=> x ?; split. 442 | - intros H. exists a1, a2. simpl in H. 443 | split. { by rewrite H. } 444 | split; by simpl. 445 | - simpl. by intros (x1&x2 & -> & -> & ->). 446 | Qed. 447 | 448 | Lemma ownM_unit : uPred_ownM ε ⊣⊢ emp. 449 | Proof. unseal. split; naive_solver. Qed. 450 | 451 | Lemma ownM_valid x : uPred_ownM x ⊢ ⌜ ✓ x ⌝. 452 | Proof. 453 | unseal. split. simpl. intros. setoid_subst. done. 454 | Qed. 455 | 456 | (** Consistency/soundness statement *) 457 | (** The lemmas [pure_soundness] and [internal_eq_soundness] should become an 458 | instance of [siProp] soundness in the future. *) 459 | Lemma pure_soundness φ : (emp ⊢ ⌜ φ ⌝) → φ. 460 | Proof. unseal=> -[H]. by apply (H ε); simpl; eauto using ucmra_unit_valid. Qed. 461 | 462 | End primitive. 463 | End uPred_primitive. -------------------------------------------------------------------------------- /theories/lambdabar/README.md: -------------------------------------------------------------------------------- 1 | # Artifact for ƛ: A Self-Dual Distillation of Session Types (Pearl) 2 | 3 | Title of the submitted paper: ƛ: A Self-Dual Distillation of Session Types (Pearl) 4 | ECOOP submission number for the paper: #67 5 | We claim the functional and available badges. 6 | 7 | 8 | ## Artifact contents 9 | 10 | This artifact is a Coq mechanization of the ƛ language, and of the theorems about ƛ from the paper. 11 | It consists of Coq source code in the form of .v files. 12 | 13 | Relevant for the artifact reviewers are these files: 14 | * lambdabar/langdef.v -- definition of the language, operational semantics, and type system. 15 | * lambdabar/definitions.v -- the definitions about deadlock freedom / reachability / global progress corresponding to those in the paper. 16 | * lambdabar/theorems.v -- the proofs of the theorems in the paper. 17 | * lambdabar/sessions.v -- the encoding of session types in ƛ. 18 | 19 | Additionally, these proofs make use of lemmas proved in the following files and directories: 20 | * lambdabar/langtools.v -- imports the required libraries 21 | * lambdabar/rtypesystem.v -- definition of the run-time type system. 22 | * lambdabar/invariant.v -- definition and proofs about the configuration invariant. 23 | * cgraphs/**.v -- definitions and lemmas about graphs and separation logic, a modified version of [1] 24 | These files are internal details of the proofs, which are checked by Coq, so the reviewers need not check their correctness. 25 | 26 | We will publish the artifact on DARTS, as suggested by ECOOP's the call for artifacts. 27 | 28 | 29 | ## Getting started 30 | 31 | To test the artifact, you need a recent version of Coq, and an installation of Iris. 32 | We have tested it with Coq 8.14.1 and coq-iris.dev.2022-01-24.0.72a4bd62. 33 | 34 | The installation instructions for Coq can be found at: https://coq.inria.fr/download 35 | The installation instructions for Iris can be found at: https://gitlab.mpi-sws.org/iris/iris/#working-with-iris 36 | 37 | We advise using opam (OCaml package manager) to install Coq and Iris. 38 | On Unix-like platforms it can probably be installed with your OS' package manager, or on OS X with `brew install opam`. 39 | In that case you do not need to install Coq separately; opam will install it when installing Iris. 40 | 41 | After installing these, the development can be built with `make`. 42 | This will let Coq check all the definitions and theorems. 43 | 44 | ## Evaluation instructions 45 | 46 | To ascertain the correctness of the mechanization, the reviewers should check: 47 | 48 | 1. That the language definition in lambdabar/langdef.v corresponds to the language in the paper. 49 | There are minor differences in the presentation, e.g. in the Coq mechanization we have n-ary sum types, 50 | whereas we only have binary sum types in the paper. N-ary sums are strictly stronger. 51 | We use coinduction in Coq to model equi-recursive types. This is again strictly stronger than what is in the paper. 52 | 2. That the definitions in lambdabar/definitions.v correspond to those in the paper. 53 | Each definition has been labeled with a comment indicating which definition in the paper corresponds to it. 54 | 3. That the theorems in lambdabar/theorems.v correspond to those in the paper. 55 | Each theorem has been labeled with a comment indicating which theorem in the paper corresponds to it. 56 | 4. That the encoding of session types in lambdabar/sessions.v corresponds to the encoding in the paper. 57 | Here again the Coq mechanization is slightly stronger, because we mechanize n-ary choice plus message sends. 58 | The encoding of send/choice in the paper are special cases. 59 | 5. That Coq agrees that the theorems are correct, by running `make` without errors. 60 | 61 | 62 | [1] https://zenodo.org/record/5675138 -------------------------------------------------------------------------------- /theories/lambdabar/compiler.v: -------------------------------------------------------------------------------- 1 | From cgraphs.lambdabar Require Export langtools. 2 | From cgraphs.lambdabar Require Export langdef. 3 | 4 | Module GV. 5 | 6 | (* Expressions and values *) 7 | (* ---------------------- *) 8 | 9 | Inductive expr := 10 | | Val : val -> expr 11 | | Var : string -> expr 12 | | Fun : string -> expr -> expr 13 | | App : expr -> expr -> expr 14 | | Unit : expr 15 | | Pair : expr -> expr -> expr 16 | | LetPair : expr -> expr -> expr 17 | | Sum : nat -> expr -> expr 18 | | MatchSum n : expr -> (fin n -> expr) -> expr 19 | | Fork : expr -> expr 20 | | Send : expr -> expr -> expr 21 | | Send' : val -> val -> expr (* We have dummy steps in the operational semantics to get a lockstep correspondence. *) 22 | | Send'' : val -> val -> expr (* This shows precisely which operations do administrative β reductions after compilation. *) 23 | | Send''' : val -> val -> expr 24 | | Send'''' : val -> val -> expr 25 | | Recv : expr -> expr 26 | | Close : expr -> expr 27 | with val := 28 | | FunV : string -> expr -> val 29 | | UnitV : val 30 | | PairV : val -> val -> val 31 | | SumV : nat -> val -> val 32 | | ChanV : nat -> val. 33 | 34 | 35 | (* Operational semantics *) 36 | (* --------------------- *) 37 | 38 | Definition subst (x:string) (a:val) := fix rec e := 39 | match e with 40 | | Val _ => e 41 | | Var x' => if decide (x = x') then Val a else e 42 | | Fun x' e => Fun x' (if decide (x = x') then e else rec e) 43 | | App e1 e2 => App (rec e1) (rec e2) 44 | | Unit => Unit 45 | | Pair e1 e2 => Pair (rec e1) (rec e2) 46 | | LetPair e1 e2 => LetPair (rec e1) (rec e2) 47 | | Sum n e => Sum n (rec e) 48 | | MatchSum n e1 e2 => MatchSum n (rec e1) (rec ∘ e2) 49 | | Fork e => Fork (rec e) 50 | | Send e1 e2 => Send (rec e1) (rec e2) 51 | | Send' v1 v2 => Send' v1 v2 52 | | Send'' v1 v2 => Send'' v1 v2 53 | | Send''' v1 v2 => Send''' v1 v2 54 | | Send'''' v1 v2 => Send'''' v1 v2 55 | | Recv e => Recv (rec e) 56 | | Close e => Close (rec e) 57 | end. 58 | 59 | Inductive pure_step : expr -> expr -> Prop := 60 | | Fun_step x e : 61 | pure_step (Fun x e) (Val $ FunV x e) 62 | | App_step x e a : 63 | pure_step (App (Val $ FunV x e) (Val a)) (subst x a e) 64 | | Unit_step : 65 | pure_step Unit (Val $ UnitV) 66 | | Pair_step v1 v2 : 67 | pure_step (Pair (Val v1) (Val v2)) (Val $ PairV v1 v2) 68 | | LetPair_step v1 v2 e: 69 | pure_step (LetPair (Val $ PairV v1 v2) e) (App (App e (Val v1)) (Val v2)) 70 | | Sum_step n v : 71 | pure_step (Sum n (Val v)) (Val $ SumV n v) 72 | | MatchSum_step n (i : fin n) v es : 73 | pure_step (MatchSum n (Val $ SumV i v) es) (App (es i) (Val v)) 74 | | Send'_step v1 v2 : 75 | pure_step (Send (Val v1) (Val v2)) (Send' v1 v2) 76 | | Send''_step v1 v2 : 77 | pure_step (Send' v1 v2) (Send'' v1 v2) 78 | | Send'''_step v1 v2 : 79 | pure_step (Send'' v1 v2) (Send''' v1 v2) 80 | | Send''''_step v1 v2 : 81 | pure_step (Send''' v1 v2) (Send'''' v1 v2). 82 | 83 | 84 | Inductive ctx1 : (expr -> expr) -> Prop := 85 | | Ctx_App_l e : ctx1 (λ x, App x e) 86 | | Ctx_App_r v : ctx1 (λ x, App (Val v) x) 87 | | Ctx_Pair_l e : ctx1 (λ x, Pair x e) 88 | | Ctx_Pair_r e : ctx1 (λ x, Pair e x) 89 | | Ctx_LetPair e : ctx1 (λ x, LetPair x e) 90 | | Ctx_Sum i : ctx1 (λ x, Sum i x) 91 | | Ctx_MatchSum n es : ctx1 (λ x, MatchSum n x es) 92 | | Ctx_Fork : ctx1 (λ x, Fork x) 93 | | Ctx_Send_l e : ctx1 (λ x, Send x e) 94 | | Ctx_Send_r e : ctx1 (λ x, Send e x) 95 | | Ctx_Recv : ctx1 (λ x, Recv x) 96 | | Ctx_Close : ctx1 (λ x, Close x). 97 | 98 | Inductive ctx : (expr -> expr) -> Prop := 99 | | Ctx_id : ctx id 100 | | Ctx_comp k1 k2 : ctx1 k1 -> ctx k2 -> ctx (k1 ∘ k2). 101 | 102 | (* Buffers are represented as doubly linked lists in the heap. *) 103 | (* When a buffer element has been used, it gets set to `Used`. 104 | THe `Used` marker is then deleted from the heap in a subsequent step. 105 | This maintains the lockstep correspondence. 106 | The Buf' and Buf'' are for the administrative β reductions that messenger threads do. *) 107 | Inductive obj := Thread (e : expr) | Chan | Buf (c1 c2 : nat) (v : val) | Buf' (c1 c2 : nat) (v : val) | Buf'' (c1 c2 : nat) (v : val) | Used. 108 | Definition cfg := gmap nat obj. 109 | 110 | Inductive local_step : nat -> cfg -> cfg -> Prop := 111 | | Pure_step i k e e' : 112 | ctx k -> pure_step e e' -> 113 | local_step i {[ i := Thread (k e) ]} {[ i := Thread (k e') ]} 114 | | Exit_step i v : 115 | local_step i {[ i := Thread (Val v) ]} ∅ 116 | | Buf_done_step i : 117 | local_step i {[ i := Used ]} ∅ 118 | | Fork_step i j n k v : 119 | i ≠ j -> i ≠ n -> j ≠ n -> ctx k -> 120 | local_step i {[ i := Thread (k (Fork (Val v))) ]} 121 | {[ i := Thread (k (Val $ ChanV n)); 122 | j := Thread (App (Val v) (Val $ ChanV n)); 123 | n := Chan ]} 124 | | Send_step i j n k v c : 125 | i ≠ j -> i ≠ n -> j ≠ n -> ctx k -> 126 | local_step i {[ i := Thread (k (Send'''' (ChanV c) v)) ]} 127 | {[ i := Thread (k (Val $ ChanV n)); 128 | j := Buf c n v; 129 | n := Chan ]} 130 | | Buf'_step i n v c : 131 | local_step i {[ i := Buf c n v ]} {[ i := Buf' c n v ]} 132 | | Buf''_step i n v c : 133 | local_step i {[ i := Buf' c n v ]} {[ i := Buf'' c n v ]} 134 | | Recv_step i j n k v c : 135 | i ≠ j -> i ≠ n -> j ≠ n -> ctx k -> 136 | local_step n {[ i := Thread (k (Recv (Val $ ChanV n))); 137 | j := Buf'' n c v; 138 | n := Chan ]} 139 | {[ i := Thread (k $ Val (PairV (ChanV c) v)); 140 | j := Used ]}. 141 | 142 | Inductive step : nat -> cfg -> cfg -> Prop := 143 | | Frame_step ρ ρ' ρf i : 144 | ρ ##ₘ ρf -> ρ' ##ₘ ρf -> 145 | local_step i ρ ρ' -> step i (ρ ∪ ρf) (ρ' ∪ ρf). 146 | 147 | Definition step' ρ ρ' := ∃ i, step i ρ ρ'. 148 | Definition steps := rtc step'. 149 | 150 | End GV. 151 | 152 | Notation Let x e1 e2 := (App (Fun x e2) e1). 153 | Notation Let' x e1 e2 := (App (Val $ FunV x e2) e1). 154 | Notation Let2 x y e1 e2 e3 := (App (App (Val $ FunV x (Fun y e3)) e1) e2). 155 | 156 | Fixpoint compile (e : GV.expr) : expr := 157 | match e with 158 | | GV.Val v => Val $ compile_val v 159 | | GV.Var x => Var x 160 | | GV.Fun x e => Fun x (compile e) 161 | | GV.App e1 e2 => App (compile e1) (compile e2) 162 | | GV.Unit => Unit 163 | | GV.Pair e1 e2 => Pair (compile e1) (compile e2) 164 | | GV.LetPair e1 e2 => LetPair (compile e1) (compile e2) 165 | | GV.Sum n e => Sum n (compile e) 166 | | GV.MatchSum n e f => MatchSum n (compile e) (compile ∘ f) 167 | | GV.Fork e => Fork (compile e) 168 | | GV.Send e1 e2 => 169 | Let2 "x" "y" (compile e1) (compile e2) ( 170 | Fork (Fun "z" (App (Var "x") (Pair (Var "z") (Var "y")))) 171 | ) 172 | | GV.Send' v1 v2 => 173 | Let "y" (Val $ compile_val v2) ( 174 | Fork (Fun "z" (App (Val $ compile_val v1) (Pair (Var "z") (Var "y")))) 175 | ) 176 | | GV.Send'' v1 v2 => 177 | Let' "y" (Val $ compile_val v2) ( 178 | Fork (Fun "z" (App (Val $ compile_val v1) (Pair (Var "z") (Var "y")))) 179 | ) 180 | | GV.Send''' v1 v2 => 181 | Fork (Fun "z" (App (Val $ compile_val v1) (Pair (Var "z") (Val $ compile_val v2)))) 182 | | GV.Send'''' v1 v2 => 183 | Fork (Val $ FunV "z" (App (Val $ compile_val v1) (Pair (Var "z") (Val $ compile_val v2)))) 184 | | GV.Recv e => App (compile e) (Val $ UnitV) 185 | | GV.Close e => App (compile e) (Val $ UnitV) 186 | end 187 | with compile_val (v : GV.val) : val := 188 | match v with 189 | | GV.FunV x e => FunV x (compile e) 190 | | GV.UnitV => UnitV 191 | | GV.PairV v1 v2 => PairV (compile_val v1) (compile_val v2) 192 | | GV.SumV n v => SumV n (compile_val v) 193 | | GV.ChanV n => BarrierV n 194 | end. 195 | 196 | Definition compile_obj (o : GV.obj) : obj := 197 | match o with 198 | | GV.Thread e => Thread (compile e) 199 | | GV.Chan => Barrier 200 | | GV.Buf c n v => Thread (App (Val $ FunV "z" (App (Val $ BarrierV c) (Pair (Var "z") (Val $ compile_val v)))) (Val $ BarrierV n)) 201 | | GV.Buf' c n v => Thread (App (Val $ BarrierV c) (Pair (Val $ BarrierV n) (Val $ compile_val v))) 202 | | GV.Buf'' c n v => Thread (App (Val $ BarrierV c) (Val $ PairV (BarrierV n) (compile_val v))) 203 | | GV.Used => Thread (Val $ UnitV) 204 | end. 205 | 206 | Definition compile_cfg (ρ : GV.cfg) : cfg := compile_obj <$> ρ. 207 | 208 | Lemma compile_ctx k1 : 209 | GV.ctx k1 -> ∃ k2, ctx k2 ∧ ∀ e, compile (k1 e) = k2 (compile e). 210 | Proof. 211 | induction 1; eauto using ctx. 212 | destruct IHctx as [k3 [Hk3 Heq]]. 213 | destruct H; simpl; setoid_rewrite Heq. 214 | - eexists (λ x, App (k3 x) _). split; eauto. 215 | eapply (Ctx_comp (λ x, App x _)); eauto using ctx1. 216 | - eexists (λ x, App _ (k3 x)). split; eauto. 217 | eapply (Ctx_comp (λ x, App _ x)); eauto using ctx1. 218 | - eexists (λ x, Pair (k3 x) _). split; eauto. 219 | eapply (Ctx_comp (λ x, Pair x _)); eauto using ctx1. 220 | - eexists (λ x, Pair _ (k3 x)). split; eauto. 221 | eapply (Ctx_comp (λ x, Pair _ x)); eauto using ctx1. 222 | - eexists (λ x, LetPair (k3 x) _). split; eauto. 223 | eapply (Ctx_comp (λ x, LetPair x _)); eauto using ctx1. 224 | - eexists (λ x, Sum _ (k3 x)). split; eauto. 225 | eapply (Ctx_comp (λ x, Sum _ x)); eauto using ctx1. 226 | - eexists (λ x, MatchSum _ (k3 x) _). split; eauto. 227 | eapply (Ctx_comp (λ x, MatchSum _ x _)); eauto using ctx1. 228 | - eexists (λ x, Fork (k3 x) ). split; eauto. 229 | eapply (Ctx_comp (λ x, Fork x)); eauto using ctx1. 230 | - eexists (λ x, App (App _ (k3 x)) _). split; eauto. 231 | eapply (Ctx_comp (λ x, App x _)); eauto using ctx1. 232 | eapply (Ctx_comp (λ x, App _ x)); eauto using ctx1. 233 | - eexists (λ x, App _ (k3 x)). split; eauto. 234 | eapply (Ctx_comp (λ x, App _ x)); eauto using ctx1. 235 | - eexists (λ x, App (k3 x) _). split; eauto. 236 | eapply (Ctx_comp (λ x, App x _)); eauto using ctx1. 237 | - eexists (λ x, App (k3 x) _). split; eauto. 238 | eapply (Ctx_comp (λ x, App x _)); eauto using ctx1. 239 | Qed. 240 | 241 | Lemma compile_subst x v e : 242 | compile (GV.subst x v e) = subst x (compile_val v) (compile e). 243 | Proof. 244 | induction e; simpl; eauto; repeat case_decide; eauto; 245 | try by f_equal; simplify_eq. 246 | - f_equal; eauto. apply functional_extensionality. eauto. 247 | - do 4 (f_equal; eauto). 248 | Qed. 249 | 250 | Lemma ctx_append k1 k2 : 251 | ctx k1 -> ctx k2 -> ctx (k1 ∘ k2). 252 | Proof. 253 | induction 1; eauto. intros Q. 254 | eapply (Ctx_comp k1); eauto. 255 | Qed. 256 | 257 | Lemma compile_pure_step i e e' k : 258 | ctx k -> 259 | GV.pure_step e e' -> 260 | local_step i {[i := Thread (k (compile e))]} {[i := Thread (k (compile e'))]}. 261 | Proof. 262 | intros Hk []; simpl; try solve [econstructor; eauto using pure_step]. 263 | - rewrite compile_subst. econstructor; eauto using pure_step. 264 | - econstructor; eauto using pure_step. econstructor. 265 | - eapply (Pure_step _ (λ x, k (App x _))); eauto using pure_step. 266 | { eapply ctx_append; eauto. eapply (Ctx_comp (λ x, App x _)); eauto using ctx, ctx1. } 267 | eapply App_step. 268 | - eapply (Pure_step _ (λ x, k (App x _))); eauto using pure_step. 269 | { eapply ctx_append; eauto. eapply (Ctx_comp (λ x, App x _)); eauto using ctx, ctx1. } 270 | - eapply Pure_step; eauto. 271 | eapply App_step. 272 | - eapply (Pure_step _ (λ x, k (Fork x))); eauto using pure_step. 273 | { eapply ctx_append; eauto. eapply Ctx_comp; eauto using ctx, ctx1. } 274 | Qed. 275 | 276 | Lemma compile_step ρ ρ' i : 277 | GV.step i ρ ρ' -> step i (compile_cfg ρ) (compile_cfg ρ'). 278 | Proof. 279 | intros Hstep. 280 | destruct Hstep. 281 | unfold compile_cfg. 282 | rewrite !map_fmap_union. 283 | econstructor; eauto using fmap_map_disjoint. 284 | clear H H0. 285 | destruct H1. 286 | - rewrite !map_fmap_singleton /=. 287 | destruct (compile_ctx k) as [k2 [Hk2 Hk2c]]; first done. 288 | rewrite !Hk2c. 289 | eapply compile_pure_step; done. 290 | - rewrite fmap_empty map_fmap_singleton /=. econstructor. 291 | - rewrite fmap_empty map_fmap_singleton /=. econstructor. 292 | - rewrite !fmap_insert fmap_empty /=. 293 | destruct (compile_ctx k) as [k2 [Hk2 Hk2c]]; first done. 294 | rewrite !Hk2c. 295 | econstructor; eauto. 296 | - rewrite !fmap_insert fmap_empty /=. 297 | destruct (compile_ctx k) as [k2 [Hk2 Hk2c]]; first done. 298 | rewrite !Hk2c /=. 299 | eapply Fork_step; eauto. 300 | - rewrite !map_fmap_singleton /=. 301 | eapply (Pure_step _ id); eauto using ctx. 302 | econstructor. 303 | - rewrite !map_fmap_singleton /=. 304 | eapply Pure_step; eauto using pure_step, ctx, ctx1. 305 | - rewrite !fmap_insert fmap_empty /=. 306 | destruct (compile_ctx k) as [k2 [Hk2 Hk2c]]; first done. 307 | rewrite !Hk2c /=. 308 | eapply (Sync_step i j n k2 id UnitV); eauto using ctx. 309 | Qed. -------------------------------------------------------------------------------- /theories/lambdabar/definitions.v: -------------------------------------------------------------------------------- 1 | From cgraphs.lambdabar Require Export langdef. 2 | 3 | (* The definition of the set of barrier references in an expression. *) 4 | Fixpoint expr_refs e := 5 | match e with 6 | | Val v => val_refs v 7 | | Var x => ∅ 8 | | Fun x e => expr_refs e 9 | | App e1 e2 => expr_refs e1 ∪ expr_refs e2 10 | | Unit => ∅ 11 | | Pair e1 e2 => expr_refs e1 ∪ expr_refs e2 12 | | LetPair e1 e2 => expr_refs e1 ∪ expr_refs e2 13 | | Sum i e => expr_refs e 14 | | MatchSum n e es => expr_refs e ∪ fin_union n (expr_refs ∘ es) 15 | | Fork e => expr_refs e 16 | end 17 | with val_refs v := 18 | match v with 19 | | FunV x e => expr_refs e 20 | | UnitV => ∅ 21 | | PairV v1 v2 => val_refs v1 ∪ val_refs v2 22 | | SumV i v => val_refs v 23 | | BarrierV i => {[ i ]} 24 | end. 25 | 26 | (* Paper definition 2 *) 27 | Definition expr_waiting e j := ∃ k v, ctx k ∧ e = k (App (Val $ BarrierV j) (Val v)). 28 | 29 | Definition waiting (ρ : cfg) (i j : nat) := 30 | match ρ !! i, ρ !! j with 31 | | Some (Thread e), Some Barrier => expr_waiting e j 32 | | Some Barrier, Some (Thread e) => i ∈ expr_refs e ∧ ¬ expr_waiting e i 33 | | _,_ => False 34 | end. 35 | 36 | (* These definitions are not explicitly given in the paper, but we factor them out in Coq *) 37 | Definition can_step (ρ : cfg) (i : nat) := ∃ ρ', step i ρ ρ'. 38 | Definition inactive (ρ : cfg) (i : nat) := ρ !! i = None. 39 | 40 | (* Paper definition 3 *) 41 | Record deadlock (ρ : cfg) (s : nat -> Prop) := { 42 | dl_nostep i : s i -> ¬ can_step ρ i; 43 | dl_waiting i j : waiting ρ i j -> s i -> s j; 44 | }. 45 | 46 | (* Paper definition 4 *) 47 | Definition deadlock_free (ρ : cfg) := 48 | ∀ s, deadlock ρ s -> ∀ i, s i -> inactive ρ i. 49 | 50 | (* Paper definition 5 *) 51 | Inductive reachable (ρ : cfg) : nat -> Prop := 52 | | Can_step_reachable i : 53 | can_step ρ i -> reachable ρ i 54 | | Waiting_reachable i j : 55 | waiting ρ i j -> reachable ρ j -> reachable ρ i. 56 | 57 | (* Paper definition 6 *) 58 | Definition fully_reachable (ρ : cfg) := 59 | ∀ i, inactive ρ i ∨ reachable ρ i. 60 | 61 | (* Paper definition 8 *) 62 | Definition global_progress (ρ : cfg) := 63 | (∀ i, inactive ρ i) ∨ (∃ i, can_step ρ i). 64 | 65 | (* Paper definition 9 *) 66 | Definition type_safety (ρ : cfg) := 67 | ∀ i, inactive ρ i ∨ can_step ρ i ∨ ∃ j, waiting ρ i j. 68 | -------------------------------------------------------------------------------- /theories/lambdabar/invariant.v: -------------------------------------------------------------------------------- 1 | From cgraphs.lambdabar Require Export rtypesystem. 2 | From cgraphs.lambdabar Require Export definitions. 3 | 4 | Definition linv (ρ : cfg) (v : nat) (in_l : multiset labelO) : rProp := 5 | match ρ !! v with 6 | | Some (Thread e) => ⌜⌜ in_l ≡ ε ⌝⌝ ∗ rtyped0 e UnitT 7 | | Some Barrier => ⌜⌜ ∃ t1 t2, in_l ≡ {[ (false,(t1,t2)) ]} ⋅ {[ (false,(t2,t1)) ]} ⌝⌝ 8 | | None => ⌜⌜ in_l ≡ ε ⌝⌝ 9 | end. 10 | 11 | Global Instance lin_Proper ρ v : Proper ((≡) ==> (≡)) (linv ρ v). 12 | Proof. solve_proper. Qed. 13 | 14 | Definition ginv ρ := inv (linv ρ). 15 | 16 | Lemma lookup_union_spec `{Countable K} {V} (m1 m2 : gmap K V) (x : K) : 17 | (m1 ∪ m2) !! x = from_option Some (m2 !! x) (m1 !! x). 18 | Proof. 19 | rewrite lookup_union. 20 | destruct (m1 !! x),(m2 !! x); simpl; eauto. 21 | Qed. 22 | 23 | Ltac sdec := repeat (progress simp || case_decide || done || eauto). 24 | Ltac smap := repeat ( 25 | rewrite lookup_union_spec || 26 | rewrite lookup_alter_spec || 27 | rewrite lookup_insert_spec || 28 | rewrite lookup_delete_spec || 29 | rewrite lookup_empty || sdec). 30 | 31 | 32 | Lemma preservation i ρ ρ' : 33 | step i ρ ρ' -> ginv ρ -> ginv ρ'. 34 | Proof. 35 | intros H Hinv. 36 | destruct H as [ρ ρ' ρf D1 D2 i H]. 37 | destruct H. 38 | - eapply inv_impl; last done. 39 | iIntros (n x) "H". unfold linv. smap. 40 | iDestruct "H" as "[? H]". iFrame. 41 | iDestruct (replacement with "H") as (t) "[H Q]"; first done. 42 | iApply "Q". iApply pure_preservation; done. 43 | - eapply inv_impl; last done. 44 | iIntros (n x) "H". unfold linv. smap; iDestr "H"; 45 | assert (ρf !! n = None) as -> by solve_map_disjoint; eauto. 46 | destruct v; simpl; iDestr "H"; simp. done. 47 | - eapply (inv_alloc_lr i0 n j); 48 | last done; first apply _; first apply _. 49 | + naive_solver. 50 | + iIntros (? ? ?) "H". unfold linv. smap. 51 | + iIntros (?) "H". unfold linv. smap. 52 | assert (ρf !! n = None) as -> by solve_map_disjoint; eauto. 53 | + iIntros (?) "H". unfold linv. smap. 54 | assert (ρf !! j = None) as -> by solve_map_disjoint; eauto. 55 | + iIntros (?) "H". unfold linv. smap. iDestr "H". 56 | iDestruct (replacement with "H") as (t) "[H Q]"; first done. simpl. 57 | iDestr "H". simp. 58 | iExists (false,(t1,t2)), (false,(t2,t1)). 59 | iSplitL "Q". 60 | * iIntros "H". iSplit; first done. 61 | iApply "Q". simpl. eauto. 62 | * iSplit; eauto. 63 | iIntros "Q". iSplit; eauto 10 with iFrame. 64 | - assert (inv (λ k x, 65 | if decide (k = i0) then 66 | ⌜⌜ x ≡ ε ⌝⌝ ∗ ∃ t1 t2, own_out n (true,(t1,t2)) ∗ ∀ e' : expr, rtyped0 e' t2 -∗ rtyped0 (k1 e') UnitT 67 | else if decide (k = n) then 68 | ∃ t1 t2, ⌜⌜ x ≡ {[ (true,(t1,t2)) ]} ⋅ {[ (false,(t2,t1)) ]} ⌝⌝ ∗ 69 | vtyped v1 t1 70 | else if decide (k = j) then 71 | ⌜⌜ x ≡ ε ⌝⌝ ∗ rtyped0 (k2 (App (Val (BarrierV n)) (Val v2))) UnitT 72 | else linv ρf k x 73 | )%I) as Hinv'. 74 | { 75 | eapply (inv_exchange i0 n); last done; [solve_proper|solve_proper|..]. 76 | - simp. smap; unfold linv; smap. 77 | - simp. smap. unfold linv. smap. 78 | iIntros "[% H]". 79 | rewrite replacement; last done. 80 | iDestruct "H" as (t1) "[H1 H2]". simpl. 81 | iDestruct "H1" as (t2 l) "[H1 H3]". 82 | iDestruct "H1" as (t1' t2' ?) "H1". simplify_eq. 83 | iExists _. iFrame. iIntros (x [t1 [t2 ?]]) "". 84 | eapply multiset_xsplit_singleton in H8 as [[]|[]]; simplify_eq. 85 | + iExists _. iSplitL "H2". 86 | * iIntros "H". iSplit; eauto. iExists _,_. iFrame. 87 | * iExists _,_. iFrame. setoid_subst. eauto. 88 | + iExists _. iSplitL "H2". 89 | * iIntros "H". iSplit; eauto. iExists _,_. iFrame. 90 | * iExists _,_. iFrame. setoid_subst. eauto. 91 | } clear Hinv. 92 | 93 | assert (inv (λ k x, 94 | if decide (k = i0) then 95 | ⌜⌜ x ≡ ε ⌝⌝ ∗ ∃ t1 t2, own_out n (true,(t1,t2)) ∗ ∀ e' : expr, rtyped0 e' t2 -∗ rtyped0 (k1 e') UnitT 96 | else if decide (k = n) then 97 | ∃ t1 t2, ⌜⌜ x ≡ {[ (true,(t1,t2)) ]} ⌝⌝ ∗ 98 | vtyped v2 t2 99 | else if decide (k = j) then 100 | ⌜⌜ x ≡ ε ⌝⌝ ∗ rtyped0 (k2 (Val v1)) UnitT 101 | else linv ρf k x 102 | )%I) as Hinv''. 103 | { 104 | eapply (inv_dealloc j n); last done; [solve_proper|solve_proper|..]. 105 | - simp. smap. 106 | - simp. smap. 107 | iIntros "[% H]". 108 | rewrite replacement; last done. 109 | iDestruct "H" as (t1) "[H1 H2]". simpl. 110 | iDestruct "H1" as (t2 l) "[H3 H4]". 111 | iDestruct "H3" as (t1' t2' ?) "H". simplify_eq. 112 | iExists _. iFrame. iIntros (?) "H". 113 | iDestruct "H" as (t1 t2 ?) "H". 114 | eapply multiset_xsplit_singleton in H8 as [[]|[]]; simplify_eq. 115 | iSplitL "H H2". 116 | + iSplit; eauto. iApply "H2". done. 117 | + iExists _,_. iFrame. eauto. 118 | } clear Hinv'. 119 | 120 | eapply (inv_dealloc i0 n); last done; [solve_proper|solve_proper|..]. 121 | + simp. smap; unfold linv; smap. 122 | + simp. smap. 123 | iIntros "[% H]". 124 | iDestruct "H" as (t1 t2) "[H1 H2]". 125 | iExists _. iFrame. iIntros (?) "H". 126 | iDestruct "H" as (t1' t2' ?) "H". 127 | eapply multiset_singleton_mult' in H6 as []. simplify_eq. 128 | unfold linv. smap. 129 | assert (ρf !! n = None) as -> by solve_map_disjoint. 130 | iSplit; eauto. iSplit; eauto. 131 | iApply "H2". simpl. done. 132 | Qed. 133 | 134 | Lemma fresh2 (s : gset nat) : 135 | ∃ x y, x ∉ s ∧ y ∉ s ∧ x ≠ y. 136 | Proof. 137 | exists (fresh s), (fresh (s ∪ {[ fresh s ]})). 138 | split; first apply is_fresh. 139 | pose proof (is_fresh (s ∪ {[ fresh s ]})). 140 | set_solver. 141 | Qed. 142 | 143 | Lemma cfg_fresh2 (ρ : cfg) : 144 | ∃ j1 j2, ρ !! j1 = None ∧ ρ !! j2 = None ∧ j1 ≠ j2. 145 | Proof. 146 | destruct (fresh2 (dom ρ)) as (j1 & j2 & H1 & H2 & H3). 147 | exists j1,j2. split_and!; last done; 148 | apply not_elem_of_dom; done. 149 | Qed. 150 | 151 | Lemma linv_out_Some i j Σ l ρ x : 152 | holds (linv ρ j x) Σ -> 153 | Σ !! i ≡ Some l -> 154 | ∃ e, ρ !! j = Some (Thread e). 155 | Proof. 156 | unfold linv. 157 | destruct (ρ !! j) as [[]|]; eauto. 158 | - rewrite affinely_pure_holds. 159 | intros [H ?] Q. 160 | specialize (H i). rewrite H lookup_empty in Q. simplify_eq. 161 | - rewrite affinely_pure_holds. 162 | intros [H ?] Q. 163 | specialize (H i). rewrite H lookup_empty in Q. simplify_eq. 164 | Qed. 165 | 166 | Definition own_dom A : rProp := ∃ Σ, ⌜⌜ A = dom Σ ⌝⌝ ∗ own Σ. 167 | 168 | Lemma own_dom_empty : own_dom ∅ ⊣⊢ emp. 169 | Proof. 170 | iSplit; unfold own_dom; iIntros "H". 171 | - iDestruct "H" as (? H) "H". 172 | symmetry in H. apply dom_empty_iff_L in H as ->. 173 | by iApply own_empty. 174 | - iExists ∅. rewrite own_empty dom_empty_L //. 175 | Qed. 176 | 177 | Lemma own_dom_singleton k v : own {[ k := v ]} ⊢ own_dom {[ k ]}. 178 | Proof. 179 | iIntros "H". iExists {[ k := v ]}. 180 | rewrite dom_singleton_L. iFrame. done. 181 | Qed. 182 | 183 | Lemma own_dom_union A B : own_dom A ∗ own_dom B ⊢ own_dom (A ∪ B). 184 | Proof. 185 | iIntros "[H1 H2]". 186 | iDestruct "H1" as (Σ1 H1) "H1". 187 | iDestruct "H2" as (Σ2 H2) "H2". subst. 188 | iExists (Σ1 ∪ Σ2). rewrite dom_union_L. iSplit; eauto. 189 | iApply own_union. iFrame. 190 | Qed. 191 | 192 | Lemma own_dom_fin_gset `{Countable A} n (g : fin n -> A) (f : A -> gset vertex) : 193 | ([∗ set] p ∈ fin_gset n g, own_dom (f p)) -∗ own_dom (big_union (fin_gset n (f ∘ g))). 194 | Proof. 195 | induction n. 196 | - rewrite !fin_gset_0 big_union_empty big_sepS_empty own_dom_empty //. 197 | - rewrite !fin_gset_S big_union_singleton_union. 198 | destruct (decide (g 0%fin ∈ fin_gset n (λ i : fin n, g (FS i)))). 199 | + rewrite subseteq_union_1_L; last rewrite singleton_subseteq_l //. 200 | rewrite subseteq_union_1_L; first apply IHn. 201 | eapply elem_of_fin_gset in e. 202 | intros ??. 203 | eapply elem_of_big_union. 204 | destruct e. simpl in *. 205 | rewrite -H1 in H0. 206 | eexists. split; last done. 207 | eapply elem_of_fin_gset. eauto. 208 | + rewrite big_sepS_insert //. 209 | iIntros "[H1 H2]". 210 | iDestruct (IHn with "H2") as "H2". 211 | iApply own_dom_union. iFrame. 212 | Qed. 213 | 214 | Lemma own_dom_fin_union n f : 215 | ([∗ set] p ∈ all_fin n, own_dom (f p)) ⊢ own_dom (fin_union n f). 216 | Proof. 217 | iApply own_dom_fin_gset. 218 | Qed. 219 | 220 | Lemma own_dom_all {A} (f : A -> gset vertex) : 221 | (∀ i, own_dom (f i)) ⊢ ⌜ ∀ i j, f i = f j ⌝. 222 | Proof. 223 | apply entails_holds. 224 | intros Σ H. 225 | rewrite pure_holds. intros. 226 | rewrite ->forall_holds in H. 227 | assert (∀ i, f i = dom Σ). 228 | { intros k. specialize (H k). 229 | eapply exists_holds in H as []. 230 | eapply pure_sep_holds in H as []. 231 | eapply own_holds in H0. 232 | rewrite -H0 H //. } 233 | rewrite !H0 //. 234 | Qed. 235 | 236 | Lemma own_dom_and A B : 237 | own_dom A ∧ own_dom B ⊢ ⌜ A = B ⌝. 238 | Proof. 239 | iIntros "H". 240 | iAssert (∀ c:bool, own_dom (if c then A else B))%I with "[H]" as "H". 241 | { iIntros ([]). 242 | - by iDestruct "H" as "[H _]". 243 | - by iDestruct "H" as "[_ H]". } 244 | iDestruct (own_dom_all with "H") as %Q. 245 | specialize (Q true false). simpl in *. eauto. 246 | Qed. 247 | 248 | Lemma fin_union_same `{Countable A} n (s : gset A) : 249 | fin_union (S n) (λ i, s) = s. 250 | Proof. 251 | induction n. 252 | - rewrite fin_union_S fin_union_0 right_id_L //. 253 | - rewrite fin_union_S IHn union_idemp_L //. 254 | Qed. 255 | 256 | Lemma rtyped_refs Γ e t : 257 | rtyped Γ e t ⊢ own_dom (expr_refs e) 258 | with val_typed_refs v t : 259 | vtyped v t ⊢ own_dom (val_refs v). 260 | Proof. 261 | - iIntros "H". destruct e; simpl; repeat (iDestruct "H" as (?) "H"); try destruct l; 262 | rewrite ?val_typed_refs ?rtyped_refs ?own_dom_empty ?own_dom_union; eauto. 263 | iDestruct "H" as "[H1 H]". iApply own_dom_union; iFrame. 264 | case_decide; subst. { rewrite fin_union_0 own_dom_empty //. } 265 | setoid_rewrite rtyped_refs. 266 | iDestruct (own_dom_all with "H") as %Q. 267 | destruct n; simplify_eq. 268 | assert (expr_refs ∘ e0 = λ i, expr_refs (e0 0%fin)) as ->. 269 | { apply functional_extensionality. intros. eapply Q. } 270 | rewrite fin_union_same. iApply "H". 271 | - iIntros "H". destruct v; simpl; rewrite ?own_dom_empty; eauto; 272 | repeat (iDestruct "H" as (?) "H"); try destruct l; 273 | rewrite ?val_typed_refs ?rtyped_refs ?own_dom_union; eauto. 274 | by iApply own_dom_singleton. 275 | Qed. 276 | 277 | Lemma expr_refs_linv ρ j e x Σ : 278 | ρ !! j = Some (Thread e) -> 279 | holds (linv ρ j x) Σ -> 280 | expr_refs e = dom Σ. 281 | Proof. 282 | intros H1 H2. 283 | unfold linv in *. 284 | rewrite H1 in H2. 285 | eapply pure_sep_holds in H2 as [_ H2]. 286 | rewrite -rtyped_rtyped0 in H2. 287 | eapply holds_entails in H2; last eapply rtyped_refs. 288 | unfold own_dom in *. 289 | eapply exists_holds in H2 as [Σ' H2]. 290 | eapply pure_sep_holds in H2 as [-> H2]. 291 | eapply own_holds in H2. rewrite H2 //. 292 | Qed. 293 | 294 | Lemma full_reachability ρ : 295 | ginv ρ -> fully_reachable ρ. 296 | Proof. 297 | unfold fully_reachable. 298 | intros Hinv. 299 | destruct Hinv as [g [Hwf Hinv]]. 300 | eapply (cgraph_ind' (λ a b l, waiting ρ a b)); eauto; first solve_proper. 301 | intros i IH1 IH2. 302 | classical_right. 303 | rewrite /inactive in H. 304 | pose proof (Hinv i) as Q. 305 | unfold linv in Q. 306 | destruct (ρ !! i) eqn:E; simplify_eq. clear H. 307 | destruct o. 308 | - apply pure_sep_holds in Q as [Q1 Q2]. assert (Q2' := Q2). 309 | eapply holds_entails in Q2; last apply pure_progress. 310 | assert (ρ = {[ i := Thread e ]} ∪ delete i ρ) as HH. 311 | { apply map_eq. intro. smap. } rewrite HH. 312 | apply pure_holds in Q2 as [[v ->]|Q]. 313 | + constructor. exists (∅ ∪ delete i ρ). 314 | econstructor; last constructor; last solve_map_disjoint. 315 | intro x. smap. destruct (_!!x); done. 316 | + destruct Q as (k & e0 & [Hk ->] & [[e0' Q] | [[v ->] | [v [j ->]]]]). 317 | * constructor. eexists ({[ i := Thread (k e0') ]} ∪ delete i ρ). 318 | constructor; [intro j; smap; by destruct (_!!j)..|]. 319 | constructor; eauto. 320 | * constructor. 321 | destruct (cfg_fresh2 ρ) as (j & n & Hj & Hn & Hjn). 322 | exists ({[ i := Thread (k $ Val $ BarrierV n); 323 | j := Thread (App (Val v) (Val $ BarrierV n)); 324 | n := Barrier ]} ∪ delete i ρ). 325 | constructor; [intro x; smap; by destruct (_!!x)..|]. 326 | constructor; eauto; intros ->; simplify_eq. 327 | * (* Thread is now trying to sync with a barrier *) 328 | (* It is therefore waiting and reachable *) 329 | rewrite -HH. 330 | assert (∃ l, out_edges g i !! j ≡ Some l) as [l Hl]. 331 | { 332 | (* rewrite replacement in Q2'; last done. *) 333 | (* simpl in Q2'. *) 334 | assert (holds ((∃ l, own_out j l) ∗ True) (out_edges g i)) as QQ. 335 | { 336 | eapply holds_entails; first exact Q2'. 337 | iIntros "H". 338 | rewrite replacement; last done. 339 | iDestruct "H" as (t) "[H1 H2]". 340 | simpl. 341 | iDestruct "H1" as (t2 l) "[H11 H12]". 342 | iDestruct "H11" as (t1 t0 ?) "H11". simplify_eq. 343 | iSplitL "H11"; eauto. 344 | } 345 | eapply sep_holds in QQ as (Σ1 & Σ2 & H12 & Hdisj & Hout & HP). 346 | eapply exists_holds in Hout as [l Hout]. 347 | unfold own_out in Hout. 348 | eapply own_holds in Hout. 349 | exists l. rewrite H12. 350 | rewrite -Hout. 351 | smap. 352 | } 353 | assert (ρ !! j = Some Barrier) as F. 354 | { 355 | eapply out_edges_in_labels in Hl as [x Hx]. 356 | specialize (Hinv j). 357 | rewrite Hx in Hinv. 358 | eapply pure_holds. 359 | eapply holds_entails; first exact Hinv. 360 | iIntros "H". 361 | unfold linv. 362 | destruct (ρ !! j) as [[]|]; eauto. 363 | - iDestruct "H" as (?) "H". 364 | exfalso. eapply multiset_empty_neq_singleton. 365 | eapply multiset_empty_mult in H as []; eauto. 366 | - iDestruct "H" as "%". 367 | exfalso. eapply multiset_empty_neq_singleton. 368 | eapply multiset_empty_mult in H as []; eauto. 369 | } 370 | assert (waiting ρ i j). { 371 | unfold waiting. rewrite E F. 372 | unfold expr_waiting; eauto. 373 | } 374 | assert (reachable ρ j). { 375 | edestruct (IH1 j); eauto. 376 | unfold inactive in *. simplify_eq. 377 | } 378 | eauto using reachable. 379 | - eapply affinely_pure_holds in Q as [Q1 [t1 [t2 Q2]]]. 380 | (* Need to check whether both threads are trying to sync. *) 381 | (* If so, then can_step *) 382 | (* Otherwise, use IH *) 383 | apply in_labels_out_edges2 in Q2 as (j1 & j2 & Hj12 & Hj1 & Hj2). 384 | 385 | edestruct (linv_out_Some i j1) as [e1 He1]; eauto. 386 | edestruct (linv_out_Some i j2) as [e2 He2]; eauto. 387 | 388 | destruct (classic (waiting ρ j1 i)) as [W1|W1]; last first. 389 | { 390 | edestruct IH2; [|done|..]; eauto. 391 | - unfold inactive in H. simplify_eq. 392 | - assert (waiting ρ i j1); eauto using reachable. 393 | unfold waiting in *. 394 | rewrite He1 E in W1. 395 | rewrite E He1. split; eauto. 396 | erewrite expr_refs_linv; eauto. 397 | apply elem_of_dom. rewrite Hj1. done. 398 | } 399 | destruct (classic (waiting ρ j2 i)) as [W2|W2]; last first. 400 | { 401 | edestruct IH2; [|done|..]; eauto. 402 | - unfold inactive in H. simplify_eq. 403 | - assert (waiting ρ i j2); eauto using reachable. 404 | unfold waiting in *. 405 | rewrite He2 E in W2. 406 | rewrite E He2. split; eauto. 407 | erewrite expr_refs_linv; eauto. 408 | apply elem_of_dom. rewrite Hj2. done. 409 | } 410 | constructor. 411 | unfold waiting in W1,W2. 412 | rewrite He1 E in W1. 413 | rewrite He2 E in W2. 414 | assert (ρ = {[ j1 := Thread e1; j2 := Thread e2; i := Barrier ]} ∪ (delete j2 $ delete j1 $ delete i ρ)) as HH. 415 | { apply map_eq. intro. smap. } 416 | destruct W2 as (k2 & v2 & Hk2 & ->). 417 | destruct W1 as (k1 & v1 & Hk1 & ->). 418 | unfold can_step. 419 | exists ({[ j1 := Thread (k1 $ Val v2); j2 := Thread (k2 $ Val v1) ]} ∪ (delete j2 $ delete j1 $ delete i ρ)). 420 | rewrite {1}HH. 421 | constructor. 422 | { intro x. smap. destruct (_!!x); done. } 423 | { intro x. smap. destruct (_!!x); done. } 424 | constructor; eauto; intros ->; simplify_eq. 425 | Qed. 426 | 427 | Lemma initialization e : 428 | typed ∅ e UnitT -> ginv {[ 0 := Thread e ]}. 429 | Proof. 430 | intros H. 431 | unfold ginv, linv. 432 | eapply inv_impl; last eauto using inv_init. 433 | intros. simpl. 434 | iIntros "[% _]". 435 | smap. iSplit; eauto. 436 | rewrite -rtyped_rtyped0. 437 | iApply typed_rtyped. eauto. 438 | Qed. -------------------------------------------------------------------------------- /theories/lambdabar/langdef.v: -------------------------------------------------------------------------------- 1 | From cgraphs.lambdabar Require Export langtools. 2 | 3 | (* Expressions and values *) 4 | (* ---------------------- *) 5 | 6 | Inductive expr := 7 | | Val : val -> expr 8 | | Var : string -> expr 9 | | Fun : string -> expr -> expr 10 | | App : expr -> expr -> expr 11 | | Unit : expr 12 | | Pair : expr -> expr -> expr 13 | | LetPair : expr -> expr -> expr 14 | | Sum : nat -> expr -> expr 15 | | MatchSum n : expr -> (fin n -> expr) -> expr 16 | | Fork : expr -> expr 17 | with val := 18 | | FunV : string -> expr -> val 19 | | UnitV : val 20 | | PairV : val -> val -> val 21 | | SumV : nat -> val -> val 22 | | BarrierV : nat -> val. 23 | 24 | 25 | (* Type system *) 26 | (* ----------- *) 27 | 28 | Inductive linearity := Lin | Unr. 29 | 30 | CoInductive type := 31 | | FunT : linearity -> type -> type -> type 32 | | UnitT : type 33 | | PairT : type -> type -> type 34 | | SumT n : (fin n -> type) -> type. 35 | 36 | CoInductive unr : type -> Prop := 37 | | Fun_unr t1 t2 : unr (FunT Unr t1 t2) 38 | | Unit_unr : unr UnitT 39 | | Pair_unr t1 t2 : unr t1 -> unr t2 -> unr (PairT t1 t2) 40 | | Sum_unr n ts : (∀ i, unr (ts i)) -> unr (SumT n ts). 41 | 42 | (* We define linear environment splitting here. 43 | On paper this is implicit in Γ1,Γ2 ⊢ e : A. 44 | In Coq we have to explicitly say env_split Γ Γ1 Γ2, and typed Γ e A. *) 45 | Definition env := gmap string type. 46 | 47 | Definition env_unr (Γ : env) := 48 | ∀ x t, Γ !! x = Some t -> unr t. 49 | 50 | Definition disj (Γ1 Γ2 : env) := 51 | ∀ i t1 t2, Γ1 !! i = Some t1 -> Γ2 !! i = Some t2 -> t1 = t2 ∧ unr t1. 52 | 53 | Definition env_split (Γ : env) (Γ1 : env) (Γ2 : env) := 54 | Γ = Γ1 ∪ Γ2 ∧ disj Γ1 Γ2. 55 | 56 | Definition env_bind (Γ' : env) (x : string) (t : type) (Γ : env) := 57 | Γ' = <[ x := t ]> Γ ∧ ∀ t', Γ !! x = Some t' -> unr t'. 58 | 59 | Definition env_var (Γ : env) (x : string) (t : type) := 60 | ∃ Γ', Γ = <[ x := t ]> Γ' ∧ env_unr Γ'. 61 | 62 | 63 | Inductive typed : env -> expr -> type -> Prop := 64 | | Var_typed Γ x t : 65 | env_var Γ x t -> 66 | typed Γ (Var x) t 67 | | Fun_typed Γ Γ' x e t1 t2 l : 68 | env_bind Γ' x t1 Γ -> 69 | (l = Unr -> env_unr Γ) -> 70 | typed Γ' e t2 -> 71 | typed Γ (Fun x e) (FunT l t1 t2) 72 | | App_typed Γ Γ1 Γ2 e1 e2 t1 t2 l : 73 | env_split Γ Γ1 Γ2 -> 74 | typed Γ1 e1 (FunT l t1 t2) -> 75 | typed Γ2 e2 t1 -> 76 | typed Γ (App e1 e2) t2 77 | | Unit_typed Γ : 78 | env_unr Γ -> 79 | typed Γ Unit UnitT 80 | | Pair_typed Γ Γ1 Γ2 e1 e2 t1 t2 : 81 | env_split Γ Γ1 Γ2 -> 82 | typed Γ1 e1 t1 -> 83 | typed Γ2 e2 t2 -> 84 | typed Γ (Pair e1 e2) (PairT t1 t2) 85 | | LetPair_typed Γ Γ1 Γ2 e1 e2 t1 t2 t : 86 | env_split Γ Γ1 Γ2 -> 87 | typed Γ1 e1 (PairT t1 t2) -> 88 | typed Γ2 e2 (FunT Lin t1 (FunT Lin t2 t)) -> 89 | typed Γ (LetPair e1 e2) t 90 | | Sum_typed Γ n (ts : fin n -> type) i e : 91 | typed Γ e (ts i) -> 92 | typed Γ (Sum i e) (SumT n ts) 93 | | MatchSumN_typed n Γ Γ1 Γ2 t (ts : fin n -> type) es e : 94 | env_split Γ Γ1 Γ2 -> 95 | (n = 0 -> env_unr Γ2) -> 96 | typed Γ1 e (SumT n ts) -> 97 | (∀ i, typed Γ2 (es i) (FunT Lin (ts i) t)) -> 98 | typed Γ (MatchSum n e es) t 99 | | Fork_typed Γ e t1 t2 : 100 | typed Γ e (FunT Lin (FunT Lin t2 t1) UnitT) -> 101 | typed Γ (Fork e) (FunT Lin t1 t2). 102 | 103 | 104 | (* Operational semantics *) 105 | (* --------------------- *) 106 | 107 | Definition subst (x:string) (a:val) := fix rec e := 108 | match e with 109 | | Val _ => e 110 | | Var x' => if decide (x = x') then Val a else e 111 | | Fun x' e => Fun x' (if decide (x = x') then e else rec e) 112 | | App e1 e2 => App (rec e1) (rec e2) 113 | | Unit => Unit 114 | | Pair e1 e2 => Pair (rec e1) (rec e2) 115 | | LetPair e1 e2 => LetPair (rec e1) (rec e2) 116 | | Sum n e => Sum n (rec e) 117 | | MatchSum n e1 e2 => MatchSum n (rec e1) (rec ∘ e2) 118 | | Fork e => Fork (rec e) 119 | end. 120 | 121 | Inductive pure_step : expr -> expr -> Prop := 122 | | Fun_step x e : 123 | pure_step (Fun x e) (Val $ FunV x e) 124 | | App_step x e a : 125 | pure_step (App (Val $ FunV x e) (Val a)) (subst x a e) 126 | | Unit_step : 127 | pure_step Unit (Val $ UnitV) 128 | | Pair_step v1 v2 : 129 | pure_step (Pair (Val v1) (Val v2)) (Val $ PairV v1 v2) 130 | | LetPair_step v1 v2 e: 131 | pure_step (LetPair (Val $ PairV v1 v2) e) (App (App e (Val v1)) (Val v2)) 132 | | Sum_step n v : 133 | pure_step (Sum n (Val v)) (Val $ SumV n v) 134 | | MatchSum_step n (i : fin n) v es : 135 | pure_step (MatchSum n (Val $ SumV i v) es) (App (es i) (Val v)). 136 | 137 | Inductive ctx1 : (expr -> expr) -> Prop := 138 | | Ctx_App_l e : ctx1 (λ x, App e x) 139 | | Ctx_App_r e : ctx1 (λ x, App x e) 140 | | Ctx_Pair_l e : ctx1 (λ x, Pair x e) 141 | | Ctx_Pair_r e : ctx1 (λ x, Pair e x) 142 | | Ctx_LetPair e : ctx1 (λ x, LetPair x e) 143 | | Ctx_Sum i : ctx1 (λ x, Sum i x) 144 | | Ctx_MatchSum n es : ctx1 (λ x, MatchSum n x es) 145 | | Ctx_Fork : ctx1 (λ x, Fork x). 146 | 147 | Inductive ctx : (expr -> expr) -> Prop := 148 | | Ctx_id : ctx id 149 | | Ctx_comp k1 k2 : ctx1 k1 -> ctx k2 -> ctx (k1 ∘ k2). 150 | 151 | Inductive obj := Thread (e : expr) | Barrier. 152 | Definition cfg := gmap nat obj. 153 | 154 | Inductive local_step : nat -> cfg -> cfg -> Prop := 155 | | Pure_step i k e e' : 156 | ctx k -> pure_step e e' -> 157 | local_step i {[ i := Thread (k e) ]} {[ i := Thread (k e') ]} 158 | | Exit_step i v : 159 | local_step i {[ i := Thread (Val v) ]} ∅ 160 | | Fork_step i j n k v : 161 | i ≠ j -> i ≠ n -> j ≠ n -> ctx k -> 162 | local_step i {[ i := Thread (k (Fork (Val v))) ]} 163 | {[ i := Thread (k (Val $ BarrierV n)); 164 | j := Thread (App (Val v) (Val $ BarrierV n)); 165 | n := Barrier ]} 166 | | Sync_step i j n k1 k2 v1 v2 : 167 | i ≠ j -> i ≠ n -> j ≠ n -> ctx k1 -> ctx k2 -> 168 | local_step n {[ i := Thread (k1 (App (Val $ BarrierV n) (Val v1))); 169 | j := Thread (k2 (App (Val $ BarrierV n) (Val v2))); 170 | n := Barrier ]} 171 | {[ i := Thread (k1 $ Val v2); 172 | j := Thread (k2 $ Val v1) ]}. 173 | 174 | Inductive step : nat -> cfg -> cfg -> Prop := 175 | | Frame_step ρ ρ' ρf i : 176 | ρ ##ₘ ρf -> ρ' ##ₘ ρf -> 177 | local_step i ρ ρ' -> step i (ρ ∪ ρf) (ρ' ∪ ρf). 178 | 179 | Definition step' ρ ρ' := ∃ i, step i ρ ρ'. 180 | Definition steps := rtc step'. 181 | 182 | -------------------------------------------------------------------------------- /theories/lambdabar/langtools.v: -------------------------------------------------------------------------------- 1 | From iris.proofmode Require Export base tactics classes. 2 | From cgraphs.cgraphs Require Export util. 3 | From Coq.Logic Require Export FunctionalExtensionality Classical. 4 | From cgraphs Require Export seplogic. 5 | From stdpp Require Export gmap. 6 | Require Export cgraphs.cgraphs.genericinv. 7 | 8 | Ltac inv H := inversion H; clear H; simplify_eq. -------------------------------------------------------------------------------- /theories/lambdabar/letmacro.v: -------------------------------------------------------------------------------- 1 | From cgraphs.lambdabar Require Export langdef. 2 | 3 | (* In this file we demonstrate how typed macros work. *) 4 | (* We define a macro for let in terms of function application and lambda. *) 5 | 6 | Definition Let x e1 e2 := App (Fun x e2) e1. 7 | 8 | (* Check Let. *) 9 | (* Check Fun. *) 10 | 11 | (* We can now prove a typing rule for Let *) 12 | 13 | Lemma Let_typed Γ Γ1 Γ1' Γ2 x e1 e2 t1 t2 : 14 | env_split Γ Γ1 Γ2 -> 15 | env_bind Γ1' x t1 Γ1 -> 16 | typed Γ1' e2 t2 -> 17 | typed Γ2 e1 t1 -> 18 | typed Γ (Let x e1 e2) t2. 19 | Proof. 20 | intros Hs Hb H1 H2. 21 | unfold Let. 22 | eapply App_typed; eauto. 23 | eapply (Fun_typed _ _ _ _ _ _ Lin); eauto. 24 | intros [=]. 25 | Qed. 26 | 27 | (* Check Let_typed. *) 28 | (* Check Fun_typed. *) 29 | 30 | (* We now have a lemma that lets us type check our Let construct using the 31 | usual typing rule for let. From the outside, this gives the same interface 32 | as if we had added Let as a primitive expression and added a typing rule 33 | to our language: *) 34 | 35 | (* 36 | Inductive typed : env -> expr -> type -> Prop := 37 | | ... 38 | | Let_typed Γ Γ1 Γ1' Γ2 x e1 e2 t1 t2 : 39 | env_split Γ Γ1 Γ2 -> 40 | env_bind Γ1' x t1 Γ1 -> 41 | typed Γ1' e2 t2 -> 42 | typed Γ2 e1 t1 -> 43 | typed Γ (Let x e1 e2) t2 44 | | ... 45 | *) -------------------------------------------------------------------------------- /theories/lambdabar/rtypesystem.v: -------------------------------------------------------------------------------- 1 | From cgraphs.lambdabar Require Export langdef. 2 | 3 | Notation vertex := nat. 4 | Definition label : Type := bool * type * type. 5 | 6 | (* ----------- *) 7 | (* Boilerplate *) 8 | 9 | (* Canonical Structure vertexO := leibnizO vertex. *) 10 | Canonical Structure typeO := leibnizO type. 11 | Canonical Structure labelO := prodO boolO (prodO typeO typeO). 12 | (* 13 | Global Instance vertex_eqdecision : EqDecision vertex. 14 | Proof. 15 | intros [n|n] [m|m]; unfold Decision; destruct (decide (n = m)); 16 | subst; eauto; right; intro; simplify_eq. 17 | Qed. 18 | Global Instance vertex_countable : Countable vertex. 19 | Proof. 20 | refine (inj_countable' (λ l, match l with 21 | | VThread n => inl n 22 | | VBarrier n => inr n 23 | end) (λ l, match l with 24 | | inl n => VThread n 25 | | inr n => VBarrier n 26 | end) _); by intros []. 27 | Qed. *) 28 | 29 | (* End boilerplate *) 30 | (* --------------- *) 31 | 32 | Notation rProp := (hProp vertex labelO). 33 | 34 | Definition linbox l (P : rProp) : rProp := 35 | match l with 36 | | Lin => P 37 | | Unr => □ P 38 | end. 39 | 40 | Fixpoint rtyped (Γ : env) e t : rProp := 41 | match e with 42 | | Val v => ⌜⌜ env_unr Γ ⌝⌝ ∗ vtyped v t 43 | | Var x => ⌜⌜ env_var Γ x t ⌝⌝ 44 | | Fun x e => 45 | ∃ l t1 t2, ⌜⌜ t = FunT l t1 t2 ⌝⌝ ∗ 46 | ∃ Γ', ⌜⌜ env_bind Γ' x t1 Γ ∧ (l = Unr -> env_unr Γ) ⌝⌝ ∗ 47 | linbox l (rtyped Γ' e t2) 48 | | App e1 e2 => 49 | ∃ Γ1 Γ2, ⌜⌜ env_split Γ Γ1 Γ2 ⌝⌝ ∗ 50 | ∃ t1 l, 51 | rtyped Γ1 e1 (FunT l t1 t) ∗ 52 | rtyped Γ2 e2 t1 53 | | Unit => ⌜⌜ t = UnitT ∧ env_unr Γ ⌝⌝ 54 | | Pair e1 e2 => 55 | ∃ Γ1 Γ2, ⌜⌜ env_split Γ Γ1 Γ2 ⌝⌝ ∗ 56 | ∃ t1 t2, ⌜⌜ t = PairT t1 t2 ⌝⌝ ∗ 57 | rtyped Γ1 e1 t1 ∗ rtyped Γ2 e2 t2 58 | | LetPair e1 e2 => 59 | ∃ Γ1 Γ2, ⌜⌜ env_split Γ Γ1 Γ2 ⌝⌝ ∗ 60 | ∃ t1 t2, 61 | rtyped Γ1 e1 (PairT t1 t2) ∗ 62 | rtyped Γ2 e2 (FunT Lin t1 (FunT Lin t2 t)) 63 | | Sum i e => 64 | ∃ n (ts : fin n -> type) (i' : fin n), ⌜⌜ t = SumT n ts ⌝⌝ ∗ ⌜⌜ i = i' ⌝⌝ ∗ 65 | rtyped Γ e (ts i') 66 | | MatchSum n e es => 67 | ∃ Γ1 Γ2, ⌜⌜ env_split Γ Γ1 Γ2 ∧ (n = 0 -> env_unr Γ2)⌝⌝ ∗ 68 | ∃ ts, 69 | rtyped Γ1 e (SumT n ts) ∗ 70 | if decide (n=0) then ⌜⌜ env_unr Γ2 ⌝⌝ else (∀ i, rtyped Γ2 (es i) (FunT Lin (ts i) t)) 71 | | Fork e => 72 | ∃ t1 t2, ⌜⌜ t = FunT Lin t1 t2 ⌝⌝ ∗ 73 | rtyped Γ e (FunT Lin (FunT Lin t2 t1) UnitT) 74 | end 75 | with vtyped v t := 76 | match v with 77 | | FunV x e => 78 | ∃ l t1 t2, ⌜⌜ t = FunT l t1 t2 ⌝⌝ ∗ linbox l (rtyped {[ x := t1 ]} e t2) 79 | | UnitV => ⌜⌜ t = UnitT ⌝⌝ 80 | | PairV v1 v2 => 81 | ∃ t1 t2, ⌜⌜ t = PairT t1 t2 ⌝⌝ ∗ 82 | vtyped v1 t1 ∗ vtyped v2 t2 83 | | SumV i v => 84 | ∃ n ts (i' : fin n), ⌜⌜ t = SumT n ts ∧ i = i' ⌝⌝ ∗ 85 | vtyped v (ts i') 86 | | BarrierV k => 87 | ∃ t1 t2, ⌜⌜ t = FunT Lin t1 t2 ⌝⌝ ∗ 88 | own_out k ((false,(t1,t2)) : labelO) 89 | end. 90 | 91 | Lemma typed_rtyped Γ e t : 92 | ⌜⌜ typed Γ e t ⌝⌝ -∗ rtyped Γ e t. 93 | Proof. 94 | iIntros (H). 95 | iInduction e as [] "IH" forall (t Γ H); 96 | inv H; simpl; eauto; repeat iExists _; iSplitL; eauto; 97 | repeat iExists _; try iSplitL; eauto; try iSplitL; 98 | try destruct l; try case_decide; repeat iIntros (?); 99 | try iApply ("IH" with "[%]") || iApply ("IH1" with "[%]"); eauto. 100 | Qed. 101 | 102 | (* From stdpp's naive_solver *) 103 | Ltac simp := 104 | repeat match goal with 105 | (**i solve the goal *) 106 | | |- _ => fast_done 107 | (**i intros *) 108 | | |- ∀ _, _ => intro 109 | (**i simplification of assumptions *) 110 | | H : False |- _ => destruct H 111 | | H : _ ∧ _ |- _ => 112 | (* Work around bug https://coq.inria.fr/bugs/show_bug.cgi?id=2901 *) 113 | let H1 := fresh in let H2 := fresh in 114 | destruct H as [H1 H2]; try clear H 115 | | H : ∃ _, _ |- _ => 116 | let x := fresh in let Hx := fresh in 117 | destruct H as [x Hx]; try clear H 118 | | H : ?P → ?Q, H2 : ?P |- _ => specialize (H H2) 119 | | H : Is_true (bool_decide _) |- _ => apply (bool_decide_unpack _) in H 120 | | H : Is_true (_ && _) |- _ => apply andb_True in H; destruct H 121 | (**i simplify and solve equalities *) 122 | | |- _ => progress simplify_eq/= 123 | (**i operations that generate more subgoals *) 124 | (* | |- _ ∧ _ => split *) 125 | (* | |- Is_true (bool_decide _) => apply (bool_decide_pack _) *) 126 | (* | |- Is_true (_ && _) => apply andb_True; split *) 127 | (* | H : _ ∨ _ |- _ => *) 128 | (* let H1 := fresh in destruct H as [H1|H1]; try clear H *) 129 | (* | H : Is_true (_ || _) |- _ => *) 130 | (* apply orb_True in H; let H1 := fresh in destruct H as [H1|H1]; try clear H *) 131 | (**i solve the goal using the user supplied tactic *) 132 | end. 133 | 134 | Ltac iDestr H := repeat (iDestruct "H" as %? || iDestruct H as (?) H). 135 | Ltac iSpl := repeat (iExists _ || iSplit || iIntros (?)). 136 | 137 | Lemma unrestricted_box v t : 138 | unr t -> vtyped v t -∗ □ vtyped v t. 139 | Proof. 140 | iIntros (H) "H". 141 | iInduction v as [] "IH" forall (t H); simpl; 142 | iDestr "H"; simp; inv H; simp; eauto. 143 | - iDestruct "H" as "#H". iModIntro. eauto. 144 | - iDestruct "H" as "[H1 H2]". 145 | iDestruct ("IH" with "[%] H1") as "H1"; first done. 146 | iDestruct ("IH1" with "[%] H2") as "H2"; first done. 147 | iDestruct "H1" as "#H1". 148 | iDestruct "H2" as "#H2". 149 | iModIntro. repeat (iExists _ || iSplitL); eauto. 150 | - iDestruct ("IH" with "[%] H") as "H"; first done. 151 | iDestruct "H" as "#H". iModIntro. eauto. 152 | Qed. 153 | 154 | 155 | Definition substR (Γ : env) x v := from_option (vtyped v) emp%I (Γ !! x). 156 | 157 | Ltac sdec := repeat case_decide; simplify_eq; simpl in *; eauto; try done. 158 | Ltac smap := repeat (rewrite lookup_alter_spec || rewrite lookup_union || rewrite lookup_insert_spec || rewrite lookup_delete_spec || sdec). 159 | 160 | Lemma env_unr_substR Γ x v : 161 | env_unr Γ -> substR Γ x v ⊢ emp. 162 | Proof. 163 | rewrite /env_unr /substR. 164 | destruct (Γ !! x) eqn:E; simp. 165 | rewrite unrestricted_box; eauto. 166 | Qed. 167 | 168 | Lemma env_split_substR Γ Γ1 Γ2 x v : 169 | env_split Γ Γ1 Γ2 -> substR Γ x v ⊢ substR Γ1 x v ∗ substR Γ2 x v. 170 | Proof. 171 | rewrite /env_split /substR. simp. 172 | rewrite lookup_union. 173 | destruct (Γ1 !! x) eqn:E; 174 | destruct (Γ2 !! x) eqn:F; rewrite ?E ?F; simpl; eauto. 175 | edestruct (H1 x); eauto. simp. 176 | iIntros "H". 177 | iDestruct (unrestricted_box with "H") as "H"; eauto. 178 | iDestruct "H" as "#H". iSplitL; eauto. 179 | Qed. 180 | 181 | Lemma env_var_substR Γ x y v t : 182 | env_var Γ y t -> 183 | substR Γ x v ⊢ if decide (x = y) then vtyped v t else emp. 184 | Proof. 185 | rewrite /env_var /substR. simp. smap. 186 | destruct (_!!_) eqn:E; simp. 187 | rewrite unrestricted_box; eauto. 188 | Qed. 189 | 190 | Lemma env_bind_substR Γ Γ' l x y v t : 191 | (l = Unr -> env_unr Γ) -> env_bind Γ' y t Γ -> 192 | substR Γ x v ⊢ if decide (x = y) then emp else linbox l (substR Γ' x v). 193 | Proof. 194 | rewrite /env_bind /substR. simp. smap. 195 | - destruct (Γ !! y) eqn:E; simpl; eauto. 196 | rewrite unrestricted_box; eauto. 197 | - destruct (Γ !! x) eqn:E; rewrite ?E; destruct l; eauto; simpl. 198 | rewrite {1}unrestricted_box; eauto. 199 | eapply H; eauto. 200 | Qed. 201 | 202 | 203 | Lemma env_unr_delete Γ x : 204 | env_unr Γ -> env_unr (delete x Γ). 205 | Proof. 206 | rewrite /env_unr. intros ???. smap. 207 | Qed. 208 | 209 | Lemma env_split_delete Γ Γ1 Γ2 x : 210 | env_split Γ Γ1 Γ2 -> env_split (delete x Γ) (delete x Γ1) (delete x Γ2). 211 | Proof. 212 | rewrite /env_split /disj. simp. 213 | split; [apply delete_union|]. 214 | intros ???. smap. 215 | Qed. 216 | 217 | Lemma env_var_delete y x Γ t : 218 | env_var Γ x t -> if decide (y = x) then env_unr (delete y Γ) else env_var (delete y Γ) x t. 219 | Proof. 220 | rewrite /env_var /env_unr. simp. smap. 221 | - simp. revert H. smap. 222 | - exists (delete y H0). split. 223 | + apply map_eq. intro. smap. 224 | + intros ??. smap. 225 | Qed. 226 | 227 | Lemma env_bind_delete x y t Γ Γ' : 228 | env_bind Γ' x t Γ -> 229 | env_bind (if decide (y = x) then Γ' else delete y Γ') x t (delete y Γ). 230 | Proof. 231 | rewrite /env_bind. simp. 232 | split. 233 | - apply map_eq. intro. smap. 234 | - intro. smap. 235 | Qed. 236 | 237 | 238 | Lemma env_unr_empty : 239 | env_unr ∅. 240 | Proof. 241 | rewrite /env_unr. intros ??. smap. 242 | Qed. 243 | 244 | Lemma env_split_empty Γ1 Γ2 : 245 | env_split ∅ Γ1 Γ2 <-> Γ1 = ∅ ∧ Γ2 = ∅. 246 | Proof. 247 | rewrite /env_split. 248 | split. simp. 249 | - symmetry in H0. 250 | pose proof (map_positive_l _ _ H0). subst. 251 | rewrite left_id in H0. subst. eauto. 252 | - simp. rewrite left_id. split; eauto. 253 | rewrite /disj. intros ??. smap. 254 | Qed. 255 | 256 | Lemma env_var_empty x t : 257 | env_var ∅ x t <-> False. 258 | Proof. 259 | rewrite /env_var. split; simp. 260 | rewrite map_eq_iff in H. specialize (H x). revert H. smap. 261 | Qed. 262 | 263 | Lemma env_bind_empty Γ x t1 : 264 | env_bind Γ x t1 ∅ <-> Γ = {[ x := t1 ]}. 265 | Proof. 266 | rewrite /env_bind. repeat split; simp. 267 | Qed. 268 | 269 | 270 | Lemma linbox_mono P Q l : 271 | □ (P -∗ Q) -∗ linbox l P -∗ linbox l Q. 272 | Proof. 273 | iIntros "#H P". 274 | destruct l; simpl; [|iDestruct "P" as "#P"; iModIntro]; 275 | iApply "H"; done. 276 | Qed. 277 | 278 | Lemma linbox_sep P Q l : 279 | linbox l P ∗ linbox l Q ⊢ linbox l (P ∗ Q). 280 | Proof. 281 | destruct l; simpl; eauto. 282 | iIntros "[#H #R]". iModIntro. 283 | iSplitL; eauto. 284 | Qed. 285 | 286 | 287 | Lemma substitution Γ x v e t : 288 | substR Γ x v ∗ 289 | rtyped Γ e t -∗ 290 | rtyped (delete x Γ) (subst x v e) t. 291 | Proof. 292 | iIntros "RH". 293 | iInduction e as [] "IH" forall (Γ t); simpl; 294 | iDestruct "RH" as "[R H]"; iDestr "H"; try iDestruct "H" as "[H Q]"; simp. 295 | - rewrite env_unr_substR //. iSpl; eauto using env_unr_delete. 296 | - rewrite env_var_substR //. 297 | eapply (env_var_delete x) in H. 298 | case_decide; subst; simpl; iFrame; iPureIntro; eauto. 299 | - iExists _,_,_. iSplit; first done. 300 | iExists _. iSplit; eauto 6 using env_bind_delete, env_unr_delete. 301 | rewrite env_bind_substR; eauto. 302 | case_decide; subst; iFrame. 303 | iApply linbox_mono; eauto. 304 | iApply linbox_sep. iFrame. 305 | - iDestruct (env_split_substR with "R") as "[R1 R2]"; eauto. 306 | iSpl; eauto using env_split_delete. 307 | iSplitL "H R1"; (iApply "IH" || iApply "IH1"); eauto with iFrame. 308 | - rewrite env_unr_substR //. 309 | eauto using env_unr_delete. 310 | - iDestruct (env_split_substR with "R") as "[R1 R2]"; eauto. 311 | iSpl; eauto using env_split_delete. 312 | iSplitL "H R1"; (iApply "IH" || iApply "IH1"); eauto with iFrame. 313 | - iDestruct (env_split_substR with "R") as "[R1 R2]"; eauto. 314 | iSpl; eauto using env_split_delete. 315 | iSplitL "H R1"; (iApply "IH" || iApply "IH1"); eauto with iFrame. 316 | - iSpl; eauto. iApply "IH". iFrame. 317 | - iDestruct (env_split_substR with "R") as "[R1 R2]"; eauto. 318 | iSpl; first iPureIntro; eauto using env_split_delete, env_unr_delete. 319 | case_decide; subst. 320 | { iDestruct "Q" as "%". iSplit; eauto using env_unr_delete. 321 | eapply env_unr_substR in H. rewrite H. 322 | iApply "IH1". iFrame. } 323 | iSplitL "H R1"; iSpl; (iApply "IH" || iApply "IH1"); eauto with iFrame. 324 | - iSpl; eauto. (iApply "IH" || iApply "IH1"); eauto with iFrame. 325 | Qed. 326 | 327 | Fixpoint rtyped0 e t : rProp := 328 | match e with 329 | | Val v => vtyped v t 330 | | Var x => False 331 | | Fun x e => 332 | ∃ l t1 t2, ⌜⌜ t = FunT l t1 t2 ⌝⌝ ∗ 333 | ∃ Γ, ⌜⌜ env_bind Γ x t1 ∅ ⌝⌝ ∗ 334 | linbox l (rtyped Γ e t2) 335 | | App e1 e2 => 336 | ∃ t1 l, 337 | rtyped0 e1 (FunT l t1 t) ∗ 338 | rtyped0 e2 t1 339 | | Unit => ⌜⌜ t = UnitT ⌝⌝ 340 | | Pair e1 e2 => 341 | ∃ t1 t2, ⌜⌜ t = PairT t1 t2 ⌝⌝ ∗ 342 | rtyped0 e1 t1 ∗ rtyped0 e2 t2 343 | | LetPair e1 e2 => 344 | ∃ t1 t2, 345 | rtyped0 e1 (PairT t1 t2) ∗ 346 | rtyped0 e2 (FunT Lin t1 (FunT Lin t2 t)) 347 | | Sum i e => 348 | ∃ n (ts : fin n -> type) (i' : fin n), ⌜⌜ t = SumT n ts ⌝⌝ ∗ ⌜⌜ i = i' ⌝⌝ ∗ 349 | rtyped0 e (ts i') 350 | | MatchSum n e es => 351 | ∃ ts, 352 | rtyped0 e (SumT n ts) ∗ 353 | if decide (n=0) then emp else (∀ i, rtyped0 (es i) (FunT Lin (ts i) t)) 354 | | Fork e => 355 | ∃ t1 t2, ⌜⌜ t = FunT Lin t1 t2 ⌝⌝ ∗ 356 | rtyped0 e (FunT Lin (FunT Lin t2 t1) UnitT) 357 | end. 358 | 359 | 360 | Lemma rtyped_rtyped0 e t : 361 | rtyped ∅ e t ⊣⊢ rtyped0 e t. 362 | Proof. 363 | revert t. induction e; intros; simpl; 364 | iSplit; iIntros "H"; 365 | try setoid_rewrite env_split_empty; 366 | try setoid_rewrite env_var_empty; 367 | try setoid_rewrite env_bind_empty; 368 | iDestr "H"; simp; eauto using env_unr_empty; 369 | try iDestruct "H" as "[H Q]"; 370 | repeat (iExists _ || iSplit); eauto using env_unr_empty; 371 | rewrite ?H ?IHe ?IHe1 ?IHe2; try case_decide; iFrame; eauto using env_unr_empty; 372 | iIntros (?); setoid_rewrite H; eauto. 373 | Qed. 374 | 375 | Lemma substitution0 v t1 t2 x e : 376 | vtyped v t1 ∗ 377 | rtyped {[ x := t1 ]} e t2 -∗ 378 | rtyped0 (subst x v e) t2. 379 | Proof. 380 | rewrite -rtyped_rtyped0. 381 | iIntros "[H Q]". 382 | iDestruct (substitution _ x v e t2 with "[H Q]") as "H"; iFrame. 383 | - rewrite /substR lookup_singleton //. 384 | - rewrite delete_singleton //. 385 | Qed. 386 | 387 | Lemma pure_preservation e e' t : 388 | pure_step e e' -> 389 | rtyped0 e t -∗ rtyped0 e' t. 390 | Proof. 391 | intros []; simpl; 392 | iIntros "H"; 393 | try setoid_rewrite env_bind_empty; 394 | repeat (iDestr "H" || iDestruct "H" as "[H ?]"); simp; 395 | repeat (iExists _ || iSplit || case_decide); eauto with iFrame. 396 | - iApply substitution0. iFrame. by destruct l0. 397 | - subst. inv_fin i'. 398 | Qed. 399 | 400 | Lemma replacement1 k e B : 401 | ctx1 k -> 402 | rtyped0 (k e) B -∗ ∃ t, rtyped0 e t ∗ ∀ e', rtyped0 e' t -∗ rtyped0 (k e') B. 403 | Proof. 404 | destruct 1; simpl; iIntros "H"; 405 | iDestr "H"; try iDestruct "H" as "[H Q]"; 406 | eauto 8 with iFrame. 407 | Qed. 408 | 409 | Lemma replacement k e B : 410 | ctx k -> 411 | rtyped0 (k e) B ⊣⊢ ∃ t, rtyped0 e t ∗ ∀ e', rtyped0 e' t -∗ rtyped0 (k e') B. 412 | Proof. 413 | intros Hk. 414 | iSplit; iIntros "H"; last first. 415 | { iDestruct "H" as (t) "[H Q]". by iApply "Q". } 416 | iInduction Hk as [] "IH" forall (B e); simpl. 417 | { iExists _. iFrame. eauto. } subst. 418 | iDestruct (replacement1 with "H") as (?) "[H R]"; eauto. 419 | iDestruct ("IH" with "H") as (?) "[Q H]". 420 | iExists _. iFrame. iIntros (?) "?". 421 | iApply "R". iApply "H". done. 422 | Qed. 423 | 424 | 425 | Ltac solve_ctx := solve [iPureIntro; do 2 eexists; split; last done; eauto using ctx, ctx1]. 426 | Ltac solve_step := solve [iPureIntro; do 2 eexists; split; eauto using Ctx_id; simp; eauto using pure_step]. 427 | 428 | Ltac solve_pr := simp; try (solve_ctx || solve_step). 429 | 430 | Lemma pure_progress e t : 431 | rtyped0 e t -∗ ⌜ (∃ v, e = Val v) ∨ 432 | ∃ k e0, (ctx k ∧ e = k e0) ∧ 433 | ((∃ e', pure_step e0 e') ∨ 434 | (∃ v, e0 = Fork (Val v)) ∨ 435 | (∃ v k, e0 = App (Val $ BarrierV k) (Val v))) ⌝. 436 | Proof. 437 | iIntros "H". 438 | iInduction e as [] "IH" forall (t); simpl; eauto; 439 | iDestr "H"; 440 | try iDestruct "H" as "[H Q]"; simp; 441 | try iDestruct ("IH" with "H") as %H; 442 | try iDestruct ("IH1" with "H") as %H; 443 | try iDestruct ("IH1" with "Q") as %Q; iRight; 444 | try destruct H; solve_pr; 445 | try destruct Q; solve_pr; 446 | destruct H0; simpl; iDestr "H"; solve_pr. 447 | Qed. -------------------------------------------------------------------------------- /theories/lambdabar/sessions.v: -------------------------------------------------------------------------------- 1 | From cgraphs.lambdabar Require Export langdef. 2 | From cgraphs.lambdabar Require Export rtypesystem. 3 | 4 | 5 | (* Session types *) 6 | 7 | CoInductive session_type := 8 | | SendTB n : (fin n -> type) -> (fin n -> session_type) -> session_type 9 | | RecvTB n : (fin n -> type) -> (fin n -> session_type) -> session_type 10 | | EndTB : session_type. 11 | 12 | 13 | Global Instance finvec_equiv `{Equiv T} n : Equiv (fin n -> T) := λ f g, ∀ i, f i ≡ g i. 14 | 15 | CoInductive session_type_equiv : Equiv session_type := 16 | | cteq_EndT : EndTB ≡ EndTB 17 | | cteq_SendT n t1 t2 f1 f2 : t1 ≡ t2 -> f1 ≡ f2 -> SendTB n t1 f1 ≡ SendTB n t2 f2 18 | | cteq_RecvT n t1 t2 f1 f2 : t1 ≡ t2 -> f1 ≡ f2 -> RecvTB n t1 f1 ≡ RecvTB n t2 f2. 19 | Global Existing Instance session_type_equiv. 20 | 21 | Axiom session_type_extensionality : ∀ σ1 σ2 : session_type, σ1 ≡ σ2 -> σ1 = σ2. 22 | 23 | (* 24 | Coq's default notion of equality is not good enough for coinductive types: 25 | the default equality is syntactic equality and not extensional equality. 26 | We add an axiom to make equality extensional. 27 | See https://coq.inria.fr/refman/language/core/coinductive.html: 28 | "More generally, as in the case of positive coinductive types, 29 | it is consistent to further identify extensional equality of coinductive 30 | types with propositional equality" 31 | Such an axiom is similar to functional extensionality, but for coinductive types. 32 | *) 33 | 34 | CoFixpoint dual (σ : session_type) : session_type := 35 | match σ with 36 | | SendTB n ts σs => RecvTB n ts (dual ∘ σs) 37 | | RecvTB n ts σs => SendTB n ts (dual ∘ σs) 38 | | EndBT => EndTB 39 | end. 40 | 41 | (* Interpretation of session types into linear lambda calculus types *) 42 | 43 | CoFixpoint toL (σ : session_type) : type := 44 | match σ with 45 | | SendTB n ts σs => FunT Lin (SumT n (λ i, PairT (toL (dual $ σs i)) (ts i))) UnitT 46 | | RecvTB n ts σs => FunT Lin UnitT (SumT n (λ i, PairT (toL (σs i)) (ts i))) 47 | | EndBT => FunT Lin UnitT UnitT 48 | end. 49 | 50 | (* Session type operations in terms of binary barriers *) 51 | 52 | Definition SendB e1 i e2 := 53 | LetPair (Pair e1 e2) (Fun "x" (Fun "y" 54 | (Fork (Fun "z" (App (Var "x") (Sum i (Pair (Var "z") (Var "y")))))))). 55 | Definition RecvB e := App e Unit. 56 | Definition ForkB e := Fork e. 57 | Definition CloseB (e : expr) := App e Unit. 58 | 59 | 60 | (* Helper definitions and lemmas *) 61 | 62 | Definition session_type_id (σ : session_type) : session_type := 63 | match σ with 64 | | SendTB n ts σs => SendTB n ts σs 65 | | RecvTB n ts σs => RecvTB n ts σs 66 | | EndBT => EndTB 67 | end. 68 | 69 | Lemma session_type_id_id (σ : session_type) : 70 | session_type_id σ = σ. 71 | Proof. 72 | by destruct σ. 73 | Qed. 74 | 75 | Lemma global_type_eq_alt (σ1 σ2 : session_type) : 76 | session_type_id σ1 = session_type_id σ2 -> σ1 = σ2. 77 | Proof. 78 | rewrite !session_type_id_id //. 79 | Defined. 80 | 81 | Definition type_id (t : type) := 82 | match t with 83 | | FunT l t1 t2 => FunT l t1 t2 84 | | UnitT => UnitT 85 | | PairT t1 t2 => PairT t1 t2 86 | | SumT n ts => SumT n ts 87 | end. 88 | 89 | Lemma type_id_id (t : type) : 90 | type_id t = t. 91 | Proof. 92 | by destruct t. 93 | Qed. 94 | 95 | Lemma env_split_left Γ : 96 | env_split Γ Γ ∅. 97 | Proof. 98 | unfold env_split. rewrite right_id. split; eauto. 99 | unfold disj. intros ???. smap. 100 | Qed. 101 | 102 | Definition toL1 (σ : session_type) : type := 103 | match σ with 104 | | SendTB n ts σs => SumT n (λ i, PairT (toL (dual $ σs i)) (ts i)) 105 | | RecvTB n ts σs => UnitT 106 | | EndBT => UnitT 107 | end. 108 | 109 | Lemma session_type_equiv_alt (σ1 σ2 : session_type) : 110 | session_type_id σ1 ≡ session_type_id σ2 -> σ1 ≡ σ2. 111 | Proof. 112 | intros. 113 | rewrite -(session_type_id_id σ1). 114 | rewrite -(session_type_id_id σ2). 115 | done. 116 | Defined. 117 | 118 | Lemma dual_dual σ : dual (dual σ) = σ. 119 | Proof. 120 | apply session_type_extensionality. 121 | apply session_type_equiv_alt. 122 | revert σ. cofix IH. intros []; simpl; constructor; try done; intros i; 123 | apply session_type_equiv_alt; apply IH. 124 | Qed. 125 | 126 | Lemma toL_toL1 σ : 127 | toL σ = FunT Lin (toL1 σ) (toL1 (dual σ)). 128 | Proof. 129 | rewrite -{1}(type_id_id (toL _)). 130 | destruct σ; simpl; eauto; simplify_eq. 131 | f_equal. f_equal. apply functional_extensionality. 132 | intros x. f_equal. rewrite dual_dual. done. 133 | Qed. 134 | 135 | Lemma toL_toL_dual_split σ : 136 | ∃ t1 t2, toL σ = FunT Lin t1 t2 ∧ toL (dual σ) = FunT Lin t2 t1. 137 | Proof. 138 | exists (toL1 σ), (toL1 (dual σ)). 139 | rewrite toL_toL1 //. split; eauto. 140 | rewrite toL_toL1 dual_dual //. 141 | Qed. 142 | 143 | 144 | 145 | Lemma env_bind_notin x Γ t : 146 | Γ !! x = None -> 147 | env_bind (<[ x := t ]> Γ) x t Γ. 148 | Proof. 149 | intros H. 150 | rewrite /env_bind H; split; simp. 151 | Qed. 152 | 153 | Lemma env_split_disjoint Γ Γ1 Γ2 : 154 | Γ = Γ1 ∪ Γ2 -> Γ1 ##ₘ Γ2 -> env_split Γ Γ1 Γ2. 155 | Proof. 156 | intros -> H. 157 | rewrite /env_split. split; eauto. 158 | rewrite /disj. intros i ??. 159 | specialize (H i). 160 | destruct (Γ1 !! i) eqn:E, (Γ2 !! i) eqn:F; rewrite ?E ?F; simp. 161 | Qed. 162 | 163 | Lemma env_var_singleton x t : 164 | env_var {[ x := t ]} x t. 165 | Proof. 166 | rewrite /env_var. exists ∅. 167 | split; eauto using env_unr_empty. 168 | Qed. 169 | 170 | Lemma env_var_singleton_eq x t1 t2 : 171 | t1 = t2 -> env_var {[ x := t1 ]} x t2. 172 | Proof. 173 | intros ->. apply env_var_singleton. 174 | Qed. 175 | 176 | (* Admissibility of typing rules *) 177 | 178 | (* Prove typing rule for ForkB admissible *) 179 | 180 | Lemma ForkB_typed Γ σ e : 181 | typed Γ e (FunT Lin (toL (dual σ)) UnitT) -> 182 | typed Γ (ForkB e) (toL σ). 183 | Proof. 184 | intros H. rewrite /ForkB. 185 | destruct (toL_toL_dual_split σ) as [t1 [t2 [H1 H2]]]. 186 | rewrite H1. 187 | eapply Fork_typed. 188 | rewrite -H2. 189 | exact H. 190 | Qed. 191 | 192 | (* Prove typing rule for SendB admissible *) 193 | 194 | Lemma SendB_typed Γ Γ1 Γ2 e1 e2 n ts σs i : 195 | env_split Γ Γ1 Γ2 -> 196 | typed Γ1 e1 (toL (SendTB n ts σs)) -> 197 | typed Γ2 e2 (ts i) -> 198 | typed Γ (SendB e1 i e2) (toL (σs i)). 199 | Proof. 200 | intros Hsplit H1 H2. 201 | rewrite /SendB. 202 | eapply LetPair_typed. 203 | { eapply env_split_left. } { eauto using typed. } 204 | eapply Fun_typed. 205 | { eapply env_bind_notin. smap. } { simp. } 206 | eapply Fun_typed. 207 | { eapply env_bind_notin. smap. } { simp. } 208 | eapply ForkB_typed. 209 | eapply Fun_typed. 210 | { eapply env_bind_notin. smap. } { simp. } 211 | eapply (App_typed _ {[ "x" := _ ]} {[ "y" := _; "z" := _ ]}). 212 | 1: { 213 | eapply env_split_disjoint; last solve_map_disjoint. 214 | apply map_eq. intros x. smap. } 215 | 2: { 216 | eapply (Sum_typed _ _ (λ i, PairT (toL (dual (σs i))) (ts i))). 217 | eapply (Pair_typed _ {[ "z" := _ ]} {[ "y" := _ ]}). 218 | + eapply env_split_disjoint; last solve_map_disjoint. 219 | apply map_eq. intros x. smap. 220 | + eapply Var_typed. eapply env_var_singleton. 221 | + eapply Var_typed. eapply env_var_singleton. 222 | } 223 | eapply Var_typed. 224 | eapply env_var_singleton_eq. 225 | rewrite -(type_id_id (toL _)). simpl. 226 | done. 227 | Qed. 228 | 229 | (* Prove typing rule for RecvB admissible *) 230 | 231 | Lemma RecvB_typed Γ e n ts σs : 232 | typed Γ e (toL (RecvTB n ts σs)) -> 233 | typed Γ (RecvB e) (SumT n (λ i, PairT (toL (σs i)) (ts i))). 234 | Proof. 235 | intros H. 236 | rewrite /RecvB. 237 | rewrite -(type_id_id (toL _)) /= in H. 238 | eapply App_typed; eauto using typed, env_unr_empty, env_split_left. 239 | Qed. 240 | 241 | (* Prove typing rule for CloseB admissible *) 242 | 243 | Lemma CloseB_typed Γ e : 244 | typed Γ e (toL EndTB) -> 245 | typed Γ (CloseB e) UnitT. 246 | Proof. 247 | intros H. rewrite /CloseB. 248 | rewrite -(type_id_id (toL _)) // in H. simpl in *. 249 | eapply App_typed; eauto using env_split_left, typed, env_unr_empty. 250 | Qed. -------------------------------------------------------------------------------- /theories/lambdabar/theorems.v: -------------------------------------------------------------------------------- 1 | From cgraphs.lambdabar Require Import invariant. 2 | 3 | 4 | (* The theorems are given in a slightly different order because some of the 5 | proofs of the earlier theorems depend on the later theorems. *) 6 | 7 | (* Paper theorem 7 part 1 *) 8 | Lemma fully_reachable_iff_deadlock_free ρ : 9 | fully_reachable ρ <-> deadlock_free ρ. 10 | Proof. 11 | split. 12 | - intros Hfr s [] i si. 13 | destruct (Hfr i); eauto. 14 | exfalso. induction H; naive_solver. 15 | - intros Hdf i. classical_left. 16 | eapply (Hdf (λ i, ¬ reachable ρ i)); 17 | first constructor; eauto using reachable. 18 | Qed. 19 | 20 | (* Paper theorem 10 part 1 *) 21 | Lemma fully_reachable_type_safety ρ : 22 | fully_reachable ρ -> type_safety ρ. 23 | Proof. 24 | intros Hfr i. destruct (Hfr i) as [|[]]; eauto. 25 | Qed. 26 | 27 | (* Paper theorem 10 part 2 *) 28 | Lemma fully_reachable_global_progress ρ : 29 | fully_reachable ρ -> global_progress ρ. 30 | Proof. 31 | intros Hfr. 32 | destruct (classic (∃ i, ¬ inactive ρ i)). 33 | - destruct H as [i Hi]. destruct (Hfr i); first naive_solver. 34 | clear Hi. right. induction H; eauto. 35 | - left. intros i. apply NNPP. eauto. 36 | Qed. 37 | 38 | (* Paper theorem 11 *) 39 | Lemma typed_full_reachability e ρ : 40 | typed ∅ e UnitT -> steps {[ 0 := Thread e ]} ρ -> fully_reachable ρ. 41 | Proof. 42 | intros Ht Hsteps. 43 | assert (ginv {[ 0 := Thread e ]}) as Hinv. 44 | { eapply initialization. done. } 45 | induction Hsteps. 46 | - eapply full_reachability. done. 47 | - eapply IHHsteps. destruct H. eapply preservation; eauto. 48 | Qed. 49 | 50 | (* Paper theorem 1 *) 51 | Lemma typed_global_progress e ρ : 52 | typed ∅ e UnitT -> steps {[ 0 := Thread e ]} ρ -> global_progress ρ. 53 | Proof. 54 | intros. eapply fully_reachable_global_progress, typed_full_reachability; done. 55 | Qed. 56 | -------------------------------------------------------------------------------- /theories/locks/lambdalock/definitions.v: -------------------------------------------------------------------------------- 1 | From cgraphs.locks.lambdalock Require Export langdef. 2 | 3 | Fixpoint expr_refs e := 4 | match e with 5 | | Val v => val_refs v 6 | | Var x => ∅ 7 | | Fun x e => expr_refs e 8 | | App e1 e2 => expr_refs e1 ∪ expr_refs e2 9 | | Unit => ∅ 10 | | Pair e1 e2 => expr_refs e1 ∪ expr_refs e2 11 | | LetPair e1 e2 => expr_refs e1 ∪ expr_refs e2 12 | | Sum i e => expr_refs e 13 | | MatchSum n e es => expr_refs e ∪ fin_union n (expr_refs ∘ es) 14 | | ForkBarrier e => expr_refs e 15 | | NewLock e => expr_refs e 16 | | ForkLock e1 e2 => expr_refs e1 ∪ expr_refs e2 17 | | Acquire e => expr_refs e 18 | | Release e1 e2 => expr_refs e1 ∪ expr_refs e2 19 | | Wait e => expr_refs e 20 | | Drop e => expr_refs e 21 | end 22 | with val_refs v := 23 | match v with 24 | | FunV x e => expr_refs e 25 | | UnitV => ∅ 26 | | PairV v1 v2 => val_refs v1 ∪ val_refs v2 27 | | SumV i v => val_refs v 28 | | BarrierV i => {[ i ]} 29 | | LockV i => {[ i ]} 30 | end. 31 | 32 | Definition obj_refs x := 33 | match x with 34 | | Thread e => expr_refs e 35 | | Barrier => ∅ 36 | | Lock refcnt o => 37 | match o with 38 | | Some v => val_refs v 39 | | None => ∅ 40 | end 41 | end. 42 | 43 | 44 | Inductive expr_head_waiting : expr -> nat -> Prop := 45 | | Barrier_waiting j v : 46 | expr_head_waiting (App (Val $ BarrierV j) (Val v)) j 47 | | ForkLock_waiting j v : 48 | expr_head_waiting (ForkLock (Val $ LockV j) (Val v)) j 49 | | Acquire_waiting j : 50 | expr_head_waiting (Acquire (Val $ LockV j)) j 51 | | Release_waiting j v : 52 | expr_head_waiting (Release (Val $ LockV j) (Val v)) j 53 | | Wait_waiting j : 54 | expr_head_waiting (Wait (Val $ LockV j)) j 55 | | Drop_waiting j : 56 | expr_head_waiting (Drop (Val $ LockV j)) j. 57 | 58 | Definition expr_waiting e j := 59 | ∃ k e', ctx k ∧ e = k e' ∧ expr_head_waiting e' j. 60 | 61 | Definition waiting (ρ : cfg) (i j : nat) := 62 | (∃ e, ρ !! i = Some (Thread e) ∧ expr_waiting e j) ∨ 63 | (∃ y, ρ !! j = Some y ∧ i ∈ obj_refs y ∧ ∀ e, y = Thread e -> ¬ expr_waiting e i). 64 | 65 | Definition can_step (ρ : cfg) (i : nat) := ∃ ρ', step i ρ ρ'. 66 | Definition inactive (ρ : cfg) (i : nat) := ρ !! i = None. 67 | 68 | Record deadlock (ρ : cfg) (s : nat -> Prop) := { 69 | dl_nostep i : s i -> ¬ can_step ρ i; 70 | dl_waiting i j : waiting ρ i j -> s i -> s j; 71 | }. 72 | 73 | Definition deadlock_free (ρ : cfg) := 74 | ∀ s, deadlock ρ s -> ∀ i, s i -> inactive ρ i. 75 | 76 | Inductive reachable (ρ : cfg) : nat -> Prop := 77 | | Can_step_reachable i : 78 | can_step ρ i -> reachable ρ i 79 | | Waiting_reachable i j : 80 | waiting ρ i j -> reachable ρ j -> reachable ρ i. 81 | 82 | Definition fully_reachable (ρ : cfg) := 83 | ∀ i, inactive ρ i ∨ reachable ρ i. 84 | 85 | Definition global_progress (ρ : cfg) := 86 | (∀ i, inactive ρ i) ∨ (∃ i, can_step ρ i). 87 | 88 | Definition type_safety (ρ : cfg) := 89 | ∀ i, inactive ρ i ∨ can_step ρ i ∨ ∃ j, waiting ρ i j. 90 | -------------------------------------------------------------------------------- /theories/locks/lambdalock/langdef.v: -------------------------------------------------------------------------------- 1 | From cgraphs.locks.lambdalock Require Export langtools. 2 | 3 | (* Expressions and values *) 4 | (* ---------------------- *) 5 | 6 | Inductive expr := 7 | | Val : val -> expr 8 | | Var : string -> expr 9 | | Fun : string -> expr -> expr 10 | | App : expr -> expr -> expr 11 | | Unit : expr 12 | | Pair : expr -> expr -> expr 13 | | LetPair : expr -> expr -> expr 14 | | Sum : nat -> expr -> expr 15 | | MatchSum n : expr -> (fin n -> expr) -> expr 16 | (* Barriers *) 17 | | ForkBarrier : expr -> expr 18 | (* Locks *) 19 | | NewLock : expr -> expr 20 | | ForkLock : expr -> expr -> expr 21 | | Acquire : expr -> expr 22 | | Release : expr -> expr -> expr 23 | | Wait : expr -> expr 24 | | Drop : expr -> expr 25 | with val := 26 | | FunV : string -> expr -> val 27 | | UnitV : val 28 | | PairV : val -> val -> val 29 | | SumV : nat -> val -> val 30 | | BarrierV : nat -> val 31 | | LockV : nat -> val. 32 | 33 | 34 | (* Type system *) 35 | (* ----------- *) 36 | 37 | Inductive linearity := Lin | Unr. 38 | 39 | Inductive lockstate := Opened | Closed. 40 | Inductive lockownership := Owner | Client. 41 | Definition lockcap : Type := lockownership * lockstate. 42 | Inductive lockownership_split : lockownership -> lockownership -> lockownership -> Prop := 43 | | lo_split_1 : lockownership_split Owner Client Owner 44 | | lo_split_2 : lockownership_split Owner Owner Client 45 | | lo_split_3 : lockownership_split Client Client Client. 46 | Inductive lockstate_split : lockstate -> lockstate -> lockstate -> Prop := 47 | | ls_split_1 : lockstate_split Opened Closed Opened 48 | | ls_split_2 : lockstate_split Opened Opened Closed 49 | | ls_split_3 : lockstate_split Closed Closed Closed. 50 | Definition lockcap_split l1 l2 l3 := 51 | lockownership_split l1.1 l2.1 l3.1 ∧ lockstate_split l1.2 l2.2 l3.2. 52 | 53 | CoInductive type := 54 | | FunT : linearity -> type -> type -> type 55 | | UnitT : type 56 | | PairT : type -> type -> type 57 | | SumT n : (fin n -> type) -> type 58 | | LockT : lockcap -> type -> type. 59 | 60 | CoInductive unr : type -> Prop := 61 | | Fun_unr t1 t2 : unr (FunT Unr t1 t2) 62 | | Unit_unr : unr UnitT 63 | | Pair_unr t1 t2 : unr t1 -> unr t2 -> unr (PairT t1 t2) 64 | | Sum_unr n ts : (∀ i, unr (ts i)) -> unr (SumT n ts). 65 | 66 | (* We define linear environment splitting here. 67 | On paper this is implicit in Γ1,Γ2 ⊢ e : A. 68 | In Coq we have to explicitly say env_split Γ Γ1 Γ2, and typed Γ e A. *) 69 | Definition env := gmap string type. 70 | 71 | Definition env_unr (Γ : env) := 72 | ∀ x t, Γ !! x = Some t -> unr t. 73 | 74 | Definition disj (Γ1 Γ2 : env) := 75 | ∀ i t1 t2, Γ1 !! i = Some t1 -> Γ2 !! i = Some t2 -> t1 = t2 ∧ unr t1. 76 | 77 | Definition env_split (Γ : env) (Γ1 : env) (Γ2 : env) := 78 | Γ = Γ1 ∪ Γ2 ∧ disj Γ1 Γ2. 79 | 80 | Definition env_bind (Γ' : env) (x : string) (t : type) (Γ : env) := 81 | Γ' = <[ x := t ]> Γ ∧ ∀ t', Γ !! x = Some t' -> unr t'. 82 | 83 | Definition env_var (Γ : env) (x : string) (t : type) := 84 | ∃ Γ', Γ = <[ x := t ]> Γ' ∧ env_unr Γ'. 85 | 86 | 87 | Inductive typed : env -> expr -> type -> Prop := 88 | (* Base language *) 89 | | Var_typed Γ x t : 90 | env_var Γ x t -> 91 | typed Γ (Var x) t 92 | | Fun_typed Γ Γ' x e t1 t2 l : 93 | env_bind Γ' x t1 Γ -> 94 | (l = Unr -> env_unr Γ) -> 95 | typed Γ' e t2 -> 96 | typed Γ (Fun x e) (FunT l t1 t2) 97 | | App_typed Γ Γ1 Γ2 e1 e2 t1 t2 l : 98 | env_split Γ Γ1 Γ2 -> 99 | typed Γ1 e1 (FunT l t1 t2) -> 100 | typed Γ2 e2 t1 -> 101 | typed Γ (App e1 e2) t2 102 | | Unit_typed Γ : 103 | env_unr Γ -> 104 | typed Γ Unit UnitT 105 | | Pair_typed Γ Γ1 Γ2 e1 e2 t1 t2 : 106 | env_split Γ Γ1 Γ2 -> 107 | typed Γ1 e1 t1 -> 108 | typed Γ2 e2 t2 -> 109 | typed Γ (Pair e1 e2) (PairT t1 t2) 110 | | LetPair_typed Γ Γ1 Γ2 e1 e2 t1 t2 t : 111 | env_split Γ Γ1 Γ2 -> 112 | typed Γ1 e1 (PairT t1 t2) -> 113 | typed Γ2 e2 (FunT Lin t1 (FunT Lin t2 t)) -> 114 | typed Γ (LetPair e1 e2) t 115 | | Sum_typed Γ n (ts : fin n -> type) i e : 116 | typed Γ e (ts i) -> 117 | typed Γ (Sum i e) (SumT n ts) 118 | | MatchSumN_typed n Γ Γ1 Γ2 t (ts : fin n -> type) es e : 119 | env_split Γ Γ1 Γ2 -> 120 | (n = 0 -> env_unr Γ2) -> 121 | typed Γ1 e (SumT n ts) -> 122 | (∀ i, typed Γ2 (es i) (FunT Lin (ts i) t)) -> 123 | typed Γ (MatchSum n e es) t 124 | (* Barriers *) 125 | | Fork_typed Γ e t1 t2 : 126 | typed Γ e (FunT Lin (FunT Lin t2 t1) UnitT) -> 127 | typed Γ (ForkBarrier e) (FunT Lin t1 t2) 128 | (* Locks *) 129 | | NewLock_typed Γ e t : 130 | typed Γ e t -> 131 | typed Γ (NewLock e) (LockT (Owner,Closed) t) 132 | | ForkLock_typed Γ Γ1 Γ2 e1 e2 t l1 l2 l3 : 133 | env_split Γ Γ1 Γ2 -> 134 | lockcap_split l1 l2 l3 -> 135 | typed Γ1 e1 (LockT l1 t) -> 136 | typed Γ2 e2 (FunT Lin (LockT l2 t) UnitT) -> 137 | typed Γ (ForkLock e1 e2) (LockT l3 t) 138 | | Acquire_typed Γ e t lo : 139 | typed Γ e (LockT (lo,Closed) t) -> 140 | typed Γ (Acquire e) (PairT (LockT (lo,Opened) t) t) 141 | | Release_typed Γ Γ1 Γ2 e1 e2 t lo : 142 | env_split Γ Γ1 Γ2 -> 143 | typed Γ1 e1 (LockT (lo,Opened) t) -> 144 | typed Γ2 e2 t -> 145 | typed Γ (Release e1 e2) (LockT (lo,Closed) t) 146 | | Wait_typed Γ e t : 147 | typed Γ e (LockT (Owner,Closed) t) -> 148 | typed Γ (Wait e) t 149 | | Drop_typed Γ e t : 150 | typed Γ e (LockT (Client,Closed) t) -> 151 | typed Γ (Drop e) UnitT. 152 | 153 | 154 | (* Operational semantics *) 155 | (* --------------------- *) 156 | 157 | Definition subst (x:string) (a:val) := fix rec e := 158 | match e with 159 | | Val _ => e 160 | | Var x' => if decide (x = x') then Val a else e 161 | | Fun x' e => Fun x' (if decide (x = x') then e else rec e) 162 | | App e1 e2 => App (rec e1) (rec e2) 163 | | Unit => Unit 164 | | Pair e1 e2 => Pair (rec e1) (rec e2) 165 | | LetPair e1 e2 => LetPair (rec e1) (rec e2) 166 | | Sum n e => Sum n (rec e) 167 | | MatchSum n e1 e2 => MatchSum n (rec e1) (rec ∘ e2) 168 | | ForkBarrier e => ForkBarrier (rec e) 169 | | NewLock e => NewLock (rec e) 170 | | ForkLock e1 e2 => ForkLock (rec e1) (rec e2) 171 | | Acquire e => Acquire (rec e) 172 | | Release e1 e2 => Release (rec e1) (rec e2) 173 | | Wait e => Wait (rec e) 174 | | Drop e => Drop (rec e) 175 | end. 176 | 177 | Inductive pure_step : expr -> expr -> Prop := 178 | | Fun_step x e : 179 | pure_step (Fun x e) (Val $ FunV x e) 180 | | App_step x e a : 181 | pure_step (App (Val $ FunV x e) (Val a)) (subst x a e) 182 | | Unit_step : 183 | pure_step Unit (Val $ UnitV) 184 | | Pair_step v1 v2 : 185 | pure_step (Pair (Val v1) (Val v2)) (Val $ PairV v1 v2) 186 | | LetPair_step v1 v2 e: 187 | pure_step (LetPair (Val $ PairV v1 v2) e) (App (App e (Val v1)) (Val v2)) 188 | | Sum_step n v : 189 | pure_step (Sum n (Val v)) (Val $ SumV n v) 190 | | MatchSum_step n (i : fin n) v es : 191 | pure_step (MatchSum n (Val $ SumV i v) es) (App (es i) (Val v)). 192 | 193 | Inductive ctx1 : (expr -> expr) -> Prop := 194 | | Ctx_App_l e : ctx1 (λ x, App x e) 195 | | Ctx_App_r e : ctx1 (λ x, App e x) 196 | | Ctx_Pair_l e : ctx1 (λ x, Pair x e) 197 | | Ctx_Pair_r e : ctx1 (λ x, Pair e x) 198 | | Ctx_LetPair e : ctx1 (λ x, LetPair x e) 199 | | Ctx_Sum i : ctx1 (λ x, Sum i x) 200 | | Ctx_MatchSum n es : ctx1 (λ x, MatchSum n x es) 201 | | Ctx_ForkBarrier : ctx1 (λ x, ForkBarrier x) 202 | | Ctx_NewLock : ctx1 (λ x, NewLock x) 203 | | Ctx_ForkLock_l e : ctx1 (λ x, ForkLock x e) 204 | | Ctx_ForkLock_r e : ctx1 (λ x, ForkLock e x) 205 | | Ctx_Acquire : ctx1 (λ x, Acquire x) 206 | | Ctx_Release_l e : ctx1 (λ x, Release x e) 207 | | Ctx_Release_r e : ctx1 (λ x, Release e x) 208 | | Ctx_Wait : ctx1 (λ x, Wait x) 209 | | Ctx_Drop : ctx1 (λ x, Drop x). 210 | 211 | Inductive ctx : (expr -> expr) -> Prop := 212 | | Ctx_id : ctx id 213 | | Ctx_comp k1 k2 : ctx1 k1 -> ctx k2 -> ctx (k1 ∘ k2). 214 | 215 | Inductive obj := Thread (e : expr) | Barrier | Lock (refcnt : nat) (o : option val). 216 | Definition cfg := gmap nat obj. 217 | 218 | Inductive local_step : nat -> cfg -> cfg -> Prop := 219 | (* Base language *) 220 | | Pure_step i k e e' : 221 | ctx k -> pure_step e e' -> 222 | local_step i {[ i := Thread (k e) ]} {[ i := Thread (k e') ]} 223 | | Exit_step i : 224 | local_step i {[ i := Thread (Val UnitV) ]} ∅ 225 | (* Barriers *) 226 | | Fork_step i j n k v : 227 | i ≠ j -> i ≠ n -> j ≠ n -> ctx k -> 228 | local_step i {[ i := Thread (k (ForkBarrier (Val v))) ]} 229 | {[ i := Thread (k (Val $ BarrierV n)); 230 | j := Thread (App (Val v) (Val $ BarrierV n)); 231 | n := Barrier ]} 232 | | Sync_step i j n k1 k2 v1 v2 : 233 | i ≠ j -> i ≠ n -> j ≠ n -> ctx k1 -> ctx k2 -> 234 | local_step n {[ i := Thread (k1 (App (Val $ BarrierV n) (Val v1))); 235 | j := Thread (k2 (App (Val $ BarrierV n) (Val v2))); 236 | n := Barrier ]} 237 | {[ i := Thread (k1 $ Val v2); 238 | j := Thread (k2 $ Val v1) ]} 239 | (* Locks *) 240 | | NewLock_step v k n i: 241 | i ≠ n -> ctx k -> 242 | local_step i {[ i := Thread (k (NewLock (Val v))) ]} 243 | {[ i := Thread (k (Val $ LockV n)); 244 | n := Lock 0 (Some v) ]} 245 | | ForkLock_step v o k i j n refcnt : 246 | i ≠ j -> i ≠ n -> j ≠ n -> ctx k -> 247 | local_step n {[ i := Thread (k (ForkLock (Val $ LockV n) (Val v))); 248 | n := Lock refcnt o ]} 249 | {[ i := Thread (k (Val $ LockV n)); 250 | j := Thread (App (Val v) (Val $ LockV n)); 251 | n := Lock (S refcnt) o ]} 252 | | Acquire_step v k i n refcnt : 253 | i ≠ n -> ctx k -> 254 | local_step n {[ i := Thread (k (Acquire (Val $ LockV n))); 255 | n := Lock refcnt (Some v) ]} 256 | {[ i := Thread (k (Val $ PairV (LockV n) v)); 257 | n := Lock refcnt None ]} 258 | | Release_step v k i n refcnt : 259 | i ≠ n -> ctx k -> 260 | local_step n {[ i := Thread (k (Release (Val $ LockV n) (Val v))); 261 | n := Lock refcnt None ]} 262 | {[ i := Thread (k (Val $ LockV n)); 263 | n := Lock refcnt (Some v) ]} 264 | | Wait_step v k i n : 265 | i ≠ n -> ctx k -> 266 | local_step n {[ i := Thread (k (Wait (Val $ LockV n))); 267 | n := Lock 0 (Some v) ]} 268 | {[ i := Thread (k (Val v)) ]} 269 | | Drop_step o k i n refcnt : 270 | i ≠ n -> ctx k -> 271 | local_step n {[ i := Thread (k (Drop (Val $ LockV n))); 272 | n := Lock (S refcnt) o ]} 273 | {[ i := Thread (k (Val $ UnitV)); 274 | n := Lock refcnt o ]}. 275 | 276 | Inductive step : nat -> cfg -> cfg -> Prop := 277 | | Frame_step ρ ρ' ρf i : 278 | ρ ##ₘ ρf -> ρ' ##ₘ ρf -> 279 | local_step i ρ ρ' -> step i (ρ ∪ ρf) (ρ' ∪ ρf). 280 | 281 | Definition step' ρ ρ' := ∃ i, step i ρ ρ'. 282 | Definition steps := rtc step'. 283 | 284 | -------------------------------------------------------------------------------- /theories/locks/lambdalock/langtools.v: -------------------------------------------------------------------------------- 1 | From iris.proofmode Require Export base tactics classes. 2 | From cgraphs.cgraphs Require Export util. 3 | From Coq.Logic Require Export FunctionalExtensionality Classical. 4 | From cgraphs Require Export seplogic. 5 | From stdpp Require Export gmap. 6 | Require Export cgraphs.cgraphs.genericinv. 7 | 8 | Ltac inv H := inversion H; clear H; simplify_eq. -------------------------------------------------------------------------------- /theories/locks/lambdalock/letmacro.v: -------------------------------------------------------------------------------- 1 | From cgraphs.locks.lambdalock Require Export langdef. 2 | 3 | (* In this file we demonstrate how typed macros work. *) 4 | (* We define a macro for let in terms of function application and lambda. *) 5 | 6 | Definition Let x e1 e2 := App (Fun x e2) e1. 7 | 8 | (* Check Let. *) 9 | (* Check Fun. *) 10 | 11 | (* We can now prove a typing rule for Let *) 12 | 13 | Lemma Let_typed Γ Γ1 Γ1' Γ2 x e1 e2 t1 t2 : 14 | env_split Γ Γ1 Γ2 -> 15 | env_bind Γ1' x t1 Γ1 -> 16 | typed Γ1' e2 t2 -> 17 | typed Γ2 e1 t1 -> 18 | typed Γ (Let x e1 e2) t2. 19 | Proof. 20 | intros Hs Hb H1 H2. 21 | unfold Let. 22 | eapply App_typed; eauto. 23 | eapply (Fun_typed _ _ _ _ _ _ Lin); eauto. 24 | intros [=]. 25 | Qed. 26 | 27 | (* Check Let_typed. *) 28 | (* Check Fun_typed. *) 29 | 30 | (* We now have a lemma that lets us type check our Let construct using the 31 | usual typing rule for let. From the outside, this gives the same interface 32 | as if we had added Let as a primitive expression and added a typing rule 33 | to our language: *) 34 | 35 | (* 36 | Inductive typed : env -> expr -> type -> Prop := 37 | | ... 38 | | Let_typed Γ Γ1 Γ1' Γ2 x e1 e2 t1 t2 : 39 | env_split Γ Γ1 Γ2 -> 40 | env_bind Γ1' x t1 Γ1 -> 41 | typed Γ1' e2 t2 -> 42 | typed Γ2 e1 t1 -> 43 | typed Γ (Let x e1 e2) t2 44 | | ... 45 | *) -------------------------------------------------------------------------------- /theories/locks/lambdalock/theorems.v: -------------------------------------------------------------------------------- 1 | From cgraphs.locks.lambdalock Require Import invariant. 2 | 3 | 4 | Lemma fully_reachable_iff_deadlock_free ρ : 5 | fully_reachable ρ <-> deadlock_free ρ. 6 | Proof. 7 | split. 8 | - intros Hfr s [] i si. 9 | destruct (Hfr i); eauto. 10 | exfalso. induction H; naive_solver. 11 | - intros Hdf i. classical_left. 12 | eapply (Hdf (λ i, ¬ reachable ρ i)); 13 | first constructor; eauto using reachable. 14 | Qed. 15 | 16 | Lemma fully_reachable_type_safety ρ : 17 | fully_reachable ρ -> type_safety ρ. 18 | Proof. 19 | intros Hfr i. destruct (Hfr i) as [|[]]; eauto. 20 | Qed. 21 | 22 | Lemma fully_reachable_global_progress ρ : 23 | fully_reachable ρ -> global_progress ρ. 24 | Proof. 25 | intros Hfr. 26 | destruct (classic (∃ i, ¬ inactive ρ i)). 27 | - destruct H as [i Hi]. destruct (Hfr i); first naive_solver. 28 | clear Hi. right. induction H; eauto. 29 | - left. intros i. apply NNPP. eauto. 30 | Qed. 31 | 32 | Lemma typed_full_reachability e ρ : 33 | typed ∅ e UnitT -> steps {[ 0 := Thread e ]} ρ -> fully_reachable ρ. 34 | Proof. 35 | intros Ht Hsteps. 36 | assert (ginv {[ 0 := Thread e ]}) as Hinv. 37 | { eapply initialization. done. } 38 | induction Hsteps. 39 | - eapply full_reachability. done. 40 | - eapply IHHsteps. destruct H. eapply preservation; eauto. 41 | Qed. 42 | 43 | Lemma typed_global_progress e ρ : 44 | typed ∅ e UnitT -> steps {[ 0 := Thread e ]} ρ -> global_progress ρ. 45 | Proof. 46 | intros. eapply fully_reachable_global_progress, typed_full_reachability; done. 47 | Qed. 48 | -------------------------------------------------------------------------------- /theories/locks/lambdalockpp/definitions.v: -------------------------------------------------------------------------------- 1 | From cgraphs.locks.lambdalockpp Require Export langdef. 2 | 3 | (* The definition of the set of barrier references in an expression. *) 4 | Fixpoint expr_refs e := 5 | match e with 6 | | Val v => val_refs v 7 | | Var x => ∅ 8 | | Fun x e => expr_refs e 9 | | App e1 e2 => expr_refs e1 ∪ expr_refs e2 10 | | Unit => ∅ 11 | | Pair e1 e2 => expr_refs e1 ∪ expr_refs e2 12 | | LetPair e1 e2 => expr_refs e1 ∪ expr_refs e2 13 | | Sum i e => expr_refs e 14 | | MatchSum n e es => expr_refs e ∪ fin_union n (expr_refs ∘ es) 15 | | ForkBarrier e => expr_refs e 16 | | NewLock i e => expr_refs e 17 | | DropLock i e => expr_refs e 18 | | ForkLock e1 e2 => expr_refs e1 ∪ expr_refs e2 19 | | Acquire i e => expr_refs e 20 | | Release i e1 e2 => expr_refs e1 ∪ expr_refs e2 21 | | Wait i e => expr_refs e 22 | | NewGroup => ∅ 23 | | DropGroup e => expr_refs e 24 | end 25 | with val_refs v := 26 | match v with 27 | | FunV x e => expr_refs e 28 | | UnitV => ∅ 29 | | PairV v1 v2 => val_refs v1 ∪ val_refs v2 30 | | SumV i v => val_refs v 31 | | BarrierV i => {[ i ]} 32 | | LockGV i ls => {[ i ]} 33 | end. 34 | 35 | Definition gmap_union `{Countable K} {V} `{Countable R} (f : V -> gset R) (xs : gmap K V) : gset R := 36 | map_fold (λ k a s, s ∪ f a) ∅ xs. 37 | 38 | Definition obj_refs x := 39 | match x with 40 | | Thread e => expr_refs e 41 | | Barrier => ∅ 42 | | LockG refcnt xs => gmap_union (from_option val_refs ∅ ∘ snd) xs 43 | end. 44 | 45 | 46 | Inductive expr_head_waiting : expr -> nat -> Prop := 47 | | Barrier_waiting j v : 48 | expr_head_waiting (App (Val $ BarrierV j) (Val v)) j 49 | | ForkLock_waiting j v ls : 50 | expr_head_waiting (ForkLock (Val $ LockGV j ls) (Val v)) j 51 | | Acquire_waiting j ls i : 52 | expr_head_waiting (Acquire i (Val $ LockGV j ls)) j 53 | | Release_waiting j v ls i : 54 | expr_head_waiting (Release i (Val $ LockGV j ls) (Val v)) j 55 | | Wait_waiting j ls i : 56 | expr_head_waiting (Wait i (Val $ LockGV j ls)) j 57 | | NewLock_waiting j ls i : 58 | expr_head_waiting (NewLock i (Val $ LockGV j ls)) j 59 | | DropLock_waiting j ls i : 60 | expr_head_waiting (DropLock i (Val $ LockGV j ls)) j 61 | | DropGroup_waiting j ls : 62 | expr_head_waiting (DropGroup (Val $ LockGV j ls)) j. 63 | 64 | 65 | (* Paper definition 2 *) 66 | Definition expr_waiting e j := 67 | ∃ k e', ctx k ∧ e = k e' ∧ expr_head_waiting e' j. 68 | 69 | Definition waiting (ρ : cfg) (i j : nat) := 70 | (∃ e, ρ !! i = Some (Thread e) ∧ expr_waiting e j) ∨ 71 | (∃ y, ρ !! j = Some y ∧ i ∈ obj_refs y ∧ ∀ e, y = Thread e -> ¬ expr_waiting e i). 72 | 73 | (* These definitions are not explicitly given in the paper, but we factor them out in Coq *) 74 | Definition can_step (ρ : cfg) (i : nat) := ∃ ρ', step i ρ ρ'. 75 | Definition inactive (ρ : cfg) (i : nat) := ρ !! i = None. 76 | 77 | (* Paper definition 3 *) 78 | Record deadlock (ρ : cfg) (s : nat -> Prop) := { 79 | dl_nostep i : s i -> ¬ can_step ρ i; 80 | dl_waiting i j : waiting ρ i j -> s i -> s j; 81 | }. 82 | 83 | (* Paper definition 4 *) 84 | Definition deadlock_free (ρ : cfg) := 85 | ∀ s, deadlock ρ s -> ∀ i, s i -> inactive ρ i. 86 | 87 | (* Paper definition 5 *) 88 | Inductive reachable (ρ : cfg) : nat -> Prop := 89 | | Can_step_reachable i : 90 | can_step ρ i -> reachable ρ i 91 | | Waiting_reachable i j : 92 | waiting ρ i j -> reachable ρ j -> reachable ρ i. 93 | 94 | (* Paper definition 6 *) 95 | Definition fully_reachable (ρ : cfg) := 96 | ∀ i, inactive ρ i ∨ reachable ρ i. 97 | 98 | (* Paper definition 8 *) 99 | Definition global_progress (ρ : cfg) := 100 | (∀ i, inactive ρ i) ∨ (∃ i, can_step ρ i). 101 | 102 | (* Paper definition 9 *) 103 | Definition type_safety (ρ : cfg) := 104 | ∀ i, inactive ρ i ∨ can_step ρ i ∨ ∃ j, waiting ρ i j. 105 | -------------------------------------------------------------------------------- /theories/locks/lambdalockpp/langdef.v: -------------------------------------------------------------------------------- 1 | From cgraphs.locks.lambdalockpp Require Export langtools. 2 | From cgraphs.cgraphs Require Import util. 3 | 4 | (* Expressions and values *) 5 | (* ---------------------- *) 6 | 7 | Inductive expr := 8 | | Val : val -> expr 9 | | Var : string -> expr 10 | | Fun : string -> expr -> expr 11 | | App : expr -> expr -> expr 12 | | Unit : expr 13 | | Pair : expr -> expr -> expr 14 | | LetPair : expr -> expr -> expr 15 | | Sum : nat -> expr -> expr 16 | | MatchSum n : expr -> (fin n -> expr) -> expr 17 | (* Barriers *) 18 | | ForkBarrier : expr -> expr 19 | (* Locks *) 20 | | NewGroup : expr 21 | | DropGroup : expr -> expr 22 | | NewLock : nat -> expr -> expr 23 | | DropLock : nat -> expr -> expr 24 | | ForkLock : expr -> expr -> expr 25 | | Acquire : nat -> expr -> expr 26 | | Release : nat -> expr -> expr -> expr 27 | | Wait : nat -> expr -> expr 28 | with val := 29 | | FunV : string -> expr -> val 30 | | UnitV : val 31 | | PairV : val -> val -> val 32 | | SumV : nat -> val -> val 33 | | BarrierV : nat -> val 34 | | LockGV : nat -> list nat -> val. 35 | 36 | 37 | (* Type system *) 38 | (* ----------- *) 39 | 40 | Inductive linearity := Lin | Unr. 41 | 42 | Inductive lockstate := Opened | Closed. 43 | Inductive lockownership := Owner | Client. 44 | Definition lockcap : Type := lockownership * lockstate. 45 | Inductive lockownership_split : lockownership -> lockownership -> lockownership -> Prop := 46 | | lo_split_1 : lockownership_split Owner Client Owner 47 | | lo_split_2 : lockownership_split Owner Owner Client 48 | | lo_split_3 : lockownership_split Client Client Client. 49 | Inductive lockstate_split : lockstate -> lockstate -> lockstate -> Prop := 50 | | ls_split_1 : lockstate_split Opened Closed Opened 51 | | ls_split_2 : lockstate_split Opened Opened Closed 52 | | ls_split_3 : lockstate_split Closed Closed Closed. 53 | Definition lockcap_split l1 l2 l3 := 54 | lockownership_split l1.1 l2.1 l3.1 ∧ lockstate_split l1.2 l2.2 l3.2. 55 | 56 | CoInductive type := 57 | | FunT : linearity -> type -> type -> type 58 | | UnitT : type 59 | | PairT : type -> type -> type 60 | | SumT n : (fin n -> type) -> type 61 | | LockGT : list (lockcap * type) -> type. 62 | 63 | Definition lockcaps_split (xs1 xs2 xs3 : list (lockcap * type)) : Prop := 64 | Forall3 (λ '(l1,t1) '(l2, t2) '(l3, t3), t1 = t2 ∧ t2 = t3 ∧ lockcap_split l1 l2 l3) xs1 xs2 xs3. 65 | 66 | CoInductive unr : type -> Prop := 67 | | Fun_unr t1 t2 : unr (FunT Unr t1 t2) 68 | | Unit_unr : unr UnitT 69 | | Pair_unr t1 t2 : unr t1 -> unr t2 -> unr (PairT t1 t2) 70 | | Sum_unr n ts : (∀ i, unr (ts i)) -> unr (SumT n ts). 71 | 72 | (* We define linear environment splitting here. 73 | On paper this is implicit in Γ1,Γ2 ⊢ e : A. 74 | In Coq we have to explicitly say env_split Γ Γ1 Γ2, and typed Γ e A. *) 75 | Definition env := gmap string type. 76 | 77 | Definition env_unr (Γ : env) := 78 | ∀ x t, Γ !! x = Some t -> unr t. 79 | 80 | Definition disj (Γ1 Γ2 : env) := 81 | ∀ i t1 t2, Γ1 !! i = Some t1 -> Γ2 !! i = Some t2 -> t1 = t2 ∧ unr t1. 82 | 83 | Definition env_split (Γ : env) (Γ1 : env) (Γ2 : env) := 84 | Γ = Γ1 ∪ Γ2 ∧ disj Γ1 Γ2. 85 | 86 | Definition env_bind (Γ' : env) (x : string) (t : type) (Γ : env) := 87 | Γ' = <[ x := t ]> Γ ∧ ∀ t', Γ !! x = Some t' -> unr t'. 88 | 89 | Definition env_var (Γ : env) (x : string) (t : type) := 90 | ∃ Γ', Γ = <[ x := t ]> Γ' ∧ env_unr Γ'. 91 | 92 | Definition finlist {T:Type} {n:nat} (f : fin n -> T) (xs : list T) := 93 | n = length xs ∧ ∀ i, Some (f i) = xs !! (i : nat). 94 | 95 | Inductive typed : env -> expr -> type -> Prop := 96 | (* Base language *) 97 | | Var_typed Γ x t : 98 | env_var Γ x t -> 99 | typed Γ (Var x) t 100 | | Fun_typed Γ Γ' x e t1 t2 l : 101 | env_bind Γ' x t1 Γ -> 102 | (l = Unr -> env_unr Γ) -> 103 | typed Γ' e t2 -> 104 | typed Γ (Fun x e) (FunT l t1 t2) 105 | | App_typed Γ Γ1 Γ2 e1 e2 t1 t2 l : 106 | env_split Γ Γ1 Γ2 -> 107 | typed Γ1 e1 (FunT l t1 t2) -> 108 | typed Γ2 e2 t1 -> 109 | typed Γ (App e1 e2) t2 110 | | Unit_typed Γ : 111 | env_unr Γ -> 112 | typed Γ Unit UnitT 113 | | Pair_typed Γ Γ1 Γ2 e1 e2 t1 t2 : 114 | env_split Γ Γ1 Γ2 -> 115 | typed Γ1 e1 t1 -> 116 | typed Γ2 e2 t2 -> 117 | typed Γ (Pair e1 e2) (PairT t1 t2) 118 | | LetPair_typed Γ Γ1 Γ2 e1 e2 t1 t2 t : 119 | env_split Γ Γ1 Γ2 -> 120 | typed Γ1 e1 (PairT t1 t2) -> 121 | typed Γ2 e2 (FunT Lin t1 (FunT Lin t2 t)) -> 122 | typed Γ (LetPair e1 e2) t 123 | | Sum_typed Γ n (ts : fin n -> type) i e : 124 | typed Γ e (ts i) -> 125 | typed Γ (Sum i e) (SumT n ts) 126 | | MatchSumN_typed n Γ Γ1 Γ2 t (ts : fin n -> type) es e : 127 | env_split Γ Γ1 Γ2 -> 128 | (n = 0 -> env_unr Γ2) -> 129 | typed Γ1 e (SumT n ts) -> 130 | (∀ i, typed Γ2 (es i) (FunT Lin (ts i) t)) -> 131 | typed Γ (MatchSum n e es) t 132 | (* Barriers *) 133 | | Fork_typed Γ e t1 t2 : 134 | typed Γ e (FunT Lin (FunT Lin t2 t1) UnitT) -> 135 | typed Γ (ForkBarrier e) (FunT Lin t1 t2) 136 | (* Locks *) 137 | | NewGroup_typed Γ : 138 | env_unr Γ -> 139 | typed Γ NewGroup (LockGT []) 140 | | DropGroup_typed Γ e : 141 | typed Γ e (LockGT []) -> 142 | typed Γ (DropGroup e) UnitT 143 | | NewLock_typed Γ i e t xs : 144 | typed Γ e (LockGT xs) -> 145 | typed Γ (NewLock i e) (LockGT (insert2 i ((Owner,Opened),t) xs)) 146 | | DropLock_typed Γ i e xs t : 147 | xs !! i = Some ((Client,Closed),t) -> 148 | typed Γ e (LockGT xs) -> 149 | typed Γ (DropLock i e) (LockGT (delete i xs)) 150 | | Wait_typed Γ i e xs t : 151 | (* Needs precondition *) 152 | xs !! i = Some ((Owner,Closed),t) -> 153 | (∀ j ownership state t', xs !! j = Some ((ownership,state),t') -> 154 | (state = Closed) ∧ (j < i -> ownership = Owner)) -> 155 | typed Γ e (LockGT xs) -> 156 | typed Γ (Wait i e) (PairT (LockGT (delete i xs)) t) 157 | | Acquire_typed Γ i e xs t a : 158 | (* Needs precondition *) 159 | xs !! i = Some ((a,Closed),t) -> 160 | (∀ j ownership state t', j < i -> xs !! j = Some ((ownership,state),t') -> state = Closed) -> 161 | typed Γ e (LockGT xs) -> 162 | typed Γ (Acquire i e) (PairT (LockGT (<[ i := ((a,Opened),t) ]> xs)) t) 163 | | Release_typed Γ Γ1 Γ2 i e1 e2 xs t a : 164 | xs !! i = Some ((a,Opened),t) -> 165 | env_split Γ Γ1 Γ2 -> 166 | typed Γ1 e1 (LockGT xs) -> 167 | typed Γ2 e2 t -> 168 | typed Γ (Release i e1 e2) (LockGT (<[ i := ((a,Closed),t) ]> xs)) 169 | | ForkLock_typed Γ Γ1 Γ2 e1 e2 xs1 xs2 xs3 : 170 | env_split Γ Γ1 Γ2 -> 171 | lockcaps_split xs1 xs2 xs3 -> 172 | typed Γ1 e1 (LockGT xs1) -> 173 | typed Γ2 e2 (FunT Lin (LockGT xs2) UnitT) -> 174 | typed Γ (ForkLock e1 e2) (LockGT xs3). 175 | 176 | (* Operational semantics *) 177 | (* --------------------- *) 178 | 179 | Definition subst (x:string) (a:val) := fix rec e := 180 | match e with 181 | | Val _ => e 182 | | Var x' => if decide (x = x') then Val a else e 183 | | Fun x' e => Fun x' (if decide (x = x') then e else rec e) 184 | | App e1 e2 => App (rec e1) (rec e2) 185 | | Unit => Unit 186 | | Pair e1 e2 => Pair (rec e1) (rec e2) 187 | | LetPair e1 e2 => LetPair (rec e1) (rec e2) 188 | | Sum n e => Sum n (rec e) 189 | | MatchSum n e1 e2 => MatchSum n (rec e1) (rec ∘ e2) 190 | | ForkBarrier e => ForkBarrier (rec e) 191 | | NewGroup => NewGroup 192 | | DropGroup e => DropGroup (rec e) 193 | | NewLock i e => NewLock i (rec e) 194 | | DropLock i e => DropLock i (rec e) 195 | | Acquire i e => Acquire i (rec e) 196 | | Release i e1 e2 => Release i (rec e1) (rec e2) 197 | | Wait i e => Wait i (rec e) 198 | | ForkLock e1 e2 => ForkLock (rec e1) (rec e2) 199 | end. 200 | 201 | Inductive pure_step : expr -> expr -> Prop := 202 | | Fun_step x e : 203 | pure_step (Fun x e) (Val $ FunV x e) 204 | | App_step x e a : 205 | pure_step (App (Val $ FunV x e) (Val a)) (subst x a e) 206 | | Unit_step : 207 | pure_step Unit (Val $ UnitV) 208 | | Pair_step v1 v2 : 209 | pure_step (Pair (Val v1) (Val v2)) (Val $ PairV v1 v2) 210 | | LetPair_step v1 v2 e: 211 | pure_step (LetPair (Val $ PairV v1 v2) e) (App (App e (Val v1)) (Val v2)) 212 | | Sum_step n v : 213 | pure_step (Sum n (Val v)) (Val $ SumV n v) 214 | | MatchSum_step n (i : fin n) v es : 215 | pure_step (MatchSum n (Val $ SumV i v) es) (App (es i) (Val v)). 216 | 217 | Inductive ctx1 : (expr -> expr) -> Prop := 218 | | Ctx_App_l e : ctx1 (λ x, App x e) 219 | | Ctx_App_r e : ctx1 (λ x, App e x) 220 | | Ctx_Pair_l e : ctx1 (λ x, Pair x e) 221 | | Ctx_Pair_r e : ctx1 (λ x, Pair e x) 222 | | Ctx_LetPair e : ctx1 (λ x, LetPair x e) 223 | | Ctx_Sum i : ctx1 (λ x, Sum i x) 224 | | Ctx_MatchSum n es : ctx1 (λ x, MatchSum n x es) 225 | | Ctx_ForkBarrier : ctx1 (λ x, ForkBarrier x) 226 | | Ctx_DropGroup : ctx1 (λ x, DropGroup x) 227 | | Ctx_NewLock i : ctx1 (λ x, NewLock i x) 228 | | Ctx_DropLock i : ctx1 (λ x, DropLock i x) 229 | | Ctx_ForkLock_l e : ctx1 (λ x, ForkLock x e) 230 | | Ctx_ForkLock_r e : ctx1 (λ x, ForkLock e x) 231 | | Ctx_Acquire i : ctx1 (λ x, Acquire i x) 232 | | Ctx_Release_l i e : ctx1 (λ x, Release i x e) 233 | | Ctx_Release_r i e : ctx1 (λ x, Release i e x) 234 | | Ctx_Wait i : ctx1 (λ x, Wait i x). 235 | 236 | Inductive ctx : (expr -> expr) -> Prop := 237 | | Ctx_id : ctx id 238 | | Ctx_comp k1 k2 : ctx1 k1 -> ctx k2 -> ctx (k1 ∘ k2). 239 | 240 | Definition locksbundle := gmap nat (nat * option val). 241 | Inductive obj := Thread (e : expr) | Barrier | LockG (refcnt : nat) (lcks : locksbundle). 242 | Definition cfg := gmap nat obj. 243 | 244 | (* 245 | xs = {#a ↦ lock1, #b ↦ lock2} 246 | ls = [#a, #b] 247 | 248 | xs = {#a ↦ lock1, #b ↦ lock2, #c ↦ (0,None), #d ↦ lock3} 249 | ls0 = [#d, #a] 250 | ls = [#a, #c, #b] 251 | ls' = [#a, #c, #b] 252 | 253 | Lock order: #d, #a, #c, #b 254 | *) 255 | 256 | Definition incr_all_refcounts (xs : locksbundle) (ls : list nat) : locksbundle := 257 | foldr (alter (λ '(refcnt,o), (refcnt+1,o))) xs ls. 258 | 259 | Inductive local_step : nat -> cfg -> cfg -> Prop := 260 | (* Base language *) 261 | | Pure_step i k e e' : 262 | ctx k -> pure_step e e' -> 263 | local_step i {[ i := Thread (k e) ]} {[ i := Thread (k e') ]} 264 | | Exit_step i : 265 | local_step i {[ i := Thread (Val UnitV) ]} ∅ 266 | (* Barriers *) 267 | | Fork_step i j n k v : 268 | i ≠ j -> i ≠ n -> j ≠ n -> ctx k -> 269 | local_step i {[ i := Thread (k (ForkBarrier (Val v))) ]} 270 | {[ i := Thread (k (Val $ BarrierV n)); 271 | j := Thread (App (Val v) (Val $ BarrierV n)); 272 | n := Barrier ]} 273 | | Sync_step i j n k1 k2 v1 v2 : 274 | i ≠ j -> i ≠ n -> j ≠ n -> ctx k1 -> ctx k2 -> 275 | local_step n {[ i := Thread (k1 (App (Val $ BarrierV n) (Val v1))); 276 | j := Thread (k2 (App (Val $ BarrierV n) (Val v2))); 277 | n := Barrier ]} 278 | {[ i := Thread (k1 $ Val v2); 279 | j := Thread (k2 $ Val v1) ]} 280 | (* Locks *) 281 | | NewGroup_step k i n : 282 | i ≠ n -> ctx k -> 283 | local_step i {[ i := Thread (k NewGroup) ]} 284 | {[ i := Thread (k (Val $ LockGV n [])); 285 | n := LockG 1 ∅ ]} 286 | | DeleteGroup_step n : 287 | local_step n {[ n := LockG 0 ∅ ]} ∅ 288 | | DropGroup_step k i n refcnt xs : 289 | i ≠ n -> ctx k -> 290 | local_step n {[ i := Thread (k (DropGroup (Val $ LockGV n []))); 291 | n := LockG (S refcnt) xs ]} 292 | {[ i := Thread (k (Val $ UnitV)); 293 | n := LockG refcnt xs ]} 294 | | NewLock_step k n i refcnt xs ls ii jj : 295 | i ≠ n -> ctx k -> 296 | xs !! jj = None -> 297 | local_step n {[ i := Thread (k (NewLock ii (Val $ LockGV n ls))); 298 | n := LockG refcnt xs ]} 299 | {[ i := Thread (k (Val $ LockGV n (insert2 ii jj ls))); 300 | n := LockG refcnt (<[ jj := (0,None) ]> xs) ]} 301 | | DropLock_step o k i n refcnt xs ls ii jj refcntii : 302 | i ≠ n -> ctx k -> 303 | ls !! ii = Some jj -> 304 | xs !! jj = Some (S refcntii, o) -> 305 | local_step n {[ i := Thread (k (DropLock ii (Val $ LockGV n ls))); 306 | n := LockG refcnt xs ]} 307 | {[ i := Thread (k (Val $ LockGV n (delete ii ls))); 308 | n := LockG refcnt (<[ jj := (refcntii,o) ]> xs) ]} 309 | | Acquire_step v k i n refcnt ii jj refcntii xs ls : 310 | i ≠ n -> ctx k -> 311 | ls !! ii = Some jj -> 312 | xs !! jj = Some (refcntii, Some v) -> 313 | local_step n {[ i := Thread (k (Acquire ii (Val $ LockGV n ls))); 314 | n := LockG refcnt xs ]} 315 | {[ i := Thread (k (Val $ PairV (LockGV n ls) v)); 316 | n := LockG refcnt (<[ jj := (refcntii, None) ]> xs) ]} 317 | | Release_step v k i n refcnt ii jj refcntii xs ls : 318 | i ≠ n -> ctx k -> 319 | ls !! ii = Some jj -> 320 | xs !! jj = Some (refcntii, None) -> 321 | local_step n {[ i := Thread (k (Release ii (Val $ LockGV n ls) (Val v))); 322 | n := LockG refcnt xs ]} 323 | {[ i := Thread (k (Val $ LockGV n ls)); 324 | n := LockG refcnt (<[ jj := (refcntii, Some v) ]> xs) ]} 325 | | Wait_step v k i n ii jj refcnt xs ls : 326 | i ≠ n -> ctx k -> 327 | ls !! ii = Some jj -> 328 | xs !! jj = Some (0, Some v) -> 329 | local_step n {[ i := Thread (k (Wait ii (Val $ LockGV n ls))); 330 | n := LockG refcnt xs ]} 331 | {[ i := Thread (k (Val $ PairV (LockGV n (delete ii ls)) v)); 332 | n := LockG refcnt (delete jj xs) ]} 333 | | ForkLock_step v k i j n refcnt xs ls : 334 | i ≠ j -> i ≠ n -> j ≠ n -> ctx k -> 335 | local_step n {[ i := Thread (k (ForkLock (Val $ LockGV n ls) (Val v))); 336 | n := LockG refcnt xs ]} 337 | {[ i := Thread (k (Val $ LockGV n ls)); 338 | j := Thread (App (Val v) (Val $ LockGV n ls)); 339 | n := LockG (S refcnt) (incr_all_refcounts xs ls) ]}. 340 | 341 | 342 | Inductive step : nat -> cfg -> cfg -> Prop := 343 | | Frame_step ρ ρ' ρf i : 344 | ρ ##ₘ ρf -> ρ' ##ₘ ρf -> 345 | local_step i ρ ρ' -> step i (ρ ∪ ρf) (ρ' ∪ ρf). 346 | 347 | Definition step' ρ ρ' := ∃ i, step i ρ ρ'. 348 | Definition steps := rtc step'. 349 | 350 | -------------------------------------------------------------------------------- /theories/locks/lambdalockpp/langtools.v: -------------------------------------------------------------------------------- 1 | From iris.proofmode Require Export base tactics classes. 2 | From cgraphs.cgraphs Require Export util. 3 | From Coq.Logic Require Export FunctionalExtensionality Classical. 4 | From cgraphs Require Export seplogic. 5 | From stdpp Require Export gmap. 6 | Require Export cgraphs.cgraphs.genericinv. 7 | 8 | Ltac inv H := inversion H; clear H; simplify_eq. -------------------------------------------------------------------------------- /theories/locks/lambdalockpp/letmacro.v: -------------------------------------------------------------------------------- 1 | From cgraphs.locks.lambdalockpp Require Export langdef. 2 | 3 | (* In this file we demonstrate how typed macros work. *) 4 | (* We define a macro for let in terms of function application and lambda. *) 5 | 6 | Definition Let x e1 e2 := App (Fun x e2) e1. 7 | 8 | (* Check Let. *) 9 | (* Check Fun. *) 10 | 11 | (* We can now prove a typing rule for Let *) 12 | 13 | Lemma Let_typed Γ Γ1 Γ1' Γ2 x e1 e2 t1 t2 : 14 | env_split Γ Γ1 Γ2 -> 15 | env_bind Γ1' x t1 Γ1 -> 16 | typed Γ1' e2 t2 -> 17 | typed Γ2 e1 t1 -> 18 | typed Γ (Let x e1 e2) t2. 19 | Proof. 20 | intros Hs Hb H1 H2. 21 | unfold Let. 22 | eapply App_typed; eauto. 23 | eapply (Fun_typed _ _ _ _ _ _ Lin); eauto. 24 | intros [=]. 25 | Qed. 26 | 27 | (* Check Let_typed. *) 28 | (* Check Fun_typed. *) 29 | 30 | (* We now have a lemma that lets us type check our Let construct using the 31 | usual typing rule for let. From the outside, this gives the same interface 32 | as if we had added Let as a primitive expression and added a typing rule 33 | to our language: *) 34 | 35 | (* 36 | Inductive typed : env -> expr -> type -> Prop := 37 | | ... 38 | | Let_typed Γ Γ1 Γ1' Γ2 x e1 e2 t1 t2 : 39 | env_split Γ Γ1 Γ2 -> 40 | env_bind Γ1' x t1 Γ1 -> 41 | typed Γ1' e2 t2 -> 42 | typed Γ2 e1 t1 -> 43 | typed Γ (Let x e1 e2) t2 44 | | ... 45 | *) -------------------------------------------------------------------------------- /theories/locks/lambdalockpp/plan.md: -------------------------------------------------------------------------------- 1 | [ ] Add lockpp syntax 2 | [ ] Add lockpp typing rules 3 | [ ] Add lockpp opsem 4 | [ ] Update rtypesystem 5 | [ ] Update definitions 6 | [ ] Update invariant.v 7 | [ ] Mechanize examples -------------------------------------------------------------------------------- /theories/locks/lambdalockpp/theorems.v: -------------------------------------------------------------------------------- 1 | From cgraphs.locks.lambdalockpp Require Import invariant. 2 | 3 | 4 | (* The theorems are given in a slightly different order because some of the 5 | proofs of the earlier theorems depend on the later theorems. *) 6 | 7 | (* Paper theorem 7 part 1 *) 8 | Lemma fully_reachable_iff_deadlock_free ρ : 9 | fully_reachable ρ <-> deadlock_free ρ. 10 | Proof. 11 | split. 12 | - intros Hfr s [] i si. 13 | destruct (Hfr i); eauto. 14 | exfalso. induction H; naive_solver. 15 | - intros Hdf i. classical_left. 16 | eapply (Hdf (λ i, ¬ reachable ρ i)); 17 | first constructor; eauto using reachable. 18 | Qed. 19 | 20 | (* Paper theorem 10 part 1 *) 21 | Lemma fully_reachable_type_safety ρ : 22 | fully_reachable ρ -> type_safety ρ. 23 | Proof. 24 | intros Hfr i. destruct (Hfr i) as [|[]]; eauto. 25 | Qed. 26 | 27 | (* Paper theorem 10 part 2 *) 28 | Lemma fully_reachable_global_progress ρ : 29 | fully_reachable ρ -> global_progress ρ. 30 | Proof. 31 | intros Hfr. 32 | destruct (classic (∃ i, ¬ inactive ρ i)). 33 | - destruct H as [i Hi]. destruct (Hfr i); first naive_solver. 34 | clear Hi. right. induction H; eauto. 35 | - left. intros i. apply NNPP. eauto. 36 | Qed. 37 | 38 | (* Paper theorem 11 *) 39 | Lemma typed_full_reachability e ρ : 40 | typed ∅ e UnitT -> steps {[ 0 := Thread e ]} ρ -> fully_reachable ρ. 41 | Proof. 42 | intros Ht Hsteps. 43 | assert (ginv {[ 0 := Thread e ]}) as Hinv. 44 | { eapply initialization. done. } 45 | induction Hsteps. 46 | - eapply full_reachability. done. 47 | - eapply IHHsteps. destruct H. eapply preservation; eauto. 48 | Qed. 49 | 50 | (* Paper theorem 1 *) 51 | Lemma typed_global_progress e ρ : 52 | typed ∅ e UnitT -> steps {[ 0 := Thread e ]} ρ -> global_progress ρ. 53 | Proof. 54 | intros. eapply fully_reachable_global_progress, typed_full_reachability; done. 55 | Qed. 56 | -------------------------------------------------------------------------------- /theories/locks/paper_locks_annotated.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/julesjacobs/cgraphs/HEAD/theories/locks/paper_locks_annotated.pdf -------------------------------------------------------------------------------- /theories/multiparty/README.md: -------------------------------------------------------------------------------- 1 | # ICFP 2022 Artifact 2 | 3 | Name: "Multiparty GV: Functional Multiparty Session Types With Certified Deadlock Freedom." 4 | 5 | ## Artifact Instructions 6 | 7 | This is the Coq development of MPGV. 8 | This development proves the main theorems that MPGV satisfies: 9 | - Global progress 10 | - Deadlock freedom 11 | - Full reachability (memory leak freedom) 12 | 13 | The files of interest are in `theories/multiparty/*.v`: 14 | - paper_annotated.pdf: a version of the paper annotated with references to the Coq sources for the definitions, lemmas, and theorems. 15 | - langdef.v: Definition of the MPGV language (syntax + operational semantics + type system). 16 | - globaltypes.v: The definition of global types, and proof that global type consistency implies coinductive consistency. 17 | - binary.v: Encoding binary session types in MPGV. 18 | - definitions.v: Definitions required to formulate the main theorems (mainly, definition of deadlock freedom and full reachability). 19 | - theorems.v: The proofs of the main theorems (global progress, deadlock freedom, and full reachability). 20 | 21 | The correspondence between these files and the paper is as follows: 22 | - langdef.v: Section 3 23 | - binary.v: Section 4 24 | - definitions.v: First half of section 5 (the definitions) 25 | - theorems.v: Second half of section 5 (the theorems) 26 | - globaltypes.v: Section 6. 27 | The files themselves contain further comments on the precise correspondence to the numbered definitions and theorems in the paper. 28 | 29 | The other files in the `theories/multiparty/*.v` folder contain internal details of the proofs. 30 | These files are checked by Coq and hence need not be checked to verify the correctness of the theorems. 31 | - rtypesystem.v: Run-time type system of MPGV. 32 | - invariant.v: Definition of the configuration invariant and various lemmas about it. 33 | - progress.v: Lemmas showing that the invariant implies strong progress. These lemmas are used by theorems.v. 34 | - ycombinator.v: Definition of the y-combinator that can be used to build recursive functions. 35 | - mutil.v: Various utilities and imports. 36 | 37 | ### Build instructions 38 | 39 | The VM already has the required dependencies installed, and you can simply run `make`. 40 | This will make Coq check all the theorems in the development. 41 | 42 | To build the code, install the opam package manager, and then execute the following in the root folder: 43 | 44 | opam repo add coq-released https://coq.inria.fr/opam/released 45 | opam install . 46 | 47 | Alternatively, install the following dependencies: 48 | * Coq 49 | * std++ 50 | * Iris 51 | (see cgraphs.opam for versions) 52 | 53 | These can be installed by running: 54 | 55 | opam repo add coq-released https://coq.inria.fr/opam/released 56 | opam install coq-iris 57 | 58 | You can then compile this project with `make`. 59 | 60 | We recommend installing the `opam` package manager and then installing the `coq-iris` package as follows. 61 | For Linux distributions with `apt`, the following script performs all the steps: 62 | 63 | sudo apt-get install opam 64 | opam init 65 | eval $(opam env) 66 | opam repo add coq-released https://coq.inria.fr/opam/released 67 | opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git 68 | sudo apt-get libgmp-dev 69 | opam install coq-iris 70 | make 71 | 72 | Depending on your platform, you may need to install opam in a different way, see https://opam.ocaml.org/ for details. 73 | 74 | ### Axioms 75 | 76 | *Classical logic* 77 | 78 | We use classical logic. 79 | Strictly speaking, classical axioms should not be necessary. 80 | The reason is that the final theorems we are proving are all decidable. 81 | For instance, it should be decidable whether a given configuration can take a step or not. 82 | One could decide this by checking if any of the operational semantics rules apply to the configuration. 83 | If the conclusion of a theorem is decidable, then use of the excluded middle in the proof can be avoided. 84 | However, actually doing this in Coq would require making a lot of changes, so we use classical logic for convenience. 85 | 86 | *Functional extensionality* 87 | 88 | We use the axiom of functional extensionality. 89 | Coq's default notion of equality for functions is syntactic. 90 | For the proofs it is convenient to use mathematical equality of functions. 91 | 92 | *Coinductive extensionality* 93 | 94 | Coq's default notion of equality is not good enough for coinductive types: 95 | the default equality is syntactic equality and not extensional equality. 96 | We add an axiom to make equality extensional. 97 | See https://coq.inria.fr/refman/language/core/coinductive.html: 98 | "More generally, as in the case of positive coinductive types, 99 | it is consistent to further identify extensional equality of coinductive 100 | types with propositional equality" 101 | Such an axiom is similar to functional extensionality, but for coinductive types. 102 | 103 | These extensionality axioms could be avoided by working up to an appropriate equivalence relation. 104 | However, doing this in Coq is quite inconvenient, so we add them as an axiom. 105 | In future proof assistants, perhaps based on observational type theory or HoTT, 106 | one would not need these extensionality axioms if they are provable. 107 | 108 | 109 | ### Dependencies 110 | 111 | We depend on stdpp and Iris. Stdpp offers a more comprehensive standard library for Coq. From Iris we mainly use the Iris proof mode. 112 | We also use a modified version of Iris' uPred -- whereas Iris' uPred is affine, our uPred is linear. 113 | 114 | We depend on the connectivity graph library of Jacobs et al. [https://doi.org/10.1145/3498662]. 115 | This library provides tools to prove deadlock freedom for languages where this property follows from the acyclic reference structure of the configuration. 116 | In particular, the library provides tools for showing that the configuration maintains the acyclicity invariant under stepping in the operational semantics, and it provides an induction principle for acyclic graphs using which we prove full reachability. 117 | 118 | 119 | ## QEMU Instructions 120 | 121 | The ICFP 2022 Artifact Evaluation Process is using a Debian QEMU image as a 122 | base for artifacts. The Artifact Evaluation Committee (AEC) will verify that 123 | this image works on their own machines before distributing it to authors. 124 | Authors are encouraged to extend the provided image instead of creating their 125 | own. If it is not practical for authors to use the provided image then please 126 | contact the AEC co-chairs before submission. 127 | 128 | QEMU is a hosted virtual machine monitor that can emulate a host processor 129 | via dynamic binary translation. On common host platforms QEMU can also use 130 | a host provided virtualization layer, which is faster than dynamic binary 131 | translation. 132 | 133 | QEMU homepage: https://www.qemu.org/ 134 | 135 | ### Installation 136 | 137 | #### OSX 138 | ``brew install qemu`` 139 | 140 | #### Debian and Ubuntu Linux 141 | ``apt-get install qemu-kvm`` 142 | 143 | On x86 laptops and server machines you may need to enable the 144 | "Intel Virtualization Technology" setting in your BIOS, as some manufacturers 145 | leave this disabled by default. See Debugging.md for details. 146 | 147 | 148 | #### Arch Linux 149 | 150 | ``pacman -Sy qemu`` 151 | 152 | See the [Arch wiki](https://wiki.archlinux.org/title/QEMU) for more info. 153 | 154 | See Debugging.md if you have problems logging into the artifact via SSH. 155 | 156 | 157 | #### Windows 10 158 | 159 | Download and install QEMU via the links at 160 | 161 | https://www.qemu.org/download/#windows. 162 | 163 | Ensure that `qemu-system-x86_64.exe` is in your path. 164 | 165 | Start Bar -> Search -> "Windows Features" 166 | -> enable "Hyper-V" and "Windows Hypervisor Platform". 167 | 168 | Restart your computer. 169 | 170 | #### Windows 8 171 | 172 | See Debugging.md for Windows 8 install instructions. 173 | 174 | ### Startup 175 | 176 | The base artifact provides a `start.sh` script to start the VM on unix-like 177 | systems and `start.bat` for Windows. Running this script will open a graphical 178 | console on the host machine, and create a virtualized network interface. 179 | On Linux you may need to run with `sudo` to start the VM. If the VM does not 180 | start then check `Debugging.md` 181 | 182 | Once the VM has started you can login to the guest system from the host. 183 | Whenever you are asked for a password, the answer is `password`. The default 184 | username is `artifact`. 185 | 186 | ``` 187 | $ ssh -p 5555 artifact@localhost 188 | ``` 189 | 190 | You can also copy files to and from the host using scp. 191 | 192 | ``` 193 | $ scp -P 5555 artifact@localhost:somefile . 194 | ``` 195 | 196 | ### Shutdown 197 | 198 | To shutdown the guest system cleanly, login to it via ssh and use 199 | 200 | ``` 201 | $ sudo shutdown now 202 | ``` 203 | 204 | ### Artifact Preparation 205 | 206 | Authors should install software dependencies into the VM image as needed, 207 | preferably via the standard Debian package manager. For example, to install 208 | GHC and cabal-install, login to the host and type: 209 | 210 | ``` 211 | $ sudo apt update 212 | $ sudo apt install ghc 213 | $ sudo apt install cabal-install 214 | ``` 215 | 216 | If you really need a GUI then you can install X as follows, but we prefer 217 | console-only artifacts whenever possible. 218 | 219 | ``` 220 | $ sudo apt install xorg 221 | $ sudo apt install xfce4 # or some other window manager 222 | $ startx 223 | ``` 224 | 225 | See Debugging.md for advice on resolving other potential problems. 226 | 227 | If your artifact needs lots of memory you may need to increase the value 228 | of the `QEMU_MEM_MB` variable in the `start.sh` script. 229 | 230 | When preparing your artifact, please also follow the [Submission 231 | Guidelines](https://icfp22.sigplan.org/track/icfp-2022-artifact-evaluation#Submission-Guidelines). 232 | -------------------------------------------------------------------------------- /theories/multiparty/binary.v: -------------------------------------------------------------------------------- 1 | From cgraphs.multiparty Require Import langdef. 2 | From cgraphs.multiparty Require Import ycombinator. 3 | From cgraphs.multiparty Require Import globaltypes. 4 | 5 | (* Encoding binary session types in MPGV *) 6 | (* ===================================== *) 7 | (* This is section 4 in the paper. *) 8 | 9 | 10 | (* Definition of the binary session operations in terms of MPGV's multiparty operations. *) 11 | Definition SendB e1 i e2 := Send 0 e1 i e2. 12 | Definition RecvB e := Recv 0 e. 13 | Definition ForkB e := Relabel (const 1) (Spawn 1 (const e)). 14 | Definition CloseB e := Close e. 15 | 16 | (* Definition of binary session types. *) 17 | CoInductive session_typeB := 18 | | SendTB n : (fin n -> type) -> (fin n -> session_typeB) -> session_typeB 19 | | RecvTB n : (fin n -> type) -> (fin n -> session_typeB) -> session_typeB 20 | | EndTB : session_typeB. 21 | 22 | CoFixpoint dual (σ : session_typeB) : session_typeB := 23 | match σ with 24 | | SendTB n ts σs => RecvTB n ts (dual ∘ σs) 25 | | RecvTB n ts σs => SendTB n ts (dual ∘ σs) 26 | | EndBT => EndTB 27 | end. 28 | 29 | (* Converting a binary session type to multiparty sesion type. *) 30 | CoFixpoint toM (p : participant) (σ : session_typeB) : session_type := 31 | match σ with 32 | | SendTB n ts σs => SendT n p ts (toM p ∘ σs) 33 | | RecvTB n ts σs => RecvT n p ts (toM p ∘ σs) 34 | | EndBT => EndT 35 | end. 36 | 37 | Definition ChanTB σ := ChanT (toM 0 σ). 38 | 39 | 40 | (* We prove that the typing rules for binary session types are admissible. *) 41 | (* These proofs for Send, Recv, and Close are relatively easy. *) 42 | (* The main difficulty is proving the rule for Fork (see below). *) 43 | 44 | Lemma SendB_typed Γ1 Γ2 e1 e2 n ts σs i : 45 | disj Γ1 Γ2 -> 46 | typed Γ1 e1 (ChanTB (SendTB n ts σs)) -> 47 | typed Γ2 e2 (ts i) -> 48 | typed (Γ1 ∪ Γ2) (SendB e1 i e2) (ChanTB (σs i)). 49 | Proof. 50 | unfold ChanTB. intros. 51 | eapply (Send_typed _ _ _ _ _ _ (toM 0 ∘ σs)); eauto. 52 | econstructor; last done. 53 | constructor. apply session_type_equiv_alt. simpl. done. 54 | Qed. 55 | 56 | Lemma RecvB_typed Γ e n ts σs : 57 | typed Γ e (ChanTB (RecvTB n ts σs)) -> 58 | typed Γ (RecvB e) (SumNT n (λ i, PairT (ChanTB (σs i)) (ts i))). 59 | Proof. 60 | unfold ChanTB. intros. 61 | eapply (Recv_typed _ _ _ _ (toM 0 ∘ σs)); eauto. 62 | econstructor; last done. 63 | constructor. apply session_type_equiv_alt. simpl. done. 64 | Qed. 65 | 66 | Lemma CloseB_typed Γ e : 67 | typed Γ e (ChanTB EndTB) -> 68 | typed Γ (CloseB e) UnitT. 69 | Proof. 70 | unfold ChanTB. intros. 71 | constructor. econstructor; last done. 72 | constructor. apply session_type_equiv_alt. simpl. done. 73 | Qed. 74 | 75 | (* Proof of the rule for Fork *) 76 | (* ========================== *) 77 | 78 | Definition σsB σ := λ i : fin 2, 79 | match i with 80 | | 0%fin => toM 1 σ 81 | | _ => toM 0 (dual σ) 82 | end. 83 | 84 | CoFixpoint toG σ := 85 | match σ with 86 | | SendTB n ts σs => Message n 0 1 ts (toG ∘ σs) 87 | | RecvTB n ts σs => Message n 1 0 ts (toG ∘ σs) 88 | | EndTB => EndG 89 | end. 90 | 91 | CoInductive global_type_equiv : Equiv global_type := 92 | | gte_Message n p q ts1 ts2 Gs1 Gs2 : 93 | ts1 ≡ ts2 -> Gs1 ≡ Gs2 -> 94 | Message n p q ts1 Gs1 ≡ Message n p q ts2 Gs2 95 | | gte_EndG : EndG ≡ EndG. 96 | Global Existing Instance global_type_equiv. 97 | 98 | (* 99 | Coq's default notion of equality is not good enough for coinductive types: 100 | the default equality is syntactic equality and not extensional equality. 101 | We add an axiom to make equality extensional. 102 | See https://coq.inria.fr/refman/language/core/coinductive.html: 103 | "More generally, as in the case of positive coinductive types, 104 | it is consistent to further identify extensional equality of coinductive 105 | types with propositional equality" 106 | Such an axiom is similar to functional extensionality, but for coinductive types. 107 | *) 108 | Axiom global_type_extensionality : ∀ G1 G2 : global_type, G1 ≡ G2 -> G1 = G2. 109 | 110 | Definition global_type_id (G : global_type) : global_type := 111 | match G with 112 | | Message n p q ts Gs => Message n p q ts Gs 113 | | EndG => EndG 114 | end. 115 | 116 | Lemma global_type_id_id (G : global_type) : 117 | global_type_id G = G. 118 | Proof. 119 | by destruct G. 120 | Qed. 121 | 122 | Lemma global_type_equiv_alt (G1 G2 : global_type) : 123 | global_type_id G1 ≡ global_type_id G2 -> G1 ≡ G2. 124 | Proof. 125 | intros. 126 | rewrite -(global_type_id_id G1). 127 | rewrite -(global_type_id_id G2). 128 | done. 129 | Defined. 130 | 131 | Lemma global_type_reflexive : Reflexive (≡@{global_type}). 132 | Proof. 133 | cofix IH. intros []; constructor; done. 134 | Defined. 135 | 136 | Lemma global_type_symmetric : Symmetric (≡@{global_type}). 137 | Proof. 138 | cofix IH. intros [] []; intros; try solve [constructor || inversion H]. 139 | inversion H; simplify_eq. constructor; eauto. 140 | Defined. 141 | 142 | Lemma global_type_transitive : Transitive (≡@{global_type}). 143 | Proof. 144 | cofix IH. intros ???[]. 145 | - remember (Message n p q ts2 Gs2). 146 | inversion 1; simplify_eq. 147 | constructor; etrans; eauto. 148 | - inversion 1. constructor. 149 | Defined. 150 | 151 | Global Instance global_type_equivalence : Equivalence (≡@{global_type}). 152 | Proof. 153 | split. 154 | - apply global_type_reflexive. 155 | - apply global_type_symmetric. 156 | - apply global_type_transitive. 157 | Qed. 158 | 159 | Lemma projGM_0 σ : proj 0 (toG σ) (toM 1 σ). 160 | Proof. 161 | revert σ. cofix IH; intros []. 162 | - assert (toM 1 (SendTB n t s) = SendT n 1 t (toM 1 ∘ s)) as ->. 163 | { apply session_type_extensionality. apply session_type_equiv_alt; simpl. done. } 164 | assert (toG (SendTB n t s) = Message n 0 1 t (toG ∘ s)) as ->. 165 | { apply global_type_extensionality. apply global_type_equiv_alt; simpl. done. } 166 | econstructor; first lia. simpl. 167 | intro. apply IH. 168 | - assert (toM 1 (RecvTB n t s) = RecvT n 1 t (toM 1 ∘ s)) as ->. 169 | { apply session_type_extensionality. apply session_type_equiv_alt; simpl. done. } 170 | assert (toG (RecvTB n t s) = Message n 1 0 t (toG ∘ s)) as ->. 171 | { apply global_type_extensionality. apply global_type_equiv_alt; simpl. done. } 172 | econstructor; first lia. simpl. 173 | intro. apply IH. 174 | - assert (toM 1 EndTB = EndT) as ->. 175 | { apply session_type_extensionality. apply session_type_equiv_alt; simpl. done. } 176 | assert (toG EndTB = EndG) as ->. 177 | { apply global_type_extensionality. apply global_type_equiv_alt; simpl. done. } 178 | econstructor. inversion 1. 179 | Qed. 180 | 181 | Lemma projGM_1 σ : proj 1 (toG σ) (toM 0 (dual σ)). 182 | Proof. 183 | revert σ. cofix IH; intros []. 184 | - assert (toM 0 (dual (SendTB n t s)) = RecvT n 0 t (toM 0 ∘ dual ∘ s)) as ->. 185 | { apply session_type_extensionality. apply session_type_equiv_alt; simpl. done. } 186 | assert (toG (SendTB n t s) = Message n 0 1 t (toG ∘ s)) as ->. 187 | { apply global_type_extensionality. apply global_type_equiv_alt; simpl. done. } 188 | econstructor; first lia. simpl. 189 | intro. apply IH. 190 | - assert (toM 0 (dual (RecvTB n t s)) = SendT n 0 t (toM 0 ∘ dual ∘ s)) as ->. 191 | { apply session_type_extensionality. apply session_type_equiv_alt; simpl. done. } 192 | assert (toG (RecvTB n t s) = Message n 1 0 t (toG ∘ s)) as ->. 193 | { apply global_type_extensionality. apply global_type_equiv_alt; simpl. done. } 194 | econstructor; first lia. simpl. 195 | intro. apply IH. 196 | - assert (toM 0 (dual EndTB) = EndT) as ->. 197 | { apply session_type_extensionality. apply session_type_equiv_alt; simpl. done. } 198 | assert (toG EndTB = EndG) as ->. 199 | { apply global_type_extensionality. apply global_type_equiv_alt; simpl. done. } 200 | econstructor. inversion 1. 201 | Qed. 202 | 203 | Lemma not_occurs_in_toG p σ : p >= 2 -> ¬ occurs_in p (toG σ). 204 | Proof. 205 | intros Hp Hoc. remember (toG σ). 206 | revert σ Heqg. induction Hoc; intros []; 207 | rewrite <-(global_type_id_id (toG _)); simpl; intros; simplify_eq; try lia; eauto. 208 | Qed. 209 | 210 | Lemma projGM_other σ p : p >= 2 -> proj p (toG σ) EndT. 211 | Proof. 212 | intros Hp. constructor. by apply not_occurs_in_toG. 213 | Qed. 214 | 215 | Lemma σsB_consistent σ : consistent 2 (σsB σ). 216 | apply consistent_gt_consistent. 217 | exists (toG σ). split. 218 | - intros. unfold σsB. dependent inversion i; simpl. 219 | + subst. apply projGM_0. 220 | + subst. inv_fin t; last (intros j; inversion j). simpl. apply projGM_1. 221 | - intros i Hi. apply projGM_other. done. 222 | Qed. 223 | 224 | Lemma disj_union_1 Γ : disj_union 1 Γ (const Γ). 225 | Proof. 226 | constructor; eauto. 227 | intros p q Hpq. exfalso. apply Hpq. 228 | clear Hpq. inv_fin p. 229 | - inv_fin q; eauto. intros i. inv_fin i. 230 | - intros i. inv_fin i. 231 | Unshelve. exact 0%fin. 232 | Qed. 233 | 234 | Lemma toM_relabel p q σ : toM p σ ≡ relabelT (const p) (toM q σ). 235 | Proof. 236 | revert σ. cofix IH. intros []; 237 | apply session_type_equiv_alt; simpl; constructor; try done; intro; apply IH. 238 | Qed. 239 | 240 | (* The Fork rule for binary session types is admissible in MPGV. *) 241 | Lemma ForkB_typed Γ σ e : 242 | typed Γ e (FunT (ChanTB (dual σ)) UnitT) -> 243 | typed Γ (ForkB e) (ChanTB σ). 244 | Proof. 245 | unfold ChanTB, ForkB. intros. 246 | do 2 econstructor; last first. 247 | { eapply (Spawn_typed _ _ (const Γ) _ (σsB σ)); 248 | eauto using disj_union_1, σsB_consistent. } 249 | constructor. 250 | apply toM_relabel. 251 | Qed. -------------------------------------------------------------------------------- /theories/multiparty/definitions.v: -------------------------------------------------------------------------------- 1 | From stdpp Require Export gmap. 2 | Require Export cgraphs.multiparty.langdef. 3 | 4 | 5 | (* This file contains the definitions of section 5 in the paper. *) 6 | 7 | 8 | 9 | (* The auxiliary definitions of section 5 *) 10 | (* ====================================== *) 11 | (* These are not spelled out in detail in the paper, *) 12 | 13 | (* The set of objects in the system (threads and channels), called V in the paper. *) 14 | Inductive object := Thread (_:nat) | Chan (_:session). 15 | 16 | (* Stuff required to be able to form finite sets of objects (gset object). *) 17 | Canonical Structure objectO := leibnizO object. 18 | Global Instance object_eqdecision : EqDecision object. 19 | Proof. 20 | intros [n|n] [m|m]; unfold Decision; destruct (decide (n = m)); 21 | subst; eauto; right; intro; simplify_eq. 22 | Qed. 23 | Global Instance object_countable : Countable object. 24 | Proof. 25 | refine (inj_countable' (λ l, match l with 26 | | Thread n => inl n 27 | | Chan n => inr n 28 | end) (λ l, match l with 29 | | inl n => Thread n 30 | | inr n => Chan n 31 | end) _); by intros []. 32 | Qed. 33 | 34 | (* We define the set of references of expressions, values, buffers, and finally, objects. *) 35 | (* These definitions are not spelled out in the paper, because they are rather boring. *) 36 | Fixpoint expr_refs (e : expr) : gset object := 37 | match e with 38 | | Val v => val_refs v 39 | | Var x => ∅ 40 | | Pair e1 e2 => expr_refs e1 ∪ expr_refs e2 41 | | Inj b e1 => expr_refs e1 42 | | App e1 e2 => expr_refs e1 ∪ expr_refs e2 43 | | UApp e1 e2 => expr_refs e1 ∪ expr_refs e2 44 | | Lam s e1 => expr_refs e1 45 | | ULam s e1 => expr_refs e1 46 | | Send p e1 i e2 => expr_refs e1 ∪ expr_refs e2 47 | | Recv p e1 => expr_refs e1 48 | | Let s e1 e2 => expr_refs e1 ∪ expr_refs e2 49 | | LetUnit e1 e2 => expr_refs e1 ∪ expr_refs e2 50 | | LetProd s1 s2 e1 e2 => expr_refs e1 ∪ expr_refs e2 51 | | MatchVoid e1 => expr_refs e1 52 | | MatchSum e1 s e2 e3 => expr_refs e1 ∪ expr_refs e2 ∪ expr_refs e3 53 | | InjN i e => expr_refs e 54 | | MatchSumN n e f => expr_refs e ∪ fin_union n (expr_refs ∘ f) 55 | | If e1 e2 e3 => expr_refs e1 ∪ expr_refs e2 56 | | Spawn n f => fin_union n (expr_refs ∘ f) 57 | | Close e1 => expr_refs e1 58 | | Relabel π e1 => expr_refs e1 59 | end 60 | with val_refs (v : val) : gset object := 61 | match v with 62 | | UnitV => ∅ 63 | | NatV n => ∅ 64 | | PairV v1 v2 => val_refs v1 ∪ val_refs v2 65 | | InjV b v1 => val_refs v1 66 | | InjNV i v1 => val_refs v1 67 | | FunV s e1 => expr_refs e1 68 | | UFunV s e1 => expr_refs e1 69 | | ChanV (c,b) _ => {[ Chan c ]} 70 | end. 71 | 72 | Definition map_union `{Countable K, Countable A} {V} (f : V -> gset A) (m : gmap K V) := 73 | map_fold (λ k v s, f v ∪ s) ∅ m. 74 | 75 | Definition buf_refs (buf : list entryT) := foldr (λ '(i,v) s, val_refs v ∪ s) ∅ buf. 76 | 77 | Definition bufs_refs (bufss : bufsT participant participant entryT) : gset object := 78 | map_union (map_union buf_refs) bufss. 79 | 80 | (* This is the final refs definition we need to formulate the theorems. *) 81 | (* This is simply called `refs` in the paper. *) 82 | Definition obj_refs (es : list expr) (h : heap) (x : object) : gset object := 83 | match x with 84 | | Thread n => from_option expr_refs ∅ (es !! n) 85 | | Chan c => bufs_refs (gmap_slice h c) 86 | end. 87 | 88 | (* This defines when a thread is blocked on a channel. *) 89 | (* This is spelled blocked_(es,h)(Thread(i),Session(c)) in the paper. *) 90 | Definition thread_blocked (es : list expr) (h : heap) (i c : nat) := 91 | ∃ p q k π, ctx k ∧ 92 | es !! i = Some (k (Recv p (Val (ChanV (c,q) π)))) ∧ 93 | is_Some (h !! (c,q)) ∧ 94 | pop (π p) (c,q) h = None. 95 | 96 | (* This is the definition of active set. In Coq, we use a predicate rather than a set. *) 97 | (* We have in Coq that `active es h x` holds whenever in the paper `x ∈ active(es,h)`. *) 98 | Definition active (es : list expr) (h : heap) (x : object) := 99 | match x with 100 | | Thread i => ∃ e, es !! i = Some e ∧ e ≠ Val UnitV 101 | | Chan i => ∃ p, is_Some (h !! (i,p)) 102 | end. 103 | 104 | 105 | (* The main definitions from section 5 *) 106 | (* =================================== *) 107 | 108 | (* Definition 5.1 *) 109 | (* 110 | A subset [s] of the threads & channels is in a partial deadlock (/ memory leak) if: 111 | - All of the threads in the subset are blocked on one of the channels in the subset. 112 | - All of the endpoints of the channels in the subset are held by one of the threads or channels in the subset. 113 | *) 114 | Record deadlock (es : list expr) (h : heap) (s : gset object) := { 115 | dl_nonempty : s ≠ ∅; 116 | dl_active x : x ∈ s -> active es h x; 117 | dl_threadb i : Thread i ∈ s -> ¬ can_stepi i es h; 118 | dl_threadw i c : Thread i ∈ s -> thread_blocked es h i c -> Chan c ∈ s; 119 | dl_chan c x : Chan c ∈ s -> Chan c ∈ obj_refs es h x -> x ∈ s 120 | }. 121 | 122 | (* Definition 5.2 *) 123 | Definition deadlock_free es h := ∀ s, ¬ deadlock es h s. 124 | 125 | (* Definition 5.3 *) 126 | (* A thread is reachable if it can step, or if it is blocked on a reachable channel. *) 127 | (* A channel is reachable if a reachable object holds a reference to it. *) 128 | Inductive reachable (es : list expr) (h : heap) : object → Prop := 129 | | Thread_step_reachable i : can_stepi i es h → reachable es h (Thread i) 130 | | Thread_blocked_reachable i c : reachable es h (Chan c) → thread_blocked es h i c → reachable es h (Thread i) 131 | | Chan_ref_reachable c x : (Chan c) ∈ obj_refs es h x → reachable es h x → reachable es h (Chan c). 132 | 133 | (* Definition 5.4 *) 134 | Definition fully_reachable es h := ∀ x, active es h x -> reachable es h x. -------------------------------------------------------------------------------- /theories/multiparty/mutil.v: -------------------------------------------------------------------------------- 1 | From stdpp Require Import countable fin_sets functions. 2 | From iris Require Import proofmode.proofmode proofmode.tactics. 3 | From cgraphs Require Import util bi. 4 | From Coq.Logic Require Export FunctionalExtensionality Classical. 5 | 6 | 7 | Lemma big_sepS_pure_impl {PROP : bi} `{Countable A} (s : gset A) (P : A -> PROP) (Q : A -> Prop) : 8 | (□ ∀ i, ⌜ i ∈ s ⌝ -∗ P i -∗ ⌜ Q i ⌝) -∗ 9 | ([∗ set] i ∈ s, P i) -∗ ⌜ set_Forall Q s ⌝. 10 | Proof. 11 | iIntros "#H G". 12 | iApply big_sepS_pure_1. 13 | iApply (big_sepS_impl with "G"). Unshelve. 14 | iModIntro. iIntros (x HH) "Q". Unshelve. iApply "H"; eauto. 15 | Qed. 16 | 17 | Lemma big_sepF_pure_impl {PROP : bi} n (P : fin n -> PROP) (Q : fin n -> Prop) : 18 | (□ ∀ i, P i -∗ ⌜ Q i ⌝) -∗ 19 | ([∗ set] i ∈ all_fin n, P i) -∗ ⌜ ∀ i, Q i ⌝. 20 | Proof. 21 | iIntros "#H G". 22 | iDestruct (big_sepS_pure_impl with "[] G") as %G. 23 | { iModIntro. iIntros (i Hi) "Q". iApply "H". done. } 24 | iPureIntro. intros. 25 | apply G. apply all_fin_all. 26 | Qed. 27 | 28 | Lemma big_sepS_impl1 {PROP : bi} `{Countable A} (s : gset A) (P P' : A -> PROP) (x0 : A) : 29 | x0 ∈ s -> 30 | □ (∀ x, ⌜⌜ x ≠ x0 ⌝⌝ -∗ P x -∗ P' x) -∗ 31 | (P x0 -∗ P' x0) -∗ 32 | ([∗ set] x ∈ s, P x) -∗ [∗ set] x ∈ s, P' x. 33 | Proof. 34 | iIntros (Hx0) "#Hr H1 H". 35 | rewrite big_sepS_delete //. 36 | iApply big_sepS_delete; first done. 37 | iDestruct "H" as "[H0 H]". 38 | iSplitL "H1 H0". 39 | - iApply "H1". done. 40 | - iApply (big_sepS_impl with "H"). iModIntro. 41 | iIntros (x Hx) "H". 42 | iApply ("Hr" with "[%] H"). set_solver. 43 | Qed. 44 | 45 | Lemma subset_exists `{Countable A} (P : A -> Prop) (s : gset A) : 46 | (∀ x, P x -> x ∈ s) -> ∃ s' : gset A, ∀ x, x ∈ s' <-> P x. 47 | Proof. 48 | revert P; induction s using set_ind_L; intros P Q. 49 | - exists ∅. set_solver. 50 | - destruct (IHs (λ y, P y ∧ y ≠ x)); first set_solver. 51 | destruct (classic (P x)); last set_solver. 52 | exists (x0 ∪ {[ x ]}). set_solver. 53 | Qed. -------------------------------------------------------------------------------- /theories/multiparty/paper_multiparty_annotated.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/julesjacobs/cgraphs/HEAD/theories/multiparty/paper_multiparty_annotated.pdf -------------------------------------------------------------------------------- /theories/multiparty/theorems.v: -------------------------------------------------------------------------------- 1 | From cgraphs.multiparty Require Import invariant langdef progress. 2 | Require Import Coq.Logic.Classical. 3 | 4 | (* This file contains the main theorems about MPGV. *) 5 | (* This is the theorems part of section 5 in the paper. *) 6 | 7 | (* The definitions used in this file can be found in definitions.v *) 8 | (* The language definition can be found in langdef.v *) 9 | 10 | (* Theorem 5.1 *) 11 | Theorem global_progress e es h : 12 | typed ∅ e UnitT -> steps [e] ∅ es h -> 13 | (∃ es' h', step es h es' h') ∨ (h = ∅ ∧ ∀ e, e ∈ es -> e = Val UnitV). 14 | Proof. 15 | intros. edestruct inv_global_progress; eauto using invariant_holds. 16 | Qed. 17 | 18 | (* Theorem 5.2 *) 19 | Theorem reachability_deadlock_freedom es h : 20 | deadlock_free es h <-> fully_reachable es h. 21 | Proof. 22 | unfold deadlock_free, fully_reachable. 23 | split. 24 | - intros. destruct (classic (reachable es h x)); eauto. 25 | assert (∃ s : gset object, ∀ x, x ∈ s <-> active es h x ∧ ¬ reachable es h x) as [s Hs]. 26 | { edestruct activeset_exists. eapply subset_exists. naive_solver. } 27 | exfalso. eapply (H s). 28 | split; eauto. 29 | + set_solver. 30 | + naive_solver. 31 | + intros ???. assert (¬ reachable es h (Thread i)) by naive_solver. 32 | eauto using reachable. 33 | + intros ????. 34 | destruct (classic (Chan c ∈ s)); eauto. exfalso. 35 | eapply Hs in H2 as []. 36 | destruct (classic (reachable es h (Chan c))); eauto using reachable. 37 | assert (active es h (Chan c)). 38 | { destruct H3 as (?&?&?&?&?&?&?&?). eexists. eauto. } 39 | naive_solver. 40 | + intros. apply Hs in H2 as []. 41 | rewrite Hs. 42 | split. { by eapply obj_refs_active. } 43 | intro. eapply H4. 44 | eauto using reachable. 45 | - intros. intros []. 46 | eapply set_choose_L in dl_nonempty as [x Hx]. 47 | assert (reachable es h x) as Q by eauto. 48 | induction Q; naive_solver. 49 | Qed. 50 | 51 | (* Theorem 5.3 *) 52 | Theorem deadlock_freedom_and_full_reachability e es h : 53 | typed ∅ e UnitT -> steps [e] ∅ es h -> 54 | deadlock_free es h ∧ fully_reachable es h. 55 | Proof. 56 | intros Htyped Hinv%invariant_holds; last done. 57 | split; [eapply reachability_deadlock_freedom|]; 58 | unfold fully_reachable; eauto using strong_progress. 59 | Qed. -------------------------------------------------------------------------------- /theories/multiparty/ycombinator.v: -------------------------------------------------------------------------------- 1 | From iris.proofmode Require Import base tactics classes. 2 | From cgraphs.multiparty Require Import langdef rtypesystem. 3 | From stdpp Require Import gmap. 4 | 5 | Section ycombinator. 6 | (* We define the y-combinator for creating recursive functions t1 -> t2. *) 7 | Variable t1 t2 : type. 8 | 9 | Definition gT := UFunT t1 t2. 10 | Definition fT := UFunT gT gT. 11 | CoFixpoint xT := UFunT xT gT. 12 | 13 | Lemma unfold_xT : xT = UFunT xT gT. 14 | by rewrite <-type_id_id at 1. 15 | Qed. 16 | 17 | Definition y1 := ULam "x" (UApp (Var "f") (ULam "v" (UApp (UApp (Var "x") (Var "x")) (Var "v")))). 18 | Definition y := ULam "f" (UApp y1 y1). 19 | 20 | Lemma Var_typed' x xT : typed {[x := xT]} (Var x) xT. 21 | Proof. 22 | replace {[x := xT]} with (∅ ∪ {[x := xT]} : envT) by rewrite left_id //. 23 | eapply Var_typed; eauto. 24 | eapply Γunrestricted_empty. 25 | Qed. 26 | 27 | Lemma Γunrestricted_singleton x xT : unrestricted xT -> Γunrestricted {[x := xT]}. 28 | Proof. 29 | intros ???. destruct (decide (x = x0)); subst. 30 | - rewrite lookup_singleton. intros. simplify_eq. done. 31 | - rewrite lookup_singleton_ne; eauto. intros. simplify_eq. 32 | Qed. 33 | 34 | Lemma singleton_disj x y xT yT : 35 | String.eqb x y = false ∨ (xT = yT ∧ unrestricted xT) -> disj {[x := xT]} {[y := yT]}. 36 | Proof. 37 | intros ??????. 38 | eapply lookup_singleton_Some in H0 as []. 39 | eapply lookup_singleton_Some in H1 as []. 40 | subst. rewrite String.eqb_refl in H. 41 | destruct H; simplify_eq. destruct H; subst. eauto. 42 | Qed. 43 | 44 | Lemma fT_unrestricted : unrestricted fT. 45 | Proof. constructor. Qed. 46 | Lemma xT_unrestricted : unrestricted xT. 47 | rewrite <-type_id_id. constructor. 48 | Qed. 49 | 50 | Ltac check := eauto using Γunrestricted_singleton, Γunrestricted_empty, fT_unrestricted, xT_unrestricted, singleton_disj. 51 | 52 | Lemma ctx_dup (Γ : envT) : Γ = Γ ∪ Γ. 53 | Proof. 54 | eapply map_eq. intro. 55 | rewrite lookup_union. destruct (_!!_); eauto. 56 | Qed. 57 | 58 | Lemma y1_typed : typed {[ "f" := fT ]} y1 (UFunT xT gT). 59 | Proof. 60 | unfold y1. 61 | eapply ULam_typed; check. 62 | eapply UApp_typed; check. 63 | - eapply Var_typed'. 64 | - eapply ULam_typed; check. 65 | eapply UApp_typed; check. 66 | + rewrite ->ctx_dup at 1. 67 | eapply UApp_typed; check. 68 | * rewrite ->unfold_xT at 1. eapply Var_typed'. 69 | * eapply Var_typed'. 70 | + eapply Var_typed'. 71 | Qed. 72 | 73 | Lemma y_typed : typed ∅ y (UFunT fT gT). 74 | Proof. 75 | unfold y. 76 | eapply ULam_typed; check. 77 | rewrite left_id. rewrite ->ctx_dup at 1. 78 | eapply UApp_typed; check. 79 | - eapply y1_typed. 80 | - rewrite unfold_xT. eapply y1_typed. 81 | Qed. 82 | End ycombinator. -------------------------------------------------------------------------------- /theories/sessiontypes/invariant.v: -------------------------------------------------------------------------------- 1 | Require Export cgraphs.cgraphs.genericinv. 2 | Require Export cgraphs.sessiontypes.langdef. 3 | Require Export cgraphs.sessiontypes.rtypesystem. 4 | 5 | Section bufs_typed. 6 | Fixpoint buf_typed (buf : list val) (ct : chan_type) (rest : chan_type) : rProp := 7 | match buf, ct with 8 | | v::buf', RecvT t ct' => val_typed v t ∗ buf_typed buf' ct' rest 9 | | [], ct => ⌜⌜ rest ≡ ct ⌝⌝ 10 | | _,_ => False 11 | end. 12 | 13 | Global Instance buf_typed_params : Params (@buf_typed) 1 := {}. 14 | Global Instance buf_typed_proper buf : Proper ((≡) ==> (≡) ==> (≡)) (buf_typed buf). 15 | Proof. induction buf; solve_proper. Qed. 16 | Global Arguments buf_typed : simpl nomatch. 17 | 18 | Definition buf_typed' (buf' : option (list val)) (ct' : option chan_type) (rest : chan_type) : rProp := 19 | match buf', ct' with 20 | | Some buf, Some ct => buf_typed buf ct rest 21 | | None, None => ⌜⌜ rest ≡ EndT ⌝⌝ 22 | | _, _ => False 23 | end. 24 | 25 | Global Instance buf_typed'_params : Params (@buf_typed') 1 := {}. 26 | Global Instance buf_typed'_proper buf : Proper ((≡) ==> (≡) ==> (≡)) (buf_typed' buf). 27 | Proof. solve_proper. Qed. 28 | 29 | Definition bufs_typed (b1' b2' : option (list val)) (σ1' σ2' : option chan_type) : rProp := 30 | ∃ rest, 31 | buf_typed' b1' σ1' rest ∗ 32 | buf_typed' b2' σ2' (dual rest). 33 | 34 | Global Instance bufs_typed_params : Params (@bufs_typed) 2 := {}. 35 | Global Instance bufs_typed_proper b1 b2 : Proper ((≡) ==> (≡) ==> (≡)) (bufs_typed b1 b2). 36 | Proof. solve_proper. Qed. 37 | End bufs_typed. 38 | 39 | Section invariant. 40 | Definition state_inv (es : list expr) (h : heap) (x : object) (in_l : multiset clabel) : rProp := 41 | match x with 42 | | Thread n => 43 | ⌜⌜ in_l ≡ ε ⌝⌝ ∗ 44 | match es !! n with 45 | | Some e => rtyped0 e UnitT 46 | | None => emp 47 | end 48 | | Chan n => ∃ σs : gmap bool chan_type, 49 | ⌜⌜ in_l ≡ map_to_multiset σs ⌝⌝ ∗ 50 | bufs_typed (h !! (n,true)) (h !! (n,false)) (σs !! true) (σs !! false) 51 | end%I. 52 | 53 | Definition invariant (es : list expr) (h : heap) := inv (state_inv es h). 54 | End invariant. 55 | 56 | Global Instance state_inv_proper es h v : Proper ((≡) ==> (⊣⊢)) (state_inv es h v). 57 | Proof. solve_proper_prepare. destruct v; [solve_proper|by setoid_rewrite H]. Qed. 58 | Global Instance state_inv_params : Params (@state_inv) 3. Defined. 59 | 60 | Lemma bufs_typed_sym' b1' b2' σ1' σ2' : 61 | bufs_typed b1' b2' σ1' σ2' ⊢ 62 | bufs_typed b2' b1' σ2' σ1'. 63 | Proof. 64 | iIntros "H". unfold bufs_typed. 65 | iDestruct "H" as (rest) "[H1 H2]". 66 | iExists (dual rest). rewrite dual_dual. iFrame. 67 | Qed. 68 | 69 | Lemma bufs_typed_wlog b b' (h : heap) (σs : gmap bool chan_type) n : 70 | bufs_typed (h !! (n,b)) (h !! (n,negb b)) (σs !! b) (σs !! negb b) ⊢ 71 | bufs_typed (h !! (n,b')) (h !! (n,negb b')) (σs !! b') (σs !! negb b'). 72 | Proof. 73 | destruct (decide (b = b')); subst; first eauto. 74 | assert (negb b = b') as ->. { by destruct b,b'. } 75 | assert (negb b' = b) as ->. { by destruct b,b'. } 76 | by rewrite bufs_typed_sym'. 77 | Qed. 78 | 79 | Lemma buf_typed_push v buf t r c : 80 | val_typed v t ∗ 81 | buf_typed buf c (RecvT t r) ⊢ 82 | buf_typed (buf ++ [v]) c r. 83 | Proof. 84 | iIntros "[H1 H2]". 85 | iInduction buf as [] "IH" forall (r c); simpl. 86 | - iDestruct "H2" as %<-. simpl. iFrame. done. 87 | - destruct c; eauto. iDestruct "H2" as "[H2 H3]". 88 | iFrame. iApply ("IH" with "H1"). done. 89 | Qed. 90 | 91 | Lemma bufs_typed_push b1' t v buf σ2' r : 92 | val_typed v t ∗ 93 | bufs_typed b1' (Some buf) (Some (SendT t r)) σ2' ⊢ 94 | bufs_typed b1' (Some (buf ++ [v])) (Some r) σ2'. 95 | Proof. 96 | iIntros "[H1 H2]". 97 | unfold bufs_typed. 98 | iDestruct "H2" as (rest) "[H2 H3]". 99 | destruct b1'; simpl; eauto. 100 | destruct σ2'; eauto. simpl. destruct l; eauto. simpl. 101 | iDestruct "H2" as "%". subst. simpl. 102 | iExists r. iSplit; eauto. 103 | iApply buf_typed_push. iFrame. 104 | rewrite H dual_send //. 105 | Qed. 106 | 107 | Lemma bufs_typed_pop b1 b2' σ1 σ2' (v : val) t : 108 | bufs_typed (Some (v :: b1)) b2' (Some (RecvT t σ1)) σ2' -∗ 109 | val_typed v t ∗ bufs_typed (Some b1) b2' (Some σ1) σ2'. 110 | Proof. 111 | iIntros "H". 112 | iDestruct "H" as (rest) "[H1 H2]". simpl. 113 | iDestruct "H1" as "[H1 H3]". iFrame. 114 | iExists rest. iFrame. 115 | Qed. 116 | 117 | Lemma bufs_typed_dealloc b2' σ2 : 118 | bufs_typed (Some []) b2' (Some EndT) σ2 ⊢ 119 | bufs_typed None b2' None σ2. 120 | Proof. 121 | iIntros "H". 122 | iDestruct "H" as (rest) "[% H2]". subst. 123 | iExists _. iFrame. done. 124 | Qed. 125 | 126 | Lemma bufs_typed_None σ1 σ2 : 127 | bufs_typed None None σ1 σ2 ⊢ ⌜⌜ σ1 = None ∧ σ2 = None ⌝⌝. 128 | Proof. 129 | iIntros "H". 130 | iDestruct "H" as (rest) "[H1 H2]". 131 | destruct σ1,σ2; eauto. 132 | Qed. 133 | 134 | Lemma bufs_typed_init r : 135 | emp ⊢ bufs_typed (Some []) (Some []) (Some r) (Some (dual r)). 136 | Proof. 137 | iIntros "H". 138 | unfold bufs_typed. 139 | iExists r; simpl; eauto. 140 | Qed. 141 | 142 | Lemma preservation (threads threads' : list expr) (chans chans' : heap) : 143 | step threads chans threads' chans' -> 144 | invariant threads chans -> 145 | invariant threads' chans'. 146 | Proof. 147 | unfold invariant. 148 | intros [i H]. destruct H. 149 | destruct H as [????????HH]. 150 | intros Hinv. 151 | destruct HH; rewrite ?right_id. 152 | - (* Pure step *) 153 | eapply inv_impl; last done. 154 | iIntros ([] x) "H"; simpl; eauto. 155 | iDestruct "H" as "[H1 H2]". iFrame. 156 | rewrite list_lookup_insert_spec. case_decide; eauto. 157 | destruct H2. subst. rewrite H0. 158 | iDestruct (rtyped0_ctx with "H2") as (t) "[H1 H2]"; eauto. 159 | iApply "H2". iApply pure_step_rtyped0; eauto. 160 | - (* Send *) 161 | eapply (inv_exchange (Thread i) (Chan c.1)); last done; first apply _; first apply _. 162 | + intros v x []. iIntros "H". 163 | destruct v; simpl. 164 | * rewrite list_lookup_insert_spec. case_decide; naive_solver. 165 | * setoid_rewrite lookup_insert_spec. repeat case_decide; eauto; destruct c; simpl in *; simplify_eq. 166 | + iIntros (y0) "H". simpl. rewrite H0. 167 | iDestruct "H" as (HH) "H". 168 | iDestruct (rtyped0_ctx with "H") as (t) "[H1 H2]"; eauto. simpl. 169 | iDestruct "H1" as (r t' ->) "[H1 H1']". 170 | iDestruct "H1" as (r0 ?) "H1". simplify_eq. 171 | destruct c. simpl. 172 | iExists _. iFrame. 173 | iIntros (x) "H". 174 | iExists (b, r). 175 | rewrite list_lookup_insert; last by eapply lookup_lt_Some. 176 | iSplitL "H2". 177 | * iIntros "H1". 178 | iSplit; eauto. 179 | iApply "H2". simpl. 180 | eauto with iFrame. 181 | * iDestruct "H" as (σs H2) "H". 182 | iExists (<[ b := r ]> σs). 183 | iSplit. 184 | -- iPureIntro. by eapply map_to_multiset_update. 185 | -- iApply (bufs_typed_wlog b true). 186 | iDestruct (bufs_typed_wlog true b with "H") as "H". 187 | assert (σs !! b ≡ Some (SendT t' r)) as Hrew 188 | by by eapply map_to_multiset_lookup. 189 | rewrite !lookup_insert_spec. 190 | repeat case_decide; simplify_eq; try solve [by destruct b]. 191 | rewrite H1. 192 | iApply bufs_typed_push. iFrame. 193 | rewrite Hrew. done. 194 | - (* Receive *) 195 | eapply (inv_exchange (Thread i) (Chan c.1)); last done; first apply _; first apply _. 196 | + intros v x []. iIntros "H". 197 | destruct v; simpl. 198 | * rewrite list_lookup_insert_spec. case_decide; naive_solver. 199 | * setoid_rewrite lookup_insert_spec. repeat case_decide; eauto; destruct c; simpl in *; simplify_eq. 200 | + iIntros (y0) "H". simpl. rewrite H0. 201 | iDestruct "H" as (HH) "H". 202 | iDestruct (rtyped0_ctx with "H") as (t) "[H1 H2]"; eauto. simpl. 203 | iDestruct "H1" as (t' r ->) "H1". 204 | iDestruct "H1" as (r0 HH') "H1". simplify_eq. 205 | destruct c. simpl. 206 | iExists _. iFrame. 207 | iIntros (x) "H". 208 | iExists (b, r). 209 | rewrite list_lookup_insert; last by eapply lookup_lt_Some. 210 | iDestruct "H" as (σs H2) "H". 211 | iDestruct (bufs_typed_wlog true b with "H") as "H". 212 | assert (σs !! b ≡ Some (RecvT t' r)) as Hrew 213 | by by eapply map_to_multiset_lookup. 214 | simplify_eq. rewrite Hrew. 215 | rewrite H1. 216 | iDestruct (bufs_typed_pop with "H") as "[Hv H]". 217 | iSplitL "H2 Hv". 218 | * iIntros "H1". 219 | iSplit; eauto. 220 | iApply "H2". simpl. 221 | iExists _,_. iSplit; first done. 222 | eauto with iFrame. 223 | * iExists (<[ b := r ]> σs). 224 | iSplit. 225 | -- iPureIntro. by eapply map_to_multiset_update. 226 | -- iApply (bufs_typed_wlog b true). 227 | rewrite !lookup_insert_spec. 228 | repeat case_decide; simplify_eq; try solve [by destruct b]. 229 | - (* Close *) 230 | eapply (inv_dealloc (Thread i) (Chan c.1)); last done; first apply _; first apply _. 231 | + intros v x []. iIntros "H". 232 | destruct v; simpl. 233 | * rewrite list_lookup_insert_spec. case_decide; naive_solver. 234 | * setoid_rewrite lookup_delete_spec. repeat case_decide; eauto; destruct c; simpl in *; simplify_eq. 235 | + iIntros (y0) "H". simpl. rewrite H0. 236 | iDestruct "H" as (HH) "H". 237 | iDestruct (rtyped0_ctx with "H") as (t) "[H1 H2]"; eauto. simpl. 238 | iDestruct "H1" as (->) "H1". 239 | iDestruct "H1" as (r0 HH') "H1". simplify_eq. 240 | destruct c. simpl. 241 | iExists _. iFrame. 242 | iIntros (x) "H". 243 | iDestruct "H" as (σs Hσs) "H". 244 | iDestruct (bufs_typed_wlog true b with "H") as "H". 245 | rewrite H1. 246 | assert (σs !! b ≡ Some EndT) as Hrew 247 | by by eapply map_to_multiset_lookup. 248 | simplify_eq. rewrite Hrew. 249 | rewrite list_lookup_insert; last by eapply lookup_lt_Some. 250 | (* iDestruct (bufs_typed_pop with "H") as "[Hv H]". *) 251 | iSplitL "H2". 252 | * iSplit; eauto. by iApply "H2". 253 | * iExists (delete b σs). 254 | iSplit. 255 | -- iPureIntro. by eapply map_to_multiset_delete. 256 | -- iApply (bufs_typed_wlog b true). 257 | rewrite !lookup_delete_spec. 258 | repeat case_decide; simplify_eq; try solve [by destruct b]. 259 | - (* Fork *) 260 | eapply (inv_alloc_lr (Thread i) (Chan i0) (Thread (length es))); last done; 261 | first apply _; first apply _. 262 | + split_and!; eauto. intro. simplify_eq. 263 | apply lookup_lt_Some in H0. lia. 264 | + intros v' x []. iIntros "H". 265 | destruct v'; simpl. 266 | * rewrite lookup_app_lr. 267 | rewrite list_lookup_insert_spec. 268 | rewrite list_lookup_singleton_spec. 269 | repeat case_decide. 270 | -- naive_solver. 271 | -- naive_solver. 272 | -- destruct H4. exfalso. apply H7. 273 | f_equal. rewrite insert_length in H6. 274 | rewrite insert_length in H5. lia. 275 | -- destruct H4. 276 | rewrite insert_length in H6. 277 | rewrite insert_length in H5. 278 | assert (n > length es) by lia. 279 | rewrite lookup_ge_None_2; eauto. lia. 280 | * setoid_rewrite lookup_insert_spec. 281 | repeat case_decide; simplify_eq. 282 | destruct H4; simplify_eq. 283 | rewrite !lookup_insert_ne //. 284 | intro. simplify_eq. 285 | + iIntros (x) "H". simpl. 286 | iDestruct "H" as (σs Hσs) "H". 287 | rewrite H1 H2. 288 | iDestruct (bufs_typed_None with "H") as "H". 289 | iDestruct "H" as "%". iPureIntro. 290 | rewrite Hσs. 291 | rewrite map_to_multiset_empty'; first done. 292 | intros []; naive_solver. 293 | + iIntros (x) "[H1 H2]". simpl. 294 | iFrame. destruct (es !! length es) eqn:E; eauto. 295 | exfalso. 296 | eapply lookup_lt_Some in E. lia. 297 | + iIntros (y0) "H". simpl. rewrite H0. 298 | iDestruct "H" as (HH) "H". 299 | iDestruct (rtyped0_ctx with "H") as (t) "[H1 H2]"; eauto. simpl. 300 | iDestruct "H1" as (r ->) "H1". 301 | iExists (true,r),(false,dual r). 302 | iSplitL "H2". 303 | * iIntros "H". iSplit; eauto. 304 | rewrite lookup_app_l. 2: { 305 | rewrite insert_length. 306 | eapply lookup_lt_Some; eauto. 307 | } 308 | rewrite list_lookup_insert; eauto using lookup_lt_Some. 309 | iApply "H2". simpl. 310 | eauto. 311 | * iSplitL "". 312 | -- iExists {[ true := r; false := dual r ]}. 313 | iSplit; eauto. 314 | rewrite !lookup_insert. 315 | rewrite lookup_insert_ne; eauto. 316 | rewrite !lookup_insert. 317 | rewrite lookup_insert_ne; eauto. 318 | rewrite !lookup_insert. 319 | by iApply bufs_typed_init. 320 | -- iIntros "H". 321 | iSplit; eauto. 322 | rewrite lookup_app_r. 2: { 323 | by rewrite insert_length. 324 | } 325 | rewrite insert_length. 326 | replace (length es - length es) with 0 by lia. simpl. 327 | iExists _. iFrame. eauto. 328 | Qed. 329 | 330 | 331 | Lemma preservationN (threads threads' : list expr) (chans chans' : heap) : 332 | steps threads chans threads' chans' -> 333 | invariant threads chans -> 334 | invariant threads' chans'. 335 | Proof. induction 1; eauto using preservation. Qed. 336 | 337 | Lemma invariant_init (e : expr) : 338 | typed ∅ e UnitT -> invariant [e] ∅. 339 | Proof. 340 | intros H. 341 | eapply inv_impl; last eauto using inv_init. 342 | intros. simpl. iIntros "[% H]". 343 | unfold state_inv. destruct v. 344 | - destruct n; simpl. 345 | + subst. iSplit; eauto. 346 | iApply rtyped_rtyped0_iff. 347 | iApply typed_rtyped. done. 348 | + subst. iFrame. eauto. 349 | - rewrite !lookup_empty. 350 | iExists ∅. unfold bufs_typed. simpl. rewrite !lookup_empty. iFrame. 351 | iSplit. 352 | + iPureIntro. rewrite map_to_multiset_empty //. 353 | + iExists EndT. rewrite dual_end. 354 | eauto using cteq_EndT. 355 | Qed. 356 | 357 | Lemma invariant_holds e threads chans : 358 | typed ∅ e UnitT -> steps [e] ∅ threads chans -> invariant threads chans. 359 | Proof. eauto using invariant_init, preservationN. Qed. -------------------------------------------------------------------------------- /theories/sessiontypes/langdef.v: -------------------------------------------------------------------------------- 1 | From iris.proofmode Require Import base tactics classes. 2 | 3 | Definition chan := nat. 4 | Definition endpoint := (chan * bool)%type. 5 | 6 | Definition other (e : endpoint) : endpoint := 7 | let '(x,b) := e in (x, negb b). 8 | 9 | Inductive val := 10 | | UnitV : val 11 | | NatV : nat -> val 12 | | PairV : val -> val -> val 13 | | InjV : bool -> val -> val 14 | | FunV : string -> expr -> val 15 | | UFunV : string -> expr -> val 16 | | ChanV : endpoint -> val 17 | 18 | with expr := 19 | | Val : val -> expr 20 | | Var : string -> expr 21 | | Pair : expr -> expr -> expr 22 | | Inj : bool -> expr -> expr 23 | | App : expr -> expr -> expr 24 | | UApp : expr -> expr -> expr 25 | | Lam : string -> expr -> expr 26 | | ULam : string -> expr -> expr 27 | | Send : expr -> expr -> expr 28 | | Recv : expr -> expr 29 | | Let : string -> expr -> expr -> expr 30 | | LetUnit : expr -> expr -> expr 31 | | LetProd : string -> string -> expr -> expr -> expr 32 | | MatchVoid : expr -> expr 33 | | MatchSum : expr -> string -> expr -> expr -> expr 34 | | If : expr -> expr -> expr -> expr 35 | | Fork : expr -> expr 36 | | Close : expr -> expr. 37 | 38 | Canonical Structure valO := leibnizO val. 39 | Canonical Structure exprO := leibnizO expr. 40 | 41 | Definition heap := gmap endpoint (list val). 42 | 43 | CoInductive chan_type' (T : Type) := 44 | | SendT : T -> chan_type' T -> chan_type' T 45 | | RecvT : T -> chan_type' T -> chan_type' T 46 | | EndT : chan_type' T. 47 | Arguments SendT {_} _ _. 48 | Arguments RecvT {_} _ _. 49 | Arguments EndT {_}. 50 | Global Instance sendt_params : Params (@SendT) 1 := {}. 51 | Global Instance recvt_params : Params (@RecvT) 1 := {}. 52 | 53 | 54 | CoInductive chan_type_equiv `{Equiv T} : Equiv (chan_type' T) := 55 | | cteq_EndT : EndT ≡ EndT 56 | | cteq_SendT t1 t2 s1 s2 : t1 ≡ t2 -> s1 ≡ s2 -> SendT t1 s1 ≡ SendT t2 s2 57 | | cteq_RecvT t1 t2 s1 s2 : t1 ≡ t2 -> s1 ≡ s2 -> RecvT t1 s1 ≡ RecvT t2 s2. 58 | Global Existing Instance chan_type_equiv. 59 | 60 | Lemma chan_type_reflexive `{Equiv T} : 61 | Reflexive (≡@{T}) -> Reflexive (≡@{chan_type' T}). 62 | Proof. 63 | intros ?. cofix IH. intros []; constructor; done. 64 | Defined. 65 | 66 | Lemma chan_type_symmetric `{Equiv T} : 67 | Symmetric (≡@{T}) -> Symmetric (≡@{chan_type' T}). 68 | Proof. 69 | intros ?. cofix IH. intros ??[]; constructor; done. 70 | Defined. 71 | 72 | Lemma chan_type_transitive `{Equiv T} : 73 | Transitive (≡@{T}) -> Transitive (≡@{chan_type' T}). 74 | Proof. 75 | intros ?. cofix IH. intros ???[]; inversion_clear 1; constructor; by etrans. 76 | Defined. 77 | 78 | Global Instance chan_type_equivalence `{Equiv T} : 79 | Equivalence (≡@{T}) -> Equivalence (≡@{chan_type' T}). 80 | Proof. 81 | split. 82 | - apply chan_type_reflexive. apply _. 83 | - apply chan_type_symmetric. apply _. 84 | - apply chan_type_transitive. apply _. 85 | Qed. 86 | 87 | Global Instance sendt_proper `{Equiv T} : Proper ((≡) ==> (≡) ==> (≡)) (@SendT T). 88 | Proof. by constructor. Qed. 89 | Global Instance recvt_proper `{Equiv T} : Proper ((≡) ==> (≡) ==> (≡)) (@RecvT T). 90 | Proof. by constructor. Qed. 91 | 92 | Definition chan_type_id {T} (s : chan_type' T) : chan_type' T := 93 | match s with 94 | | SendT t s' => SendT t s' 95 | | RecvT t s' => RecvT t s' 96 | | EndT => EndT 97 | end. 98 | 99 | Lemma chan_type_id_id {T} (s : chan_type' T) : 100 | chan_type_id s = s. 101 | Proof. 102 | by destruct s. 103 | Qed. 104 | 105 | Lemma chan_type_equiv_alt `{Equiv T} (s1 s2 : chan_type' T) : 106 | chan_type_id s1 ≡ chan_type_id s2 -> s1 ≡ s2. 107 | Proof. 108 | intros. 109 | rewrite -(chan_type_id_id s1). 110 | rewrite -(chan_type_id_id s2). 111 | done. 112 | Defined. 113 | 114 | Lemma chan_type_equiv_end_eq `{Equiv T} (s : chan_type' T) : 115 | s ≡ EndT -> s = EndT. 116 | Proof. 117 | by inversion 1. 118 | Qed. 119 | 120 | CoFixpoint dual {T} (s : chan_type' T) : chan_type' T := 121 | match s with 122 | | SendT t s' => RecvT t (dual s') 123 | | RecvT t s' => SendT t (dual s') 124 | | EndT => EndT 125 | end. 126 | 127 | Global Instance dual_proper `{Equiv T} : Proper ((≡) ==> (≡)) (@dual T). 128 | Proof. 129 | cofix IH. 130 | intros s1 s2 HH. 131 | apply chan_type_equiv_alt. 132 | destruct HH; simpl; constructor; done || by apply IH. 133 | Qed. 134 | 135 | Section dual. 136 | Context `{Equiv T, !Equivalence (≡@{T})}. 137 | Implicit Type s : chan_type' T. 138 | 139 | Lemma dual_dual s : 140 | dual (dual s) ≡ s. 141 | Proof. 142 | apply chan_type_equiv_alt. 143 | revert s. cofix IH. intros []; simpl; constructor; try done; 144 | apply chan_type_equiv_alt; apply IH. 145 | Qed. 146 | 147 | Lemma dual_send s t : dual (SendT t s) ≡ RecvT t (dual s). 148 | Proof. 149 | apply chan_type_equiv_alt; done. 150 | Qed. 151 | 152 | Lemma dual_recv s t : dual (RecvT t s) ≡ SendT t (dual s). 153 | Proof. 154 | apply chan_type_equiv_alt; done. 155 | Qed. 156 | 157 | Lemma dual_end : dual (EndT : chan_type' T) ≡ EndT. 158 | Proof. 159 | apply chan_type_equiv_alt; done. 160 | Qed. 161 | 162 | Lemma dual_end_inv s : dual s ≡ EndT -> s = EndT. 163 | Proof. 164 | intros HH. destruct s; eauto. 165 | - rewrite ->dual_send in HH. inversion HH. 166 | - rewrite ->dual_recv in HH. inversion HH. 167 | Qed. 168 | End dual. 169 | 170 | Canonical Structure chan_type'O (T:ofe) := discreteO (chan_type' T). 171 | 172 | CoInductive type := 173 | | UnitT : type 174 | | VoidT : type 175 | | NatT : type 176 | | PairT : type -> type -> type 177 | | SumT : type -> type -> type 178 | | FunT : type -> type -> type 179 | | UFunT : type -> type -> type 180 | | ChanT : chan_type' type -> type. 181 | 182 | Definition type_id (t : type) := 183 | match t with 184 | | UnitT => UnitT 185 | | VoidT => VoidT 186 | | NatT => NatT 187 | | PairT t1 t2 => PairT t1 t2 188 | | SumT t1 t2 => SumT t1 t2 189 | | FunT t1 t2 => FunT t1 t2 190 | | UFunT t1 t2 => UFunT t1 t2 191 | | ChanT s => ChanT s 192 | end. 193 | 194 | Lemma type_id_id t : type_id t = t. 195 | Proof. 196 | by destruct t. 197 | Qed. 198 | 199 | CoInductive type_equiv : Equiv type := 200 | | teq_UnitT : UnitT ≡ UnitT 201 | | teq_VoidT : VoidT ≡ VoidT 202 | | teq_NatT : NatT ≡ NatT 203 | | teq_PairT t1 t2 t1' t2' : t1 ≡ t2 -> t1' ≡ t2' -> PairT t1 t1' ≡ PairT t2 t2' 204 | | teq_SumT t1 t2 t1' t2' : t1 ≡ t2 -> t1' ≡ t2' -> SumT t1 t1' ≡ SumT t2 t2' 205 | | teq_FunT t1 t2 t1' t2' : t1 ≡ t2 -> t1' ≡ t2' -> FunT t1 t1' ≡ FunT t2 t2' 206 | | teq_UFunT t1 t2 t1' t2' : t1 ≡ t2 -> t1' ≡ t2' -> UFunT t1 t1' ≡ UFunT t2 t2' 207 | | teq_ChanT s1 s2 : s1 ≡ s2 -> ChanT s1 ≡ ChanT s2. 208 | Global Existing Instance type_equiv. 209 | 210 | Global Instance type_equivalence : Equivalence (≡@{type}). 211 | Proof. 212 | split. 213 | - cofix IH. intros []; constructor; done || apply chan_type_reflexive, _. 214 | - cofix IH. intros ??[]; constructor; done || by apply (chan_type_symmetric _). 215 | - cofix IH. intros ???[]; inversion_clear 1; constructor; 216 | by etrans || by eapply (chan_type_transitive _). 217 | Qed. 218 | 219 | Canonical Structure typeO := discreteO type. 220 | Notation chan_type := (chan_type' type). 221 | Notation chan_typeO := (chan_type'O typeO). 222 | 223 | Notation envT := (gmap string type). 224 | 225 | CoInductive unrestricted : type -> Prop := 226 | | Nat_unrestricted : unrestricted NatT 227 | | Unit_unrestricted : unrestricted UnitT 228 | | Void_unrestricted : unrestricted VoidT 229 | | UFun_unrestricted t1 t2 : unrestricted (UFunT t1 t2) 230 | | Pair_unrestricted t1 t2 : 231 | unrestricted t1 -> unrestricted t2 -> 232 | unrestricted (PairT t1 t2) 233 | | Sum_unrestricted t1 t2 : 234 | unrestricted t1 -> unrestricted t2 -> 235 | unrestricted (SumT t1 t2). 236 | 237 | Definition disj (Γ1 Γ2 : envT) : Prop := 238 | ∀ i t1 t2, Γ1 !! i = Some t1 -> Γ2 !! i = Some t2 -> t1 ≡ t2 ∧ unrestricted t1. 239 | 240 | Definition Γunrestricted (Γ : envT) := 241 | ∀ x t, Γ !! x = Some t -> unrestricted t. 242 | 243 | Lemma Γunrestricted_empty : Γunrestricted ∅. 244 | Proof. 245 | intros ??. rewrite lookup_empty. intro. congruence. 246 | Qed. 247 | 248 | Inductive typed : envT -> expr -> type -> Prop := 249 | | Unit_typed Γ : 250 | Γunrestricted Γ -> 251 | typed Γ (Val UnitV) UnitT 252 | | Nat_typed : ∀ Γ n, 253 | Γunrestricted Γ -> 254 | typed Γ (Val (NatV n)) NatT 255 | | Var_typed : ∀ Γ x t t', 256 | Γ !! x = None -> 257 | Γunrestricted Γ -> 258 | t ≡ t' -> 259 | typed (Γ ∪ {[ x := t ]}) (Var x) t' 260 | | Pair_typed : ∀ Γ1 Γ2 e1 e2 t1 t2, 261 | disj Γ1 Γ2 -> 262 | typed Γ1 e1 t1 -> 263 | typed Γ2 e2 t2 -> 264 | typed (Γ1 ∪ Γ2) (Pair e1 e2) (PairT t1 t2) 265 | | App_typed : ∀ Γ1 Γ2 e1 e2 t1 t2, 266 | disj Γ1 Γ2 -> 267 | typed Γ1 e1 (FunT t1 t2) -> 268 | typed Γ2 e2 t1 -> 269 | typed (Γ1 ∪ Γ2) (App e1 e2) t2 270 | | UApp_typed : ∀ Γ1 Γ2 e1 e2 t1 t2, 271 | disj Γ1 Γ2 -> 272 | typed Γ1 e1 (UFunT t1 t2) -> 273 | typed Γ2 e2 t1 -> 274 | typed (Γ1 ∪ Γ2) (UApp e1 e2) t2 275 | | Lam_typed : ∀ Γ x e t1 t2, 276 | Γ !! x = None -> 277 | typed (Γ ∪ {[ x := t1 ]}) e t2 -> 278 | typed Γ (Lam x e) (FunT t1 t2) 279 | | ULam_typed : ∀ Γ x e t1 t2, 280 | Γ !! x = None -> 281 | Γunrestricted Γ -> 282 | typed (Γ ∪ {[ x := t1 ]}) e t2 -> 283 | typed Γ (ULam x e) (UFunT t1 t2) 284 | | Send_typed : ∀ Γ1 Γ2 e1 e2 t r, 285 | disj Γ1 Γ2 -> 286 | typed Γ1 e1 (ChanT (SendT t r)) -> 287 | typed Γ2 e2 t -> 288 | typed (Γ1 ∪ Γ2) (Send e1 e2) (ChanT r) 289 | | Recv_typed : ∀ Γ e t r, 290 | typed Γ e (ChanT (RecvT t r)) -> 291 | typed Γ (Recv e) (PairT (ChanT r) t) 292 | | Let_typed : ∀ Γ1 Γ2 e1 e2 t1 t2 x, 293 | disj Γ1 Γ2 -> 294 | Γ2 !! x = None -> 295 | typed Γ1 e1 t1 -> 296 | typed (Γ2 ∪ {[ x := t1 ]}) e2 t2 -> 297 | typed (Γ1 ∪ Γ2) (Let x e1 e2) t2 298 | | LetUnit_typed : ∀ Γ1 Γ2 e1 e2 t, 299 | disj Γ1 Γ2 -> 300 | typed Γ1 e1 UnitT -> 301 | typed Γ2 e2 t -> 302 | typed (Γ1 ∪ Γ2) (LetUnit e1 e2) t 303 | | LetProd_typed : ∀ Γ1 Γ2 e1 e2 t11 t12 t2 x1 x2, 304 | disj Γ1 Γ2 -> 305 | x1 ≠ x2 -> 306 | Γ2 !! x1 = None -> 307 | Γ2 !! x2 = None -> 308 | typed Γ1 e1 (PairT t11 t12) -> 309 | typed (Γ2 ∪ {[ x1 := t11 ]} ∪ {[ x2 := t12 ]}) e2 t2 -> 310 | typed (Γ1 ∪ Γ2) (LetProd x1 x2 e1 e2) t2 311 | | MatchVoid_typed : ∀ Γ e t, 312 | typed Γ e VoidT -> 313 | typed Γ (MatchVoid e) t 314 | | MatchSum_typed : ∀ Γ1 Γ2 e1 eL eR tL tR t x, 315 | disj Γ1 Γ2 -> 316 | Γ2 !! x = None -> 317 | typed Γ1 e1 (SumT tL tR) -> 318 | typed (Γ2 ∪ {[ x := tL ]}) eL t -> 319 | typed (Γ2 ∪ {[ x := tR ]}) eR t -> 320 | typed (Γ1 ∪ Γ2) (MatchSum e1 x eL eR) t 321 | | If_typed : ∀ Γ1 Γ2 e1 e2 e3 t, 322 | disj Γ1 Γ2 -> 323 | typed Γ1 e1 NatT -> 324 | typed Γ2 e2 t -> 325 | typed Γ2 e3 t -> 326 | typed (Γ1 ∪ Γ2) (If e1 e2 e3) t 327 | | Fork_typed : ∀ Γ e ct, 328 | typed Γ e (FunT (ChanT (dual ct)) UnitT) -> 329 | typed Γ (Fork e) (ChanT ct) 330 | | Close_typed : ∀ Γ e, 331 | typed Γ e (ChanT EndT) -> 332 | typed Γ (Close e) UnitT 333 | | Iso_typed : ∀ Γ t t' e, 334 | t ≡ t' -> (* The ≡-relation is unfolding of recursive types *) 335 | typed Γ e t -> 336 | typed Γ e t'. 337 | 338 | Fixpoint subst (x:string) (a:val) (e:expr) : expr := 339 | match e with 340 | | Val _ => e 341 | | Var x' => if decide (x = x') then Val a else e 342 | | App e1 e2 => App (subst x a e1) (subst x a e2) 343 | | Inj b e1 => Inj b (subst x a e1) 344 | | Pair e1 e2 => Pair (subst x a e1) (subst x a e2) 345 | | UApp e1 e2 => UApp (subst x a e1) (subst x a e2) 346 | | Lam x' e1 => if decide (x = x') then e else Lam x' (subst x a e1) 347 | | ULam x' e1 => if decide (x = x') then e else ULam x' (subst x a e1) 348 | | Send e1 e2 => Send (subst x a e1) (subst x a e2) 349 | | Recv e1 => Recv (subst x a e1) 350 | | Let x' e1 e2 => Let x' (subst x a e1) (if decide (x = x') then e2 else subst x a e2) 351 | | LetUnit e1 e2 => LetUnit (subst x a e1) (subst x a e2) 352 | | LetProd x' y' e1 e2 => 353 | LetProd x' y' (subst x a e1) (if decide (x = x' ∨ x = y') then e2 else subst x a e2) 354 | | MatchVoid e1 => MatchVoid (subst x a e1) 355 | | MatchSum e1 x' eL eR => 356 | MatchSum (subst x a e1) x' 357 | (if decide (x = x') then eL else subst x a eL) 358 | (if decide (x = x') then eR else subst x a eR) 359 | | If e1 e2 e3 => If (subst x a e1) (subst x a e2) (subst x a e3) 360 | | Fork e1 => Fork (subst x a e1) 361 | | Close e1 => Close (subst x a e1) 362 | end. 363 | 364 | Inductive pure_step : expr -> expr -> Prop := 365 | | Pair_step : ∀ v1 v2, 366 | pure_step (Pair (Val v1) (Val v2)) (Val (PairV v1 v2)) 367 | | Inj_step : ∀ v1 b, 368 | pure_step (Inj b (Val v1)) (Val (InjV b v1)) 369 | | App_step : ∀ x e a, 370 | pure_step (App (Val (FunV x e)) (Val a)) (subst x a e) 371 | | UApp_step : ∀ x e a, 372 | pure_step (UApp (Val (UFunV x e)) (Val a)) (subst x a e) 373 | | Lam_step : ∀ x e, 374 | pure_step (Lam x e) (Val (FunV x e)) 375 | | ULam_step : ∀ x e, 376 | pure_step (ULam x e) (Val (UFunV x e)) 377 | | If_step1 : ∀ n e1 e2, 378 | n ≠ 0 -> 379 | pure_step (If (Val (NatV n)) e1 e2) e1 380 | | If_step2 : ∀ e1 e2, 381 | pure_step (If (Val (NatV 0)) e1 e2) e2 382 | | MatchSum_step : ∀ x v eL eR b, 383 | pure_step (MatchSum (Val (InjV b v)) x eL eR) 384 | (if b then subst x v eL else subst x v eR) 385 | | Let_step : ∀ x v e, 386 | pure_step (Let x (Val v) e) (subst x v e) 387 | | LetUnit_step : ∀ e, 388 | pure_step (LetUnit (Val UnitV) e) e 389 | | LetProd_step : ∀ x1 x2 v1 v2 e, 390 | pure_step (LetProd x1 x2 (Val (PairV v1 v2)) e) (subst x1 v1 $ subst x2 v2 e). 391 | 392 | Inductive head_step : expr -> heap -> expr -> heap -> list expr -> Prop := 393 | | Pure_step : ∀ e e' h, 394 | pure_step e e' -> head_step e h e' h [] 395 | | Send_step : ∀ h c y buf, 396 | h !! (other c) = Some buf -> 397 | head_step (Send (Val (ChanV c)) (Val y)) h (Val (ChanV c)) (<[ other c := buf ++ [y] ]> h) [] 398 | | Recv_step : ∀ h c y buf, 399 | h !! c = Some (y::buf) -> 400 | head_step (Recv (Val (ChanV c))) h (Val (PairV (ChanV c) y)) (<[ c := buf ]> h) [] 401 | | Close_step : ∀ c h, 402 | h !! c = Some [] -> 403 | head_step (Close (Val (ChanV c))) h (Val UnitV) (delete c h) [] 404 | | Fork_step : ∀ v (h : heap) i, 405 | h !! (i,true) = None -> 406 | h !! (i,false) = None -> 407 | head_step 408 | (Fork (Val v)) h 409 | (Val $ ChanV (i, true)) (<[ (i,true) := [] ]> $ <[ (i,false) := [] ]> h) 410 | [App (Val v) (Val (ChanV (i, false)))]. 411 | 412 | Inductive ctx1 : (expr -> expr) -> Prop := 413 | | Ctx_App_l : ∀ e, ctx1 (λ x, App x e) 414 | | Ctx_App_r : ∀ v, ctx1 (λ x, App (Val v) x) 415 | | Ctx_Pair_l : ∀ e, ctx1 (λ x, Pair x e) 416 | | Ctx_Pair_r : ∀ v, ctx1 (λ x, Pair (Val v) x) 417 | | Ctx_Inj : ∀ b, ctx1 (λ x, Inj b x) 418 | | Ctx_UApp_l : ∀ e, ctx1 (λ x, UApp x e) 419 | | Ctx_UApp_r : ∀ v, ctx1 (λ x, UApp (Val v) x) 420 | | Ctx_Send_l : ∀ e, ctx1 (λ x, Send x e) 421 | | Ctx_Send_r : ∀ v, ctx1 (λ x, Send (Val v) x) 422 | | Ctx_Recv : ctx1 (λ x, Recv x) 423 | | Ctx_Let : ∀ s e, ctx1 (λ x, Let s x e) 424 | | Ctx_LetUnit : ∀ e, ctx1 (λ x, LetUnit x e) 425 | | Ctx_LetProd : ∀ s1 s2 e, ctx1 (λ x, LetProd s1 s2 x e) 426 | | Ctx_MatchVoid : ctx1 (λ x, MatchVoid x) 427 | | Ctx_MatchSum : ∀ s e1 e2, ctx1 (λ x, MatchSum x s e1 e2) 428 | | Ctx_If : ∀ e1 e2, ctx1 (λ x, If x e1 e2) 429 | | Ctx_Fork : ctx1 (λ x, Fork x) 430 | | Ctx_Close : ctx1 (λ x, Close x). 431 | 432 | Inductive ctx : (expr -> expr) -> Prop := 433 | | Ctx_nil : ctx (λ x, x) 434 | | Ctx_cons : ∀ k1 k2, ctx1 k1 -> ctx k2 -> ctx (λ x, (k1 (k2 x))). 435 | 436 | Inductive ctx_step : expr -> heap -> expr -> heap -> list expr -> Prop := 437 | | Ctx_step : ∀ k e h e' h' ts, 438 | ctx k -> head_step e h e' h' ts -> ctx_step (k e) h (k e') h' ts. 439 | 440 | Inductive stepi : nat -> list expr -> heap -> list expr -> heap -> Prop := 441 | | Head_step : ∀ e e' h h' i ts es, 442 | ctx_step e h e' h' ts -> 443 | es !! i = Some e -> 444 | stepi i es h (<[i := e']> es ++ ts) h'. 445 | 446 | Definition step es h es' h' := ∃ i, stepi i es h es' h'. 447 | 448 | Definition can_stepi i es h := ∃ es' h', stepi i es h es' h'. 449 | 450 | (* Closure of the step relation; this is used in the theorem statement. *) 451 | Inductive steps : list expr -> heap -> list expr -> heap -> Prop := 452 | | Trans_step : ∀ e1 e2 e3 s1 s2 s3, 453 | step e1 s1 e2 s2 -> 454 | steps e2 s2 e3 s3 -> 455 | steps e1 s1 e3 s3 456 | | Empty_step : ∀ e1 s1, 457 | steps e1 s1 e1 s1. -------------------------------------------------------------------------------- /theories/sessiontypes/safety.v: -------------------------------------------------------------------------------- 1 | From cgraphs.sessiontypes Require Import invariant progress. 2 | 3 | Theorem safety (e : expr) (es : list expr) (h : heap) : 4 | typed ∅ e UnitT -> 5 | steps [e] ∅ es h -> 6 | (h = ∅ ∧ ∀ e, e ∈ es -> e = Val UnitV) ∨ 7 | (∃ es' h', step es h es' h'). 8 | Proof. 9 | intros Htyped Hsteps. 10 | by eapply global_progress, invariant_holds. 11 | Qed. 12 | 13 | 14 | (* 15 | The following command can be used to verify that everything has been formally 16 | proved. It should print "classic : ∀ P : Prop, P ∨ ¬ P" as the only axiom. 17 | This indicates that our proof relies on classical logic. 18 | (we use classical logic for convenience.) 19 | *) 20 | (* Print Assumptions safety. *) -------------------------------------------------------------------------------- /theories/sessiontypes/ycombinator.v: -------------------------------------------------------------------------------- 1 | From iris.proofmode Require Import base tactics classes. 2 | From cgraphs.sessiontypes Require Import langdef. 3 | 4 | Section ycombinator. 5 | (* We define the y-combinator for creating recursive functions t1 -> t2. *) 6 | Variable t1 t2 : type. 7 | 8 | Definition gT := UFunT t1 t2. 9 | Definition fT := UFunT gT gT. 10 | CoFixpoint xT := UFunT xT gT. 11 | 12 | Lemma unfold_xT : xT = UFunT xT gT. 13 | by rewrite <-type_id_id at 1. 14 | Qed. 15 | 16 | Definition y1 := ULam "x" (UApp (Var "f") (ULam "v" (UApp (UApp (Var "x") (Var "x")) (Var "v")))). 17 | Definition y := ULam "f" (UApp y1 y1). 18 | 19 | Lemma Var_typed' x xT : typed {[x := xT]} (Var x) xT. 20 | Proof. 21 | replace {[x := xT]} with (∅ ∪ {[x := xT]} : envT) by rewrite left_id //. 22 | eapply Var_typed; eauto. 23 | eapply Γunrestricted_empty. 24 | Qed. 25 | 26 | Lemma Γunrestricted_singleton x xT : unrestricted xT -> Γunrestricted {[x := xT]}. 27 | Proof. 28 | intros ???. destruct (decide (x = x0)); subst. 29 | - rewrite lookup_singleton. intros. simplify_eq. done. 30 | - rewrite lookup_singleton_ne; eauto. intros. simplify_eq. 31 | Qed. 32 | 33 | Lemma singleton_disj x y xT yT : 34 | String.eqb x y = false ∨ (xT = yT ∧ unrestricted xT) -> disj {[x := xT]} {[y := yT]}. 35 | Proof. 36 | intros ??????. 37 | eapply lookup_singleton_Some in H0 as []. 38 | eapply lookup_singleton_Some in H1 as []. 39 | subst. rewrite String.eqb_refl in H. 40 | destruct H; simplify_eq. destruct H; subst. eauto. 41 | Qed. 42 | 43 | Lemma fT_unrestricted : unrestricted fT. 44 | Proof. constructor. Qed. 45 | Lemma xT_unrestricted : unrestricted xT. 46 | rewrite <-type_id_id. constructor. 47 | Qed. 48 | 49 | Ltac check := eauto using Γunrestricted_singleton, Γunrestricted_empty, fT_unrestricted, xT_unrestricted, singleton_disj. 50 | 51 | Lemma ctx_dup (Γ : envT) : Γ = Γ ∪ Γ. 52 | Proof. 53 | eapply map_eq. intro. 54 | rewrite lookup_union. destruct (_!!_); eauto. 55 | Qed. 56 | 57 | Lemma y1_typed : typed {[ "f" := fT ]} y1 (UFunT xT gT). 58 | Proof. 59 | unfold y1. 60 | eapply ULam_typed; check. 61 | eapply UApp_typed; check. 62 | - eapply Var_typed'. 63 | - eapply ULam_typed; check. 64 | eapply UApp_typed; check. 65 | + rewrite ->ctx_dup at 1. 66 | eapply UApp_typed; check. 67 | * rewrite ->unfold_xT at 1. eapply Var_typed'. 68 | * eapply Var_typed'. 69 | + eapply Var_typed'. 70 | Qed. 71 | 72 | Lemma y_typed : typed ∅ y (UFunT fT gT). 73 | Proof. 74 | unfold y. 75 | eapply ULam_typed; check. 76 | rewrite left_id. rewrite ->ctx_dup at 1. 77 | eapply UApp_typed; check. 78 | - eapply y1_typed. 79 | - rewrite unfold_xT. eapply y1_typed. 80 | Qed. 81 | End ycombinator. --------------------------------------------------------------------------------