├── .github └── workflows │ └── docker-action.yml ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── _CoqProject ├── coq-disel-calculator.opam ├── coq-disel-examples.opam ├── coq-disel-tpc.opam ├── coq-disel.opam ├── dune-project ├── extraction ├── TPC │ └── TwoPhaseExtraction.v └── calculator │ └── CalculatorExtraction.v ├── meta.yml ├── scripts ├── calculator.sh └── tpc.sh ├── shims ├── CalculatorMain.ml ├── Debug.ml ├── DiSeL.ml ├── Shim.ml ├── TPCMain.ml └── Util.ml └── theories ├── Core ├── Actions.v ├── Always.v ├── DepMaps.v ├── DiSeLExtraction.v ├── EqTypeX.v ├── Freshness.v ├── HoareTriples.v ├── InductiveInv.v ├── InferenceRules.v ├── Injection.v ├── InjectionOld.v ├── NetworkSem.v ├── NewStatePredicates.v ├── Process.v ├── Protocols.v ├── Rely.v ├── State.v ├── StatePredicates.v ├── While.v ├── Worlds.v └── dune └── Examples ├── Calculator ├── CalculatorClientLib.v ├── CalculatorInvariant.v ├── CalculatorProtocol.v ├── CalculatorServerLib.v ├── DelegatingCalculatorServer.v ├── SimpleCalculatorApp.v └── SimpleCalculatorServers.v ├── Greeter └── Greeter.v ├── LockResource ├── LockProtocol.v └── ResourceProtocol.v ├── Querying ├── QueryHooked.v ├── QueryPlusTPC.v └── QueryProtocol.v ├── SeqLib.v ├── TwoPhaseCommit ├── SimpleTPCApp.v ├── TwoPhaseClient.v ├── TwoPhaseCoordinator.v ├── TwoPhaseInductiveInv.v ├── TwoPhaseInductiveProof.v ├── TwoPhaseParticipant.v └── TwoPhaseProtocol.v └── dune /.github/workflows/docker-action.yml: -------------------------------------------------------------------------------- 1 | name: Docker CI 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | branches: 9 | - '**' 10 | 11 | jobs: 12 | build: 13 | # the OS must be GNU/Linux to be able to use the docker-coq-action 14 | runs-on: ubuntu-latest 15 | strategy: 16 | matrix: 17 | image: 18 | - 'mathcomp/mathcomp:1.19.0-coq-8.19' 19 | - 'mathcomp/mathcomp:1.18.0-coq-8.18' 20 | - 'mathcomp/mathcomp:1.17.0-coq-8.17' 21 | - 'mathcomp/mathcomp:1.17.0-coq-8.16' 22 | - 'mathcomp/mathcomp:1.15.0-coq-8.15' 23 | - 'mathcomp/mathcomp:1.14.0-coq-8.15' 24 | - 'mathcomp/mathcomp:1.14.0-coq-8.14' 25 | - 'mathcomp/mathcomp:1.13.0-coq-8.15' 26 | - 'mathcomp/mathcomp:1.13.0-coq-8.14' 27 | fail-fast: false 28 | steps: 29 | - uses: actions/checkout@v4 30 | - uses: coq-community/docker-coq-action@v1 31 | with: 32 | custom_image: ${{ matrix.image }} 33 | custom_script: | 34 | {{before_install}} 35 | startGroup "Build disel dependencies" 36 | opam pin add -n -y -k path coq-disel . 37 | opam update -y 38 | opam install -y -j $(nproc) coq-disel --deps-only 39 | endGroup 40 | startGroup "Build disel" 41 | opam install -y -v -j $(nproc) coq-disel 42 | opam list 43 | endGroup 44 | startGroup "Build disel-examples dependencies" 45 | opam pin add -n -y -k path coq-disel-examples . 46 | opam update -y 47 | opam install -y -j $(nproc) coq-disel-examples --deps-only 48 | endGroup 49 | startGroup "Build disel-examples" 50 | opam install -y -v -j $(nproc) coq-disel-examples 51 | opam list 52 | endGroup 53 | startGroup "Uninstallation test" 54 | opam remove -y coq-disel-examples 55 | opam remove -y coq-disel 56 | endGroup 57 | 58 | # See also: 59 | # https://github.com/coq-community/docker-coq-action#readme 60 | # https://github.com/erikmd/docker-coq-github-action-demo 61 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # ----------------------------------------------------------------------------- 2 | # Generic generated file patterns 3 | # ----------------------------------------------------------------------------- 4 | 5 | Thumbs.db 6 | .DS_Store 7 | .svn 8 | 9 | *~ 10 | #*# 11 | *.bak 12 | *.BAK 13 | *.orig 14 | *.prof 15 | *.rej 16 | 17 | *.hi 18 | *.hi-boot 19 | *.o-boot 20 | *.p_o 21 | *.t_o 22 | *.debug_o 23 | *.thr_o 24 | *.thr_p_o 25 | *.thr_debug_o 26 | *.o 27 | *.vo 28 | *.vio 29 | *.vos 30 | *.vok 31 | *.a 32 | *.o.cmd 33 | *.depend* 34 | .#* 35 | log 36 | tags 37 | 38 | # ----------------------------------------------------------------------------- 39 | # Haskell leftovers 40 | # ----------------------------------------------------------------------------- 41 | 42 | dist 43 | cabal-dev 44 | *.o 45 | *.hi 46 | *.chi 47 | *.chs.h 48 | *.dyn_o 49 | *.dyn_hi 50 | .virtualenv 51 | .hpc 52 | .hsenv 53 | .cabal-sandbox/ 54 | cabal.sandbox.config 55 | *.prof 56 | *.aux 57 | *.hp 58 | 59 | # ----------------------------------------------------------------------------- 60 | # Emacs-generated TeX files 61 | # ----------------------------------------------------------------------------- 62 | 63 | _region_.* 64 | cv/*.out 65 | *.rel 66 | *.log 67 | *.blg 68 | *.aux 69 | *.bbl 70 | *.synctex.gz 71 | *.out.ps 72 | .#* 73 | 74 | # ----------------------------------------------------------------------------- 75 | # Coq-generated stuff 76 | # ----------------------------------------------------------------------------- 77 | 78 | \#*\# 79 | *.vo 80 | *.v.d 81 | *.glob 82 | .coq-native 83 | Makefile.coq 84 | extraction/**/*.mli 85 | extraction/**/*.ml 86 | _build 87 | *.d.byte 88 | *.native 89 | Makefile.coq.conf 90 | .Makefile.coq.d 91 | .coqdeps.d 92 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016-2020, Distributed Components Team. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | Redistributions of source code must retain the above copyright notice, 9 | this list of conditions and the following disclaimer. 10 | 11 | Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 16 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 17 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 18 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 19 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 20 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 21 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 22 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 23 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 24 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | OCAMLBUILD = ocamlbuild -tag safe_string -pkg unix -I shims 2 | 3 | default: Makefile.coq 4 | $(MAKE) -f Makefile.coq 5 | 6 | install: Makefile.coq 7 | $(MAKE) -f Makefile.coq install 8 | 9 | clean: Makefile.coq 10 | $(MAKE) -f Makefile.coq cleanall 11 | rm -f Makefile.coq Makefile.coq.conf 12 | $(OCAMLBUILD) -clean 13 | 14 | tpc: TPCMain.native 15 | 16 | calculator: CalculatorMain.native 17 | 18 | Makefile.coq: _CoqProject 19 | coq_makefile -f _CoqProject -o Makefile.coq 20 | 21 | TPCMain.d.byte: default 22 | $(OCAMLBUILD) -I extraction/TPC shims/TPCMain.d.byte 23 | 24 | TPCMain.native: default 25 | $(OCAMLBUILD) -I extraction/TPC shims/TPCMain.native 26 | 27 | CalculatorMain.d.byte: default 28 | $(OCAMLBUILD) -I extraction/calculator shims/CalculatorMain.d.byte 29 | 30 | CalculatorMain.native: default 31 | $(OCAMLBUILD) -I extraction/calculator shims/CalculatorMain.native 32 | 33 | .PHONY: default clean install tpc calculator 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 5 | # Disel: Distributed Separation Logic 6 | 7 | [![Docker CI][docker-action-shield]][docker-action-link] 8 | 9 | [docker-action-shield]: https://github.com/DistributedComponents/disel/actions/workflows/docker-action.yml/badge.svg?branch=master 10 | [docker-action-link]: https://github.com/DistributedComponents/disel/actions/workflows/docker-action.yml 11 | 12 | 13 | 14 | 15 | Disel is a framework for implementation and compositional verification of 16 | distributed systems and their clients in Coq. In Disel, users implement 17 | distributed systems using a domain specific language shallowly embedded in Coq 18 | which provides both high-level programming constructs as well as low-level 19 | communication primitives. Components of composite systems are specified in Disel 20 | as protocols, which capture system-specific logic and disentangle system definitions 21 | from implementation details. 22 | 23 | ## Meta 24 | 25 | - Author(s): 26 | - Ilya Sergey (initial) 27 | - James R. Wilcox (initial) 28 | - License: [BSD 2-Clause "Simplified" license](LICENSE) 29 | - Compatible Coq versions: 8.14 or later 30 | - Additional dependencies: 31 | - [MathComp](https://math-comp.github.io) 1.13.0 to 1.19.0 (`ssreflect` suffices) 32 | - [FCSL PCM](https://github.com/imdea-software/fcsl-pcm) 1.7.0 or later 33 | - [Hoare Type Theory](https://github.com/imdea-software/htt) 1.2.0 or later 34 | - Coq namespace: `DiSeL` 35 | - Related publication(s): 36 | - [Programming and Proving with Distributed Protocols](http://jamesrwilcox.com/disel.pdf) doi:[10.1145/3158116](https://doi.org/10.1145/3158116) 37 | 38 | ## Building and installation instructions 39 | 40 | The easiest way to install the latest released version of Disel: Distributed Separation Logic 41 | is via [OPAM](https://opam.ocaml.org/doc/Install.html): 42 | 43 | ```shell 44 | opam repo add coq-released https://coq.inria.fr/opam/released 45 | opam install coq-disel 46 | ``` 47 | 48 | To instead build and install manually, do: 49 | 50 | ``` shell 51 | git clone https://github.com/DistributedComponents/disel.git 52 | cd disel 53 | make # or make -j 54 | make install 55 | ``` 56 | 57 | 58 | ## Project Structure 59 | 60 | - `theories/Core` -- Disel Coq implementation, metatheory and inference rules; 61 | - `theories/Examples` -- Case studies implemented in Disel using Coq 62 | - `Calculator` -- the calculator system; 63 | - `Greeter` -- a toy "Hello World"-like protocol, where 64 | participants can only exchange greetings with each other; 65 | - `TwoPhaseCommit` -- Two Phase Commit protocol implementation; 66 | - `Query` -- querying protocol and its composition with Two Phase 67 | Commit via hooks; 68 | - `shims` -- DiSeL runtime system in OCaml 69 | 70 | ## VM Instructions 71 | 72 | Please download 73 | [the virtual machine](http://homes.cs.washington.edu/~jrw12/popl18-disel-artifact.ova), 74 | import it into VirtualBox, and boot the machine. This VM image has been tested with 75 | VirtualBox versions 5.1.24 and 5.1.28 with Oracle VM VirtualBox Extension Pack. Versions 76 | 4.X are known not to work with this image. 77 | 78 | If prompted for login information, both the username and password are 79 | "popl" (without quotes). 80 | 81 | For your convenience, all necessary software, including Coq 8.6 and 82 | ssreflect have been installed, and a checkout of Disel is present in 83 | `~/disel`. Additionally, emacs and Proof General are installed so that 84 | you can browse the sources. 85 | 86 | We recommend checking the proofs using the provided Makefile and 87 | running the two extracted applications. Additionally, you might be interested 88 | to compare the definitions and theorems from some parts of the paper to their 89 | formalizations in Coq. 90 | 91 | Checking the proofs can be accomplished by opening a terminal and running 92 | 93 | cd ~/disel 94 | make clean; make -j 4 95 | 96 | You may see lots of warnings about notations and "nothing to inject"; 97 | these are expected. Success is indicated by the build terminating 98 | without printing "error". 99 | 100 | Extracting and running the example applications is described below. 101 | 102 | ### Code corresponding to the paper 103 | 104 | The following describes how the paper corresponds to the code: 105 | 106 | * The Calculator (Section 2) 107 | - The directory `Examples/Calculator` contains the relevant files. 108 | - The protocol is defined in `CalculatorProtocol.v`, 109 | including the state space, coherence predicate, and four transitions 110 | described in Figure 2. Note that the coherence predicate is stronger than 111 | the one given in the paper: it incorporates Inv_1 from Section 2.3. This is 112 | discussed further below. 113 | - The program that implements blocking receive of server requests from 114 | Section 2.2 is defined in `CalculatorServerLib.v`, 115 | as `blocking_receive_req`. 116 | - The simple server from Section 2.3, as well as the batching and memoizing 117 | servers from Figure 3 are implemented in 118 | `SimpleCalculatorServers.v`. They are all implemented in 119 | terms of the higher-order `server_loop` function. The invariant Inv1 from 120 | Section 2.3 is incorporated into the protocol itself, as part of the coherence 121 | predicate. 122 | - The simple client from Section 2.4 is implemented in 123 | `CalculatorClientLib.v`. The invariant Inv2 is proved as 124 | a separate inductive invariant using the WithInv rule in 125 | `CalculatorInvariant.v`. It is used to prove the clients 126 | satisfy their specifications. 127 | - The delegating server is in `DelegatingCalculatorServer.v`. 128 | It again uses the invariant Inv2. 129 | - A runnable example using extraction to OCaml is given in 130 | `SimpleCalculatorApp.v`. It consists of one client and two 131 | servers, one of which delegates to the other. Instructions for how to run 132 | the example are given below under "Extracting and Running Disel Programs". 133 | * The Logic and its Soundness (Section 3) 134 | - The definitions from Figure 6 in Section 3.1 are given in `Core/State.v` 135 | `Core/Protocols.v`, and `Core/Worlds.v`. 136 | - The primitives of Disel language is defined in `Core/Actions.v` 137 | (defines send/receive wrappers as in Definitions 3.2 and 3.3). 138 | - `Core/Process.v`, `Core/Always.v` and `Core/HoareTriples.v` 139 | define traces, modal predicates (`always` is the formalization 140 | of post-safety from Definition 3.6). Definition 3.7 from the 141 | paper corresponds to `has_spec` from `Core/HoareTriples.v`. The 142 | Theorem 3.8 follows from the soundness of the shallow embedding 143 | into Coq: any well-typed program has a specification ascribed to it. 144 | - Inference rules are represented by lemmas named `*_rule` in 145 | `Core/InferenceRules.v`. For example, `bind_rule` is an 146 | implementation of `Bind` from Figure 8. 147 | * Two-Phase Commit and Querying (Section 4) 148 | - The relevant directory is `Examples/TwoPhaseCommit`. 149 | - The protocol as described in Section 4.1 is implemented in `TwoPhaseProtocol.v`. 150 | - The implementations of the coordinator (described in 4.2) and the participant 151 | are in `TwoPhaseCoordinator.v` and `TwoPhaseParticipant.v`. 152 | - The strengthened invariant from 4.3 is stated in `TwoPhaseInductiveInv.v` and 153 | proved to be preserved by all transitions in `TwoPhaseInductiveProof.v`. 154 | - A runnable example is in `SimpleTPCApp.v`. Instructions for how to run it 155 | are given below under "Extracting and Running Disel Programs". 156 | - The querying protocol from Section 4.4 is implemented in the directory 157 | `Examples/Querying`. 158 | 159 | ### Exploring further 160 | 161 | We encourage you to explore Disel further by extending one of the 162 | examples or trying your own. For example, you could build an application 163 | that uses the calculator to evaluate arithmetic expressions and prove 164 | its correctness. As a more involved example, you could define a new 165 | protocol for leader election in a ring and prove that at most one node 166 | becomes leader. To get started, we recommend following the Calculator example 167 | and modifying it as necessary. 168 | 169 | ### Extracting and Running Disel Programs 170 | 171 | As described in Section 5.1, Disel programs can be extracted to OCaml and run. 172 | You can build the two examples as follows. 173 | 174 | - From `~/disel`, run `make CalculatorMain.d.byte` to build the calculator 175 | application. The extracted code will be placed in `extraction/calculator`. 176 | (Note that all the proofs will be checked as well.) Then run 177 | `~/disel/scripts/calculator.sh` to execute the system in three processes 178 | locally. The system will make several requests to a delegating 179 | calculator to add up some numbers. (See the definition of `client_input` in 180 | `Examples/Calculator/SimpleCalculatorApp.v`.) A log of messages from the 181 | client perspective is printed to the console. Logs of the servers are 182 | available in the files `server1.log` (the delegating server) and 183 | `server3.log` (the server that actually computes). 184 | 185 | Each log contains a debugging info about the state of each node and the 186 | messages it sends and receives. For example, the first message sent by the 187 | client is logged as 188 | 189 | ``` 190 | sending msg in protocol 1 with tag = 0, contents = [1; 2] to 1 191 | ``` 192 | 193 | Tag 0 indicates a request in the Calculator protocol. Contents `1; 2` 194 | indicate the arguments to the function being calculated (in this case, 195 | addition). The message is sent to node 1, which is the delegating server. 196 | 197 | The client then receives a response logged as 198 | 199 | ``` 200 | got msg in protocol 1 with tag = 1, contents = [3; 1; 2] from 1 201 | ``` 202 | 203 | Tag 1 indicates a response. The contents mean that the answer to 204 | `1 + 2` is `3`. 205 | 206 | Several more rounds of messages are exchanged. The final line summarizes 207 | the entire execution. 208 | 209 | ``` 210 | client got result list [([1; 2], 3); ([3; 4], 7); ([5; 6], 11); ([7; 8], 15); ([9; 10], 19)] 211 | ``` 212 | 213 | - Run `make TPCMain.d.byte` from the root folder to build the 214 | Two-Phase Commit application. Then run `./scripts/tpc.sh` to 215 | execute the system in four processes on the local machine. 216 | The system will achieve consensus on several values. (See 217 | the definition of `data_seq` in `Examples/TwoPhaseCommit/SimpleTPCApp.v`.) 218 | Each participant votes on whether to commit the value or abort it. 219 | (See the definitions of `choice_seq1`, `choice_seq2`, and `choice_seq3`.) 220 | A log of messages from the coordinator's point of view is printed to the 221 | console. Participant logs are available in `participant1.log`, 222 | `participant2.log`, and `participant3.log`. 223 | 224 | The protocol executes a sequence of four rounds, since there are four 225 | elements in `data_seq`. Each round consists of two phases. The first messages 226 | sent by the coordinator are prepare messages which request votes about 227 | the first data item. They are logged as 228 | 229 | ``` 230 | sending msg in protocol 0 with tag = 0, contents = [0; 1; 2] to 1 231 | sending msg in protocol 0 with tag = 0, contents = [0; 1; 2] to 2 232 | sending msg in protocol 0 with tag = 0, contents = [0; 1; 2] to 3 233 | ``` 234 | 235 | Tag 0 indicates a prepare message. The contents indicate the index of the 236 | current request (0, since this is the first data item) and the actual data 237 | to commit (in this case, `[1; 2]`, as specified in `data_seq`). A separate 238 | prepare message is sent to each participant. 239 | 240 | The participants respond with votes, which are logged as follows 241 | 242 | ``` 243 | got msg in protocol 0 with tag = 1, contents = [0] from 1 244 | got msg in protocol 0 with tag = 1, contents = [0] from 3 245 | got msg in protocol 0 with tag = 1, contents = [0] from 2 246 | ``` 247 | 248 | Tag 1 indicates a Yes vote. The messages are ordered nondeterministically 249 | based on the operating system's and network's scheduling decisions. 250 | 251 | Since all participants voted yes, the coordinator proceeds to commit the 252 | data by sending Commit messages (tag 3) to all participants. 253 | 254 | ``` 255 | sending msg in protocol 0 with tag = 3, contents = [0] to 1 256 | sending msg in protocol 0 with tag = 3, contents = [0] to 2 257 | sending msg in protocol 0 with tag = 3, contents = [0] to 3 258 | ``` 259 | 260 | Participants acknowledge the commit with AckCommit messages (tag 5) 261 | 262 | ``` 263 | got msg in protocol 0 with tag = 5, contents = [0] from 3 264 | got msg in protocol 0 with tag = 5, contents = [0] from 1 265 | got msg in protocol 0 with tag = 5, contents = [0] from 2 266 | ``` 267 | 268 | This completes the first round. The remaining three rounds execute 269 | similarly, based on the decisions from the choice sequences. When any 270 | participant votes no (tag 2), the coordinator instead aborts the 271 | transaction by sending Abort messages (tag 4). In that case, participants 272 | respond with AckAbort messages (tag 6). Once all four rounds are over, 273 | all nodes exit. 274 | 275 | ### Proof Size Statistics 276 | 277 | Section 5.2 and Table 1 describe the size of our development. Those 278 | were obtained by using the `coqwc` tool on manually dissected files, 279 | according to our vision of what should count as a program, spec, or a proof. 280 | These numbers might slightly differ from reported in the paper due to 281 | the evolution of the project since the submission. 282 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -Q theories DiSeL 2 | 3 | -arg -w -arg -notation-overridden 4 | -arg -w -arg -local-declaration 5 | -arg -w -arg -redundant-canonical-projection 6 | -arg -w -arg -projection-no-head-constant 7 | -arg -w -arg -duplicate-clear 8 | -arg -w -arg -notation-incompatible-format 9 | 10 | theories/Core/State.v 11 | theories/Core/Freshness.v 12 | theories/Core/Protocols.v 13 | theories/Core/EqTypeX.v 14 | theories/Core/DepMaps.v 15 | theories/Core/StatePredicates.v 16 | theories/Core/NewStatePredicates.v 17 | theories/Core/Worlds.v 18 | theories/Core/NetworkSem.v 19 | theories/Core/Rely.v 20 | theories/Core/Actions.v 21 | theories/Core/Injection.v 22 | theories/Core/InductiveInv.v 23 | theories/Core/Process.v 24 | theories/Core/Always.v 25 | theories/Core/HoareTriples.v 26 | theories/Core/InferenceRules.v 27 | theories/Core/While.v 28 | theories/Core/DiSeLExtraction.v 29 | theories/Examples/SeqLib.v 30 | theories/Examples/Greeter/Greeter.v 31 | theories/Examples/Querying/QueryProtocol.v 32 | theories/Examples/Querying/QueryHooked.v 33 | theories/Examples/Calculator/CalculatorProtocol.v 34 | theories/Examples/Calculator/CalculatorInvariant.v 35 | theories/Examples/Calculator/CalculatorClientLib.v 36 | theories/Examples/Calculator/CalculatorServerLib.v 37 | theories/Examples/Calculator/SimpleCalculatorServers.v 38 | theories/Examples/Calculator/DelegatingCalculatorServer.v 39 | theories/Examples/Calculator/SimpleCalculatorApp.v 40 | theories/Examples/TwoPhaseCommit/TwoPhaseProtocol.v 41 | theories/Examples/TwoPhaseCommit/TwoPhaseCoordinator.v 42 | theories/Examples/TwoPhaseCommit/TwoPhaseParticipant.v 43 | theories/Examples/TwoPhaseCommit/SimpleTPCApp.v 44 | theories/Examples/TwoPhaseCommit/TwoPhaseInductiveInv.v 45 | theories/Examples/TwoPhaseCommit/TwoPhaseInductiveProof.v 46 | theories/Examples/TwoPhaseCommit/TwoPhaseClient.v 47 | theories/Examples/Querying/QueryPlusTPC.v 48 | theories/Examples/LockResource/LockProtocol.v 49 | theories/Examples/LockResource/ResourceProtocol.v 50 | extraction/calculator/CalculatorExtraction.v 51 | extraction/TPC/TwoPhaseExtraction.v 52 | -------------------------------------------------------------------------------- /coq-disel-calculator.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "palmskog@gmail.com" 3 | version: "dev" 4 | 5 | homepage: "https://github.com/DistributedComponents/disel" 6 | dev-repo: "git+https://github.com/DistributedComponents/disel.git" 7 | bug-reports: "https://github.com/DistributedComponents/disel/issues" 8 | license: "BSD-2-Clause" 9 | synopsis: "Calculator implemented in Disel, a separation-style logic for compositional verification of distributed systems in Coq" 10 | 11 | build: [make "-j%{jobs}%" "calculator"] 12 | depends: [ 13 | "ocaml" {>= "4.05.0"} 14 | "coq" {>= "8.14"} 15 | "coq-mathcomp-ssreflect" {>= "1.13" & < "2.0"} 16 | "coq-fcsl-pcm" {>= "1.7.0"} 17 | "coq-htt" {>= "1.2.0"} 18 | "ocamlbuild" {build} 19 | ] 20 | 21 | authors: [ 22 | "Ilya Sergey" 23 | "James R. Wilcox" 24 | ] 25 | -------------------------------------------------------------------------------- /coq-disel-examples.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "palmskog@gmail.com" 3 | version: "dev" 4 | 5 | homepage: "https://github.com/DistributedComponents/disel" 6 | dev-repo: "git+https://github.com/DistributedComponents/disel.git" 7 | bug-reports: "https://github.com/DistributedComponents/disel/issues" 8 | license: "BSD-2-Clause" 9 | synopsis: "Example systems for Disel, a separation-style logic for compositional verification of distributed systems in Coq" 10 | 11 | build: ["dune" "build" "-p" name "-j" jobs] 12 | depends: [ 13 | "dune" {>= "3.5"} 14 | "coq" {>= "8.14"} 15 | "coq-mathcomp-ssreflect" {>= "1.13" & < "2.0"} 16 | "coq-fcsl-pcm" {>= "1.7.0"} 17 | "coq-disel" {= version} 18 | ] 19 | 20 | tags: [ 21 | "category:Computer Science/Concurrent Systems and Protocols/Theory of concurrent systems" 22 | "keyword:program verification" 23 | "keyword:separation logic" 24 | "keyword:distributed algorithms" 25 | "logpath:DiSeL.Examples" 26 | ] 27 | authors: [ 28 | "Ilya Sergey" 29 | "James R. Wilcox" 30 | ] 31 | -------------------------------------------------------------------------------- /coq-disel-tpc.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "palmskog@gmail.com" 3 | version: "dev" 4 | 5 | homepage: "https://github.com/DistributedComponents/disel" 6 | dev-repo: "git+https://github.com/DistributedComponents/disel.git" 7 | bug-reports: "https://github.com/DistributedComponents/disel/issues" 8 | license: "BSD-2-Clause" 9 | synopsis: "Two-phase commit implemented in Disel, a separation-style logic for compositional verification of distributed systems in Coq" 10 | 11 | build: [make "-j%{jobs}%" "tpc"] 12 | depends: [ 13 | "ocaml" {>= "4.05.0"} 14 | "coq" {>= "8.14"} 15 | "coq-mathcomp-ssreflect" {>= "1.13" & < "2.0"} 16 | "coq-fcsl-pcm" {>= "1.7.0"} 17 | "coq-htt" {>= "1.2.0"} 18 | "ocamlbuild" {build} 19 | ] 20 | 21 | authors: [ 22 | "Ilya Sergey" 23 | "James R. Wilcox" 24 | ] 25 | -------------------------------------------------------------------------------- /coq-disel.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "palmskog@gmail.com" 3 | version: "dev" 4 | 5 | homepage: "https://github.com/DistributedComponents/disel" 6 | dev-repo: "git+https://github.com/DistributedComponents/disel.git" 7 | bug-reports: "https://github.com/DistributedComponents/disel/issues" 8 | license: "BSD-2-Clause" 9 | 10 | synopsis: "Core framework files for Disel, a separation-style logic for compositional verification of distributed systems in Coq" 11 | description: """ 12 | Disel is a framework for implementation and compositional verification of 13 | distributed systems and their clients in Coq. In Disel, users implement 14 | distributed systems using a domain specific language shallowly embedded in Coq 15 | which provides both high-level programming constructs as well as low-level 16 | communication primitives. Components of composite systems are specified in Disel 17 | as protocols, which capture system-specific logic and disentangle system definitions 18 | from implementation details.""" 19 | 20 | build: ["dune" "build" "-p" name "-j" jobs] 21 | depends: [ 22 | "dune" {>= "3.5"} 23 | "coq" {>= "8.14"} 24 | "coq-mathcomp-ssreflect" {>= "1.13" & < "2.0"} 25 | "coq-fcsl-pcm" {>= "1.7.0"} 26 | "coq-htt" {>= "1.2.0"} 27 | ] 28 | 29 | tags: [ 30 | "category:Computer Science/Concurrent Systems and Protocols/Theory of concurrent systems" 31 | "keyword:program verification" 32 | "keyword:separation logic" 33 | "keyword:distributed algorithms" 34 | "logpath:DiSeL.Core" 35 | ] 36 | authors: [ 37 | "Ilya Sergey" 38 | "James R. Wilcox" 39 | ] 40 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.5) 2 | (using coq 0.6) 3 | (name disel) 4 | -------------------------------------------------------------------------------- /extraction/TPC/TwoPhaseExtraction.v: -------------------------------------------------------------------------------- 1 | From DiSeL Require Import DiSeLExtraction. 2 | From DiSeL Require Import SimpleTPCApp. 3 | 4 | Cd "extraction". 5 | Cd "TPC". 6 | Separate Extraction DepMaps.DepMaps.dmap init_state c_runner p_runner1 p_runner2 p_runner3. 7 | Cd "..". 8 | Cd "..". 9 | -------------------------------------------------------------------------------- /extraction/calculator/CalculatorExtraction.v: -------------------------------------------------------------------------------- 1 | From DiSeL Require Import DiSeLExtraction. 2 | From DiSeL Require Import SimpleCalculatorApp. 3 | 4 | Cd "extraction". 5 | Cd "calculator". 6 | Separate Extraction State.StateGetters.getStatelet init_state c_runner s_runner1 s_runner2. 7 | Cd "..". 8 | Cd "..". 9 | -------------------------------------------------------------------------------- /scripts/calculator.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | calculator=CalculatorMain.native 4 | 5 | if ! [ -x ./$calculator ] 6 | then 7 | echo "$calculator not found!" 8 | echo "Run 'make $calculator' first." 9 | exit 1 10 | fi 11 | 12 | (./$calculator -me 1 -mode server 1 127.0.0.1 9001 2 127.0.0.1 9002 3 127.0.0.1 9003 &) >server1.log 2>&1 13 | 14 | (./$calculator -me 3 -mode server 1 127.0.0.1 9001 2 127.0.0.1 9002 3 127.0.0.1 9003 &) >server3.log 2>&1 15 | 16 | ./$calculator -me 2 -mode client -server 3 1 127.0.0.1 9001 2 127.0.0.1 9002 3 127.0.0.1 9003 | tee client.log 17 | -------------------------------------------------------------------------------- /scripts/tpc.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | tpc=TPCMain.native 4 | 5 | if ! [ -x ./$tpc ] 6 | then 7 | echo "$tpc not found!" 8 | echo "Run 'make $tpc' first." 9 | exit 1 10 | fi 11 | 12 | (./$tpc -me 1 -mode participant 0 127.0.0.1 8000 1 127.0.0.1 8001 2 127.0.0.1 8002 3 127.0.0.1 8003 &) >participant1.log 13 | 14 | (./$tpc -me 2 -mode participant 0 127.0.0.1 8000 1 127.0.0.1 8001 2 127.0.0.1 8002 3 127.0.0.1 8003 &) >participant2.log 15 | 16 | (./$tpc -me 3 -mode participant 0 127.0.0.1 8000 1 127.0.0.1 8001 2 127.0.0.1 8002 3 127.0.0.1 8003 &) >participant3.log 17 | 18 | ./$tpc -me 0 -mode coordinator 0 127.0.0.1 8000 1 127.0.0.1 8001 2 127.0.0.1 8002 3 127.0.0.1 8003 | tee coordinator.log 19 | -------------------------------------------------------------------------------- /shims/CalculatorMain.ml: -------------------------------------------------------------------------------- 1 | open Datatypes 2 | 3 | open Util 4 | open Debug 5 | open Shim 6 | 7 | type mode = Client | Server 8 | 9 | let mode : mode option ref = ref None 10 | let server_name : Datatypes.nat option ref = ref None 11 | let me : Datatypes.nat option ref = ref None 12 | let nodes : (Datatypes.nat * (string * int)) list ref = ref [] 13 | 14 | let usage msg = 15 | print_endline msg; 16 | Printf.printf "%s usage:\n" Sys.argv.(0); 17 | Printf.printf " %s [OPTIONS] \n" (Array.get Sys.argv 0); 18 | print_endline "where:"; 19 | print_endline " CLUSTER is a list of triples of ID IP_ADDR PORT,"; 20 | print_endline " giving all the nodes in the system"; 21 | print_newline (); 22 | print_endline "Options are as follows:"; 23 | print_endline " -me the identity of this node (required)"; 24 | print_endline " -mode whether this node is the server or client (required)"; 25 | print_endline " -server the identity of the server (required if mode=client)"; 26 | exit 1 27 | 28 | 29 | let rec parse_args = function 30 | | [] -> () 31 | | "-mode" :: "server" :: args -> 32 | begin 33 | mode := Some Server; 34 | parse_args args 35 | end 36 | | "-mode" :: "client" :: args -> 37 | begin 38 | mode := Some Client; 39 | parse_args args 40 | end 41 | | "-me" :: name :: args -> 42 | begin 43 | me := Some (nat_of_string name); 44 | parse_args args 45 | end 46 | | "-server" :: name :: args -> 47 | begin 48 | server_name := Some (nat_of_string name); 49 | parse_args args 50 | end 51 | | name :: ip :: port :: args -> begin 52 | let n = nat_of_string name in 53 | nodes := (n, (ip, int_of_string port)) :: !nodes; 54 | parse_args args 55 | end 56 | | arg :: args -> 57 | usage ("Unknown argument " ^ arg) 58 | 59 | let main () = 60 | parse_args (List.tl (Array.to_list Sys.argv)); 61 | match !mode, !me with 62 | | Some mode, Some me -> begin 63 | Shim.setup { nodes = !nodes; me = me; st = SimpleCalculatorApp.init_state }; 64 | match mode with 65 | | Server -> 66 | begin match int_of_nat me with 67 | | 1 -> SimpleCalculatorApp.s_runner1 () 68 | | 3 -> SimpleCalculatorApp.s_runner2 () 69 | | n -> usage ("unknown server name " ^ string_of_int n) 70 | end 71 | | Client -> let l = SimpleCalculatorApp.c_runner () in 72 | Printf.printf "client got result list %a\n%!" (print_list (print_pair (print_list print_nat) print_nat)) l 73 | end 74 | | _, _ -> usage "-mode and -me must be given" 75 | 76 | let _ = main () 77 | -------------------------------------------------------------------------------- /shims/Debug.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | let print_list (a_printer : out_channel -> 'a -> unit) (f : out_channel) (l : 'a list) = 4 | let rec go f = function 5 | | [] -> () 6 | | [a] -> a_printer f a 7 | | a :: l -> Printf.fprintf f "%a; " a_printer a; go f l 8 | in Printf.fprintf f "[%a]" go l 9 | 10 | let print_pair (a_printer : out_channel -> 'a -> unit) (b_printer : out_channel -> 'b -> unit) 11 | (f : out_channel) (x : 'a * 'b) = 12 | let (a, b) = x in 13 | Printf.fprintf f "(%a, %a)" a_printer a b_printer b 14 | 15 | let print_nat f n = Printf.fprintf f "%d" (int_of_nat n) 16 | 17 | let sprint_nat () n = Printf.sprintf "%d" (int_of_nat n) 18 | 19 | let print_finmap print_key print_value f fm = 20 | let rec go f = function 21 | | [] -> () 22 | | [(k, v)] -> Printf.fprintf f "%a |-> %a" print_key k (print_value k) v 23 | | (k, v) :: l -> Printf.fprintf f "%a |-> %a, " print_key k (print_value k) v; go f l 24 | in Printf.fprintf f "[%a]" go fm 25 | 26 | let print_um print_key print_value f = function 27 | | Unionmap.UM.Undef -> Printf.fprintf f "Undef" 28 | | Unionmap.UM.Def fm -> print_finmap print_key print_value f fm 29 | 30 | let print_heap print_key print_value f = function 31 | | Heap.Heap.Undef -> Printf.fprintf f "Undef" 32 | | Heap.Heap.Def fm -> print_finmap print_key print_value f fm 33 | 34 | let print_ordered_sort_which_is_nat f o = 35 | print_nat f (Obj.magic o) 36 | 37 | (* 38 | let print_cstate f = function 39 | | TwoPhaseProtocol.TPCProtocol.States.CInit -> Printf.fprintf f "CInit" 40 | | TwoPhaseProtocol.TPCProtocol.States.CSentPrep _ -> Printf.fprintf f "CSentPrep" 41 | | TwoPhaseProtocol.TPCProtocol.States.CWaitPrepResponse _ -> Printf.fprintf f "CWaitPrepResponse" 42 | | TwoPhaseProtocol.TPCProtocol.States.CSentCommit _ -> Printf.fprintf f "CSentCommit" 43 | | TwoPhaseProtocol.TPCProtocol.States.CSentAbort _ -> Printf.fprintf f "CSentAbort" 44 | | TwoPhaseProtocol.TPCProtocol.States.CWaitAckCommit _ -> Printf.fprintf f "CWaitAckCommit" 45 | | TwoPhaseProtocol.TPCProtocol.States.CWaitAckAbort _ -> Printf.fprintf f "CWaitAckAbort" 46 | 47 | let print_pstate f = function 48 | | TwoPhaseProtocol.TPCProtocol.States.PInit -> Printf.fprintf f "PInit" 49 | | TwoPhaseProtocol.TPCProtocol.States.PGotRequest _ -> Printf.fprintf f "PGotRequest" 50 | | TwoPhaseProtocol.TPCProtocol.States.PRespondedYes _ -> Printf.fprintf f "PRespondedYes" 51 | | TwoPhaseProtocol.TPCProtocol.States.PRespondedNo _ -> Printf.fprintf f "PRespondedNo" 52 | | TwoPhaseProtocol.TPCProtocol.States.PCommitted _ -> Printf.fprintf f "PCommitted" 53 | | TwoPhaseProtocol.TPCProtocol.States.PAborted _ -> Printf.fprintf f "PAborted" 54 | 55 | let super_hacky_print_TPC_heap this k f (v : (Heap.__, Heap.__) Idynamic.idynamic) = 56 | let v = Idynamic.idyn_val v in 57 | match int_of_nat (Obj.magic k) with 58 | | 1 -> let (round, st) = Obj.magic v in 59 | let print_state = match int_of_nat this with 60 | | 0 -> (fun f x -> print_cstate f (Obj.magic x)) 61 | | _ -> (fun f x -> print_pstate f (Obj.magic x)) 62 | in 63 | Printf.fprintf f "{round = %a, state = %a}" print_nat round print_state st 64 | | 2 -> print_list (fun f (b, data) -> 65 | Printf.fprintf f "(%s, %a)" (if b then "true" else "false") 66 | (print_list print_nat) data) 67 | f (Obj.magic v) 68 | | n -> Printf.fprintf f "" n 69 | *) 70 | 71 | let super_hacky_print_calc_heap this k f v = 72 | Printf.fprintf f "%s" "" 73 | 74 | let super_hacky_print_system_heap = super_hacky_print_calc_heap 75 | 76 | let print_dstatelet l f x = 77 | Printf.fprintf f "{dstate = %a; dsoup = <>}" 78 | (print_um print_ordered_sort_which_is_nat 79 | (fun node -> print_heap print_ordered_sort_which_is_nat 80 | (super_hacky_print_system_heap (Obj.magic node)))) 81 | (Obj.magic x.State.dstate) 82 | 83 | let print_state f x = 84 | Printf.fprintf f "%a" (print_um print_ordered_sort_which_is_nat print_dstatelet) x 85 | 86 | let print_protocol f (x : Protocols.Protocols.protocol) = 87 | let l : Ordtype.Ordered.sort = x.Protocols.Protocols.plab in 88 | Printf.fprintf f "" print_ordered_sort_which_is_nat l 89 | 90 | let print_world f x = 91 | Printf.fprintf f "%a" (print_um print_ordered_sort_which_is_nat (fun _ -> print_protocol)) x 92 | -------------------------------------------------------------------------------- /shims/DiSeL.ml: -------------------------------------------------------------------------------- 1 | open Shim 2 | open Debug 3 | 4 | type 'a prog = 'a 5 | 6 | let mkProg = Obj.magic () 7 | 8 | type 'a action = 'a 9 | 10 | let mkAction = Obj.magic () 11 | 12 | let ret_prog this w x = x 13 | 14 | let act_prog this w act = 15 | act 16 | 17 | let bnd_prog this w p1 p2 = 18 | p2 p1 19 | 20 | let sup_prog _ _ _ = 21 | failwith "sup_prog" 22 | 23 | let inject_prog _ _ _ _ _ x = 24 | x 25 | 26 | let with_inv_prog _ _ _ x = 27 | x 28 | 29 | 30 | (* 31 | [Eta expansion for ffix]: 32 | 33 | The recursive call must be eta expanded in order to work in a call-by-value semantics. 34 | Otherwise, it would just spin out computing the argument to a value without ever 35 | calling `f`. 36 | *) 37 | let ffix _ _ _ (f : 'a -> 'b) = 38 | let rec go f = f (fun x -> go f x) 39 | in go f 40 | 41 | let rec coq_while this w cond body init = 42 | if cond init 43 | then coq_while this w cond body (body init) 44 | else init 45 | 46 | let find_option f l = 47 | try 48 | Some (List.find f l) 49 | with Not_found -> None 50 | 51 | let max_errors = 3 52 | let errors = ref 0 53 | 54 | let rec get_msg = function 55 | | [] -> None 56 | | fd :: fds -> 57 | try 58 | Some (recv_msg fd) 59 | with e -> 60 | (* Printf.printf "Got exception: %s\n" (Printexc.to_string e); 61 | Printexc.print_backtrace stdout; *) 62 | errors := !errors + 1; 63 | if !errors < max_errors 64 | then get_msg fds 65 | else begin 66 | (* Printf.printf "Too many errors; aborting.\n%!"; *) 67 | raise e 68 | end 69 | 70 | let tryrecv_action_wrapper (ctx,hk) this p = 71 | let () = check_for_new_connections () in 72 | let fds = get_all_read_fds () in 73 | let (ready_fds, _, _) = Unix.select fds [] [] 0.0 in 74 | begin 75 | match get_msg ready_fds with 76 | | None -> (* nothing available *) None 77 | | Some (l, src, tag, msg) -> 78 | begin 79 | match Unionmap.UMDef.find Ordtype.nat_ordType (Obj.magic l) ctx with 80 | | None -> 81 | begin 82 | Printf.printf "World is %a\n%!" print_world (Unionmap.UMDef.from (Obj.magic ()) ctx); 83 | failwith 84 | (Printf.sprintf "Could not find protocol %a in the world!" sprint_nat l) 85 | end 86 | | Some protocol -> 87 | begin 88 | match find_option (fun rt -> rt.Protocols.Transitions.t_rcv = tag) 89 | protocol.Protocols.Protocols.rcv_trans with 90 | | None -> 91 | failwith 92 | (Printf.sprintf 93 | "Could not find a receive transition with tag %a in the protocol!" 94 | sprint_nat tag) 95 | | Some rt -> 96 | let dstatelet = get_protocol_state (Obj.magic l) in 97 | let tm = { State.tag = tag; tms_cont = msg } in 98 | if rt.Protocols.Transitions.msg_wf dstatelet (Obj.magic ()) this src tm 99 | then 100 | let st' = rt.Protocols.Transitions.receive_step this src msg dstatelet (Obj.magic ()) (Obj.magic ()) in 101 | update_my_state (Obj.magic l) this st'; 102 | Some ((src, tag), msg) (* respect Coq tuple associativity *) 103 | else 104 | failwith (Printf.sprintf "Received a msg that did not pass the wf test!") 105 | end 106 | end 107 | end 108 | 109 | 110 | let send_action_wrapper (ctx,hk) p this (l : Ordtype.Ordered.sort) t m dst = 111 | Printf.printf "World is %a\n%!" print_world (Unionmap.UMDef.from (Obj.magic ()) ctx); 112 | send_msg (Obj.magic l) dst (t.Protocols.Transitions.t_snd) m; 113 | let dstatelet = get_protocol_state l in 114 | let ost' = t.Protocols.Transitions.send_step this dst dstatelet m (Obj.magic ()) in 115 | begin 116 | match ost' with 117 | | None -> failwith "send_action_wrapper: send_step failed!" 118 | | Some st' -> update_my_state l this st' 119 | end; 120 | m 121 | 122 | let skip_action_wrapper (ctx, hk) this l p f = 123 | f (get_current_state ()) (Obj.magic ()) 124 | -------------------------------------------------------------------------------- /shims/Shim.ml: -------------------------------------------------------------------------------- 1 | open Unix 2 | open Util 3 | open Debug 4 | 5 | let read_fds : (Unix.file_descr, Datatypes.nat) Hashtbl.t = Hashtbl.create 17 6 | let write_fds : (Datatypes.nat, Unix.file_descr) Hashtbl.t = Hashtbl.create 17 7 | 8 | type cfg = { nodes : (Datatypes.nat * (string * int)) list 9 | ; me : Datatypes.nat 10 | ; mutable st : State.StateGetters.state 11 | } 12 | 13 | let the_cfg : cfg option ref = ref None 14 | let listen_fd : file_descr = socket PF_INET SOCK_STREAM 0 15 | 16 | let get_addr_port cfg name = 17 | try List.assoc name cfg.nodes 18 | with Not_found -> failwith (Printf.sprintf "Unknown name: %d" (int_of_nat name)) 19 | 20 | let get_name_for_read_fd fd = 21 | Hashtbl.find read_fds fd 22 | 23 | let send_chunk (fd : file_descr) (buf : bytes) : unit = 24 | let len = Bytes.length buf in 25 | (* Printf.printf "sending chunk of length %d" len; print_newline (); *) 26 | let n = Unix.send fd (Util.raw_bytes_of_int len) 0 4 [] in 27 | if n < 4 then 28 | failwith "send_chunk: message header failed to send all at once."; 29 | let n = Unix.send fd buf 0 len [] in 30 | if n < len then 31 | failwith (Printf.sprintf "send_chunk: message of length %d failed to send all at once." len) 32 | 33 | let recv_or_close fd buf offs len flags = 34 | let n = recv fd buf offs len flags in 35 | if n = 0 then 36 | failwith "recv_or_close: other side closed connection."; 37 | n 38 | 39 | 40 | let receive_chunk (fd : file_descr) : bytes = 41 | let buf4 = Bytes.make 4 '\x00' in 42 | let n = recv_or_close fd buf4 0 4 [] in 43 | if n < 4 then 44 | failwith "receive_chunk: message header did not arrive all at once."; 45 | let len = Util.int_of_raw_bytes buf4 in 46 | let buf = Bytes.make len '\x00' in 47 | let n = recv_or_close fd buf 0 len [] in 48 | (* Printf.printf "received chunk of length %d" len; print_newline (); *) 49 | if n < len then 50 | failwith 51 | (Printf.sprintf "receive_chunk: message of length %d did not arrive all at once." len); 52 | buf 53 | 54 | let get_cfg err_msg = 55 | match !the_cfg with 56 | | None -> failwith (err_msg ^ " called before the_cfg was set") 57 | | Some cfg -> cfg 58 | 59 | let get_write_fd name = 60 | try Hashtbl.find write_fds name 61 | with Not_found -> 62 | let write_fd = socket PF_INET SOCK_STREAM 0 in 63 | let cfg = get_cfg "get_write_fd" in 64 | let (ip, port) = get_addr_port cfg name in 65 | let entry = gethostbyname ip in 66 | let node_addr = ADDR_INET (Array.get entry.h_addr_list 0, port) in 67 | let chunk = Bytes.of_string (string_of_nat cfg.me) in 68 | connect write_fd node_addr; 69 | send_chunk write_fd chunk; 70 | Hashtbl.add write_fds name write_fd; 71 | write_fd 72 | 73 | let setup cfg = 74 | Printexc.record_backtrace true; 75 | the_cfg := Some cfg; 76 | Printf.printf "initial state is: %a\n%!" print_state (Obj.magic cfg.st); 77 | let (_, port) = get_addr_port cfg cfg.me in 78 | (* Printf.printf "listening on port %d" port; print_newline (); *) 79 | setsockopt listen_fd SO_REUSEADDR true; 80 | bind listen_fd (ADDR_INET (inet_addr_any, port)); 81 | listen listen_fd 8 82 | 83 | 84 | let new_conn () = 85 | print_endline "new connection!"; 86 | let (node_fd, node_addr) = accept listen_fd in 87 | let chunk = receive_chunk node_fd in 88 | let node = Bytes.to_string chunk in 89 | let name = nat_of_string node in 90 | Hashtbl.add read_fds node_fd name; 91 | (* ignore (get_write_fd name); *) 92 | Printf.printf "done processing new connection from node %s" node; 93 | print_newline () 94 | 95 | let check_for_new_connections () = 96 | let fds = [listen_fd] in 97 | let (ready_fds, _, _) = select fds [] [] 0.0 in 98 | List.iter (fun _ -> new_conn ()) ready_fds 99 | 100 | let get_all_read_fds () = 101 | Hashtbl.fold (fun fd _ acc -> fd :: acc) read_fds [] 102 | 103 | let serialize_msg l tag msg = 104 | Marshal.to_string (int_of_nat l, int_of_nat tag, List.map int_of_nat msg) [] 105 | 106 | let deserialize_msg s = 107 | let (l, tag, msg) = Marshal.from_string s 0 in 108 | (nat_of_int l, nat_of_int tag, List.map nat_of_int msg) 109 | 110 | let recv_msg fd = 111 | let chunk = receive_chunk fd in 112 | let (l, tag, msg) = deserialize_msg (Bytes.to_string chunk) in 113 | let src = get_name_for_read_fd fd in 114 | Printf.printf "got msg in protocol %a with tag = %a, contents = %a from %s" print_nat l print_nat tag (print_list print_nat) msg (string_of_nat src); 115 | print_newline (); 116 | (l, src, tag, msg) 117 | 118 | let send_msg l dst tag msg = 119 | Printf.printf "sending msg in protocol %a with tag = %a, contents = %a to %s" print_nat l print_nat tag (print_list print_nat) msg (string_of_nat dst); 120 | print_newline (); 121 | let fd = get_write_fd dst in 122 | let s = serialize_msg l tag msg in 123 | let chunk = Bytes.of_string s in 124 | send_chunk fd chunk 125 | 126 | let get_current_state () = 127 | let cfg = get_cfg "get_current_sate" in 128 | (*Printf.printf "current state is: %a\n%!" print_state (Obj.magic cfg.st); *) 129 | cfg.st 130 | 131 | let set_current_state x = 132 | let cfg = get_cfg "set_current_state" in 133 | (* Printf.printf "setting state to: %a\n%!" print_state (Obj.magic cfg.st); *) 134 | cfg.st <- x 135 | 136 | let get_protocol_state l = 137 | let st = get_current_state () in 138 | State.StateGetters.getStatelet st l 139 | 140 | let set_protocol_state l x' = 141 | let st = get_current_state () in 142 | set_current_state (Unionmap.UMDef.upd Ordtype.nat_ordType l x' st) 143 | 144 | let update_my_state l this x' = 145 | (* Printf.printf "setting state to %a" (print_heap print_ordered_sort_which_is_nat (super_hacky_print_system_heap (Obj.magic this))) x'; 146 | print_newline(); *) 147 | let dstatelet = get_protocol_state l in 148 | let dstatelet' = 149 | { State.dstate = Unionmap.UMDef.upd Ordtype.nat_ordType (Obj.magic this) x' 150 | dstatelet.State.dstate; 151 | State.dsoup = dstatelet.State.dsoup } in 152 | set_protocol_state l dstatelet' 153 | 154 | -------------------------------------------------------------------------------- /shims/TPCMain.ml: -------------------------------------------------------------------------------- 1 | open Datatypes 2 | 3 | open Util 4 | open Shim 5 | 6 | type mode = Coordinator | Participant 7 | 8 | let mode : mode option ref = ref None 9 | let server_name : Datatypes.nat option ref = ref None 10 | let me : Datatypes.nat option ref = ref None 11 | let nodes : (Datatypes.nat * (string * int)) list ref = ref [] 12 | 13 | let usage msg = 14 | print_endline msg; 15 | Printf.printf "%s usage:\n" Sys.argv.(0); 16 | Printf.printf " %s [OPTIONS] \n" (Array.get Sys.argv 0); 17 | print_endline "where:"; 18 | print_endline " CLUSTER is a list of triples of ID IP_ADDR PORT,"; 19 | print_endline " giving all the nodes in the system"; 20 | print_newline (); 21 | print_endline "Options are as follows:"; 22 | print_endline " -me the identity of this node (required)"; 23 | print_endline " -mode whether this node is the coordinator or participant (required)"; 24 | print_endline " -coordinator the identity of the coordinator (required if mode=client)"; 25 | exit 1 26 | 27 | 28 | let rec parse_args = function 29 | | [] -> () 30 | | "-mode" :: "participant" :: args -> 31 | begin 32 | mode := Some Participant; 33 | parse_args args 34 | end 35 | | "-mode" :: "coordinator" :: args -> 36 | begin 37 | mode := Some Coordinator; 38 | parse_args args 39 | end 40 | | "-me" :: name :: args -> 41 | begin 42 | me := Some (nat_of_string name); 43 | parse_args args 44 | end 45 | | "-coordinator" :: name :: args -> 46 | begin 47 | server_name := Some (nat_of_string name); 48 | parse_args args 49 | end 50 | | name :: ip :: port :: args -> begin 51 | nodes := (nat_of_string name, (ip, int_of_string port)) :: !nodes; 52 | parse_args args 53 | end 54 | | arg :: args -> 55 | usage ("Unknown argument " ^ arg) 56 | 57 | let main () = 58 | parse_args (List.tl (Array.to_list Sys.argv)); 59 | match !mode, !me with 60 | | Some mode, Some me -> begin 61 | Shim.setup { nodes = !nodes; me = me; st = SimpleTPCApp.init_state }; 62 | match mode with 63 | | Participant -> 64 | begin match int_of_nat me with 65 | | 1 -> SimpleTPCApp.p_runner1 () 66 | | 2 -> SimpleTPCApp.p_runner2 () 67 | | 3 -> SimpleTPCApp.p_runner3 () 68 | | n -> usage ("unknown participant name " ^ string_of_int n) 69 | end 70 | | Coordinator -> 71 | try 72 | SimpleTPCApp.c_runner () 73 | with _ -> print_endline "A participant closed its connection. Coordinator exiting." 74 | end 75 | | _, _ -> usage "-mode and -me must be given" 76 | 77 | let _ = main () 78 | -------------------------------------------------------------------------------- /shims/Util.ml: -------------------------------------------------------------------------------- 1 | let rec nat_of_int n = 2 | if n <= 0 then Datatypes.O 3 | else Datatypes.S (nat_of_int (n - 1)) 4 | 5 | let rec int_of_nat = function 6 | | Datatypes.O -> 0 7 | | Datatypes.S n -> int_of_nat n + 1 8 | 9 | let nat_of_string s = nat_of_int (int_of_string s) 10 | let string_of_nat n = string_of_int (int_of_nat n) 11 | 12 | let raw_bytes_of_int (x : int) : bytes = 13 | let buf = Bytes.make 4 '\x00' in 14 | Bytes.set buf 0 (char_of_int (x land 0xff)); 15 | Bytes.set buf 1 (char_of_int ((x lsr 8) land 0xff)); 16 | Bytes.set buf 2 (char_of_int ((x lsr 16) land 0xff)); 17 | Bytes.set buf 3 (char_of_int ((x lsr 24) land 0xff)); 18 | buf 19 | 20 | let int_of_raw_bytes (buf : bytes) : int = 21 | (int_of_char (Bytes.get buf 0)) lor 22 | ((int_of_char (Bytes.get buf 1)) lsl 8) lor 23 | ((int_of_char (Bytes.get buf 2)) lsl 16) lor 24 | ((int_of_char (Bytes.get buf 3)) lsl 24) 25 | -------------------------------------------------------------------------------- /theories/Core/Actions.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import axioms pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX Protocols Worlds NetworkSem. 5 | From Coq Require Classical_Prop. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | (* "Atomic" send/receive actions, coherent with the network semantics *) 12 | 13 | Module Actions. 14 | 15 | Section Actions. 16 | 17 | Variable W : world. 18 | Notation getS s l := (getStatelet s l). 19 | 20 | (* 21 | 22 | Action is defined with respect to the world (i.e., a number of 23 | protocols) and label. 24 | 25 | It changes the state as a whole, but, in fact, affects only a specific 26 | statelet in it, associated with a specific label. 27 | 28 | 29 | *) 30 | 31 | 32 | Structure action (V : Type) (this : nid) 33 | := Action 34 | { 35 | (* a_lab : Label; *) 36 | (* a_lab_dom : a_lab \in ddom W; *) 37 | 38 | a_safe : state -> Prop; 39 | 40 | a_safe_coh : forall s, a_safe s -> s \In Coh W; 41 | 42 | 43 | (* safe_coh : forall s, a_safe s -> coh (getP a_lab) (getS s a_lab); *) 44 | 45 | a_step : forall s1, (a_safe s1) -> state -> V -> Prop; 46 | 47 | step_total : forall s (pf : a_safe s), exists s' r, a_step pf s' r; 48 | 49 | (* step_coh : forall s1 s2 r, Coh W s1 -> *) 50 | (* a_safe s1 -> a_step s1 s2 r -> coh (getP a_lab) (getS s2 a_lab); *) 51 | 52 | (* step_frame : forall s1 s2 r z, *) 53 | (* a_lab != z -> Coh W s1 -> *) 54 | (* a_safe s1 -> a_step s1 s2 r -> getS s1 z = getS s2 z; *) 55 | 56 | (* Action step semantics respects the overall network semantics *) 57 | step_sem : forall s1 (pf : a_safe s1) s2 r, 58 | a_step pf s2 r -> network_step W this s1 s2 59 | 60 | }. 61 | 62 | 63 | (* Framing follows from the network semantics *) 64 | Lemma step_other this V (a : action V this) l s1 s2 r n (pf : a_safe a s1): 65 | this != n -> a_step pf s2 r -> 66 | getLocal n (getS s1 l) = getLocal n (getS s2 l). 67 | Proof. 68 | move=>N S2; move: (step_sem S2)=>H. 69 | by rewrite eq_sym in N; rewrite /getLocal !(step_is_local l H N). 70 | Qed. 71 | 72 | End Actions. 73 | 74 | Section SkipActionWrapper. 75 | 76 | Variable W : world. 77 | Notation getP l := (getProtocol W l). 78 | Notation getS s l := (getStatelet s l). 79 | Variable this : nid. 80 | Variable l : Label. 81 | Variable p : protocol. 82 | Variable pf : getP l = p. 83 | 84 | Definition skip_safe s := Coh W s. 85 | 86 | Variable V : Type. 87 | 88 | (* Skip-like actions allow for reading from the state *) 89 | Variable f : forall s, coh p (getS s l) -> V. 90 | 91 | Lemma safe_local s : skip_safe s -> coh p (getS s l). 92 | Proof. by rewrite -pf=>/(coh_s l). Qed. 93 | 94 | Definition skip_step s1 (pf : skip_safe s1) (s2 : state) r := 95 | [/\ s1 \In Coh W, s1 = s2 & r = f (safe_local pf)]. 96 | 97 | (* Lemma skip_step_safe s1 s2 r: skip_step s1 s2 r -> skip_safe s1. *) 98 | (* Proof. by case. Qed. *) 99 | 100 | Lemma skip_step_total s (S : skip_safe s) : exists s' r, skip_step S s' r. 101 | Proof. by exists s, (f (safe_local S)). Qed. 102 | 103 | Lemma skip_safe_coh s1 : skip_safe s1 -> Coh W s1. 104 | Proof. by []. Qed. 105 | 106 | Lemma skip_step_sem s1 (S : skip_safe s1) s2 r: 107 | skip_step S s2 r -> network_step W this s1 s2. 108 | Proof. by move=>H; apply: Idle; case: H. Qed. 109 | 110 | Definition skip_action_wrapper := 111 | Action skip_safe_coh skip_step_total skip_step_sem. 112 | 113 | End SkipActionWrapper. 114 | 115 | 116 | Section TryReceiveActionWrapper. 117 | 118 | Variable W : world. 119 | Notation getP l := (getProtocol W l). 120 | Notation getS s l := (getStatelet s l). 121 | Variable this : nid. 122 | 123 | (* 124 | 125 | Filter for specific 126 | - protocol labels 127 | - message tags 128 | - message bodies 129 | *) 130 | Variable filter : Label -> nid -> nat -> pred (seq nat). 131 | 132 | (* Necessary validity lemmas *) 133 | Variable f_valid_label : forall l n t m , 134 | filter l n t m -> l \in dom (getc W). 135 | 136 | (* Variable f_valid_tags : forall l t m , *) 137 | (* filter l t m -> t \in rcv_tags (getP l). *) 138 | 139 | Definition tryrecv_act_safe (s : state) := s \In Coh W. 140 | 141 | Lemma tryrecv_act_safe_coh s : tryrecv_act_safe s -> Coh W s. 142 | Proof. by []. Qed. 143 | 144 | (* Can we make it decidable rather than classic? *) 145 | Definition tryrecv_act_step s1 s2 (r : option (nid * nat * seq nat)) := 146 | exists (pf : s1 \In Coh W), 147 | (* No message to receive -- all relevant messages are marked *) 148 | ([/\ (forall l m tms from rt b, 149 | this \in nodes (getP l) (getS s1 l) -> 150 | Some (Msg tms from this b) = find m (dsoup (getS s1 l)) -> 151 | rt \In (rcv_trans (getP l)) -> 152 | tag tms = (t_rcv rt) -> 153 | (* This is required for safety *) 154 | msg_wf rt (coh_s l pf) this from tms -> 155 | (* The filter applies *) 156 | filter l from (t_rcv rt) (tms_cont tms) -> 157 | ~~b), 158 | r = None & s2 = s1] \/ 159 | (* There is a message to receive and the transition can be executed *) 160 | exists l m tms from rt (pf' : this \in nodes (getP l) (getS s1 l)), 161 | let: d := getS s1 l in 162 | [/\ [/\ Some (Msg tms from this true) = find m (dsoup (getS s1 l)), 163 | rt \In (rcv_trans (getP l)), 164 | tag tms = (t_rcv rt), 165 | (* This is required for safety *) 166 | msg_wf rt (coh_s l pf) this from tms & 167 | (* The filter applies *) 168 | filter l from (t_rcv rt) (tms_cont tms)], 169 | let loc' := receive_step rt from tms (coh_s l pf) pf' in 170 | let: f' := upd this loc' (dstate d) in 171 | let: s' := consume_msg (dsoup d) m in 172 | s2 = upd l (DStatelet f' s') s1 & 173 | r = Some (from, tag tms, tms_cont tms)]). 174 | 175 | Import Classical_Prop. 176 | 177 | Lemma tryrecv_act_step_total s: 178 | tryrecv_act_safe s -> exists s' r , tryrecv_act_step s s' r. 179 | Proof. 180 | move=>C; rewrite /tryrecv_act_step. 181 | case: (classic (exists l m tms from rt (pf' : this \in nodes (getP l) (getS s l)), 182 | let: d := getS s l in 183 | [/\ Some (Msg tms from this true) = find m (dsoup (getS s l)), 184 | rt \In (rcv_trans (getP l)), 185 | tag tms = (t_rcv rt), 186 | msg_wf rt (coh_s l C) this from tms & 187 | filter l from (t_rcv rt) (tms_cont tms)])); last first. 188 | - move=>H; exists s, None, C; left; split=>//l m tms from rt b T E1 E2 E3 E M. 189 | apply/negP=>Z; rewrite Z in E1; clear Z b; apply: H. 190 | by exists l, m, tms, from, rt. 191 | case=>[l][m][tms][from][rt][T][E1 E2 E3 E M]. 192 | exists (let: d := getS s l in 193 | let loc' := receive_step rt from tms (coh_s l C) T in 194 | let: f' := upd this loc' (dstate d) in 195 | let: s' := consume_msg (dsoup d) m in 196 | upd l (DStatelet f' s') s), (Some (from, tag tms, tms_cont tms)). 197 | by exists C; right; exists l, m, tms, from, rt, T. 198 | Qed. 199 | 200 | Lemma tryrecv_act_step_safe s1 s2 r: 201 | tryrecv_act_step s1 s2 r -> tryrecv_act_safe s1. 202 | Proof. by case. Qed. 203 | 204 | Lemma tryrecv_act_step_sem s1 (S : tryrecv_act_safe s1) s2 r: 205 | tryrecv_act_step s1 s2 r -> network_step W this s1 s2. 206 | Proof. 207 | case=>C; rewrite /tryrecv_act_step; case; first by case=>_ _ ->; apply: Idle. 208 | case=>[l][m][tms][from][rt][Y][[E R E1 M]]F/=Z _. 209 | have X1: l \in dom s1 by move: (f_valid_label F); rewrite (cohD C). 210 | by apply: (ReceiveMsg R X1 E1 (i := m) (from := from)). 211 | Qed. 212 | 213 | Definition tryrecv_action_wrapper := 214 | Action tryrecv_act_safe_coh tryrecv_act_step_total tryrecv_act_step_sem. 215 | 216 | End TryReceiveActionWrapper. 217 | 218 | (* A wrapper for the send-action *) 219 | Section SendActionWrapper. 220 | 221 | Variable W : world. 222 | Variable p : protocol. 223 | Notation getP l := (getProtocol W l). 224 | Notation getS s l := (getStatelet s l). 225 | Variable this : nid. 226 | 227 | Variable l : Label. 228 | 229 | Variable pf : (getProtocol W l) = p. 230 | 231 | (* A dedicated send-transition *) 232 | Variable st: send_trans (coh p). 233 | (* The transition is present *) 234 | Variable pf' : st \In (snd_trans p). 235 | 236 | (* The message and the recipient *) 237 | Variable msg : seq nat. 238 | Variable to : nid. 239 | 240 | (* This check is implicit in the action semantics *) 241 | Definition can_send (s : state) := (l \in dom s) && (this \in nodes p (getS s l)). 242 | 243 | 244 | (* Take only the hooks that affect the transition with a tag st of *) 245 | (* protocol l *) 246 | Definition filter_hooks (h : hooks) := 247 | um_filterk (fun e => e.2 == (l, t_snd st)) h. 248 | 249 | Definition send_act_safe s := 250 | [/\ Coh W s, send_safe st this to (getS s l) msg, can_send s & 251 | (* All hooks from a "reduced footprint" are applicable *) 252 | all_hooks_fire (filter_hooks (geth W)) l (t_snd st) s this msg to]. 253 | 254 | Lemma send_act_safe_coh s : send_act_safe s -> Coh W s. 255 | Proof. by case. Qed. 256 | 257 | Lemma safe_safe s : send_act_safe s -> send_safe st this to (getS s l) msg. 258 | Proof. by case. Qed. 259 | 260 | Definition send_act_step s1 (S: send_act_safe s1) s2 r := 261 | r = msg /\ 262 | exists b, 263 | Some b = send_step (safe_safe S) /\ 264 | let: d := getS s1 l in 265 | let: f' := upd this b (dstate d) in 266 | let: s' := (post_msg (dsoup d) (Msg (TMsg (t_snd st) msg) 267 | this to true)).1 in 268 | s2 = upd l (DStatelet f' s') s1. 269 | 270 | Lemma send_act_step_total s (S: send_act_safe s): exists s' r , send_act_step S s' r. 271 | Proof. 272 | rewrite /send_act_step/send_act_safe. 273 | case: S=>C S J K. 274 | move/(s_safe_def): (S)=>[b][S']E. 275 | set s2 := let: d := getS s l in 276 | let: f' := upd this b (dstate d) in 277 | let: s' := (post_msg (dsoup d) (Msg (TMsg (t_snd st) msg) 278 | this to true)).1 in 279 | upd l (DStatelet f' s') s. 280 | exists s2, msg; split=>//; exists b; split=>//. 281 | move: (safe_safe (And4 C S J K))=> S''. 282 | by rewrite -E (pf_irr S'' S') . 283 | Qed. 284 | 285 | Lemma send_act_step_sem s1 (S : send_act_safe s1) s2 r: 286 | send_act_step S s2 r -> network_step W this s1 s2. 287 | Proof. 288 | case=>_[b][E Z]; case: (S)=>C S' /andP[D1] D2 K; subst s2=>/=. 289 | rewrite (pf_irr (safe_safe S) S') in E; clear S. 290 | rewrite /all_hooks_fire/filter_hooks in K. 291 | move: st S' E K pf'; clear pf' st; subst p=>st S' E K' pf'. 292 | apply: (@SendMsg W this s1 _ l st pf' to msg)=>////. 293 | move=>z lc hk E'; apply: (K' z); rewrite E'. 294 | by rewrite find_umfiltk/= eqxx. 295 | Qed. 296 | 297 | Definition send_action_wrapper := 298 | Action send_act_safe_coh send_act_step_total send_act_step_sem. 299 | 300 | End SendActionWrapper. 301 | 302 | End Actions. 303 | 304 | Module ActionExports. 305 | 306 | Definition action := Actions.action. 307 | Definition a_safe := Actions.a_safe. 308 | Definition a_step := Actions.a_step. 309 | 310 | Definition a_safe_coh := Actions.a_safe_coh. 311 | Definition a_step_total := Actions.step_total. 312 | Definition a_step_sem := Actions.step_sem. 313 | Definition a_step_other := Actions.step_other. 314 | 315 | Definition skip_action_wrapper := Actions.skip_action_wrapper. 316 | Definition send_action_wrapper := Actions.send_action_wrapper. 317 | Definition tryrecv_action_wrapper := Actions.tryrecv_action_wrapper. 318 | 319 | End ActionExports. 320 | 321 | Export ActionExports. 322 | 323 | -------------------------------------------------------------------------------- /theories/Core/DepMaps.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness EqTypeX. 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | (* An implementation of a dependent map structure *) 10 | 11 | Module DepMaps. 12 | 13 | Section DepMaps. 14 | 15 | Definition Label := [ordType of nat]. 16 | 17 | Variable V : Type. 18 | Variable labF: V -> Label. 19 | 20 | Definition dmDom (u : union_map Label V) : bool := 21 | all (fun l => if find l u is Some p then (labF p) == l else false) (dom u). 22 | 23 | Record depmap := DepMap { 24 | dmap : union_map Label V; 25 | pf : dmDom dmap; 26 | }. 27 | 28 | Section PCMOps. 29 | 30 | Variable dm : depmap. 31 | 32 | Lemma dmDom_unit : dmDom Unit. 33 | Proof. by apply/allP=>l; rewrite dom0. Qed. 34 | 35 | Definition unit := DepMap dmDom_unit. 36 | 37 | End PCMOps. 38 | 39 | Section DJoin. 40 | 41 | Variables (dm1 dm2 : depmap). 42 | 43 | Lemma dmDom_join um1 um2: 44 | dmDom um1 -> dmDom um2 -> dmDom (um1 \+ um2). 45 | Proof. 46 | case W: (valid (um1 \+ um2)); last first. 47 | - by move=> _ _; apply/allP=>l; move/dom_valid; rewrite W. 48 | move/allP=>D1/allP D2; apply/allP=>l. 49 | rewrite domUn inE=>/andP[_]/orP; rewrite findUnL//; case=>E; rewrite ?E. 50 | - by apply: D1. 51 | rewrite joinC in W; case: validUn W=>// _ _ /(_ l E)/negbTE->_. 52 | by apply: D2. 53 | Qed. 54 | 55 | Definition join : depmap := DepMap (dmDom_join (@pf dm1) (@pf dm2)). 56 | 57 | Definition valid (dm : depmap) := valid (dmap dm). 58 | 59 | End DJoin. 60 | 61 | End DepMaps. 62 | 63 | Section PCMLaws. 64 | 65 | Variables (V : Type) (labF: V -> [ordType of nat]). 66 | Implicit Type f : depmap labF. 67 | 68 | 69 | Local Notation "f1 \+ f2" := (join f1 f2) 70 | (at level 43, left associativity). 71 | 72 | Local Notation unit := (unit labF). 73 | 74 | Lemma joinC f1 f2 : f1 \+ f2 = f2 \+ f1. 75 | Proof. 76 | case: f1 f2=>d1 pf1[d2 pf2]; rewrite /join/=. 77 | move: (dmDom_join pf1 pf2) (dmDom_join pf2 pf1); rewrite joinC=>G1 G2. 78 | by move: (eq_irrelevance G1 G2)=>->. 79 | Qed. 80 | 81 | Lemma joinCA f1 f2 f3 : f1 \+ (f2 \+ f3) = f2 \+ (f1 \+ f3). 82 | Proof. 83 | case: f1 f2 f3=>d1 pf1[d2 pf2][d3 pf3]; rewrite /join/=. 84 | move: (dmDom_join pf1 (dmDom_join pf2 pf3)) (dmDom_join pf2 (dmDom_join pf1 pf3)). 85 | by rewrite joinCA=>G1 G2; move: (eq_irrelevance G1 G2)=>->. 86 | Qed. 87 | 88 | Lemma joinA f1 f2 f3 : f1 \+ (f2 \+ f3) = (f1 \+ f2) \+ f3. 89 | Proof. 90 | case: f1 f2 f3=>d1 pf1[d2 pf2][d3 pf3]; rewrite /join/=. 91 | move: (dmDom_join pf1 (dmDom_join pf2 pf3)) (dmDom_join (dmDom_join pf1 pf2) pf3). 92 | by rewrite joinA=>G1 G2; move: (eq_irrelevance G1 G2)=>->. 93 | Qed. 94 | 95 | Lemma validL f1 f2 : valid (f1 \+ f2) -> valid f1. 96 | Proof. by rewrite /join/valid/==>/validL. Qed. 97 | 98 | Lemma unitL f : unit \+ f = f. 99 | Proof. 100 | rewrite /join/unit/=; case: f=>//=u pf. 101 | move: pf (dmDom_join (dmDom_unit labF) pf); rewrite unitL=>g1 g2. 102 | by move: (eq_irrelevance g1 g2)=>->. 103 | Qed. 104 | 105 | Lemma validU : valid unit. 106 | Proof. by rewrite /unit/valid/=. Qed. 107 | 108 | 109 | End PCMLaws. 110 | 111 | Module Exports. 112 | Section Exports. 113 | Variable V : Type. 114 | Variable labF: V -> Label. 115 | Definition depmap := depmap. 116 | Definition DepMap := DepMap. 117 | 118 | Lemma dep_unit (d : depmap labF) : dmap d = Unit -> d = unit labF. 119 | Proof. 120 | case: d=>u pf/=; rewrite /unit. move: (dmDom_unit labF)=>pf' Z; subst u. 121 | by rewrite (eq_irrelevance pf). 122 | Qed. 123 | 124 | Coercion dmap := dmap. 125 | Definition ddom (d : depmap labF) := dom (dmap d). 126 | Definition dfind x (d : depmap labF) := find x (dmap d). 127 | 128 | Definition depmap_classPCMMixin := 129 | PCMMixin (@joinC V labF) (@joinA V labF) (@unitL V labF) (@validL V labF) (validU labF). 130 | 131 | Canonical depmap_classPCM := Eval hnf in PCM (depmap labF) depmap_classPCMMixin. 132 | 133 | 134 | End Exports. 135 | End Exports. 136 | 137 | End DepMaps. 138 | 139 | Export DepMaps.Exports. 140 | 141 | -------------------------------------------------------------------------------- /theories/Core/DiSeLExtraction.v: -------------------------------------------------------------------------------- 1 | From DiSeL Require Import While. 2 | From Coq Require Import ExtrOcamlBasic. 3 | 4 | Extraction Inline ssrbool.SimplPred. 5 | 6 | Extract Constant Actions.Actions.tryrecv_action_wrapper => "DiSeL.tryrecv_action_wrapper". 7 | Extract Constant Actions.Actions.send_action_wrapper => "DiSeL.send_action_wrapper". 8 | Extract Constant Actions.Actions.skip_action_wrapper => "DiSeL.skip_action_wrapper". 9 | 10 | Extract Constant HoareTriples.act_prog => "DiSeL.act_prog". 11 | Extract Constant HoareTriples.ret_prog => "DiSeL.ret_prog". 12 | Extract Constant HoareTriples.bnd_prog => "DiSeL.bnd_prog". 13 | Extract Constant HoareTriples.DTLattice.sup_prog => "DiSeL.sup_prog". 14 | Extract Constant HoareTriples.inject_prog => "DiSeL.inject_prog". 15 | Extract Constant HoareTriples.with_inv_prog => "DiSeL.with_inv_prog". 16 | 17 | Extract Constant HoareTriples.ffix => "DiSeL.ffix". 18 | Extract Constant While.while => "DiSeL.coq_while". 19 | 20 | Extract Inductive HoareTriples.prog => "DiSeL.prog" ["DiSeL.mkProg"] "DiSeL.elimProg". 21 | 22 | Extract Inductive Actions.Actions.action => "DiSeL.action" ["DiSeL.mkAction"] "DiSeL.elimAction". 23 | -------------------------------------------------------------------------------- /theories/Core/EqTypeX.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | 9 | (* We need a custom equality type, as the default one from 10 | ssreflect breaks constraint solving when defining worlds. 11 | 12 | TODO: figure out, why? 13 | *) 14 | 15 | Module EqualityX. 16 | 17 | Definition axiom T (e : rel T) := forall x y, reflect (x = y) (e x y). 18 | 19 | Structure mixin_of T := Mixin {op : rel T; _ : axiom op}. 20 | Notation class_of := mixin_of (only parsing). 21 | 22 | Section ClassDef. 23 | 24 | Structure type := Pack {sort; _ : class_of sort; _ : Type}. 25 | Local Coercion sort : type >-> Sortclass. 26 | Variables (T : Type) (cT : type). 27 | 28 | Definition class := let: Pack _ c _ := cT return class_of cT in c. 29 | 30 | Definition pack c := @Pack T c T. 31 | Definition clone := fun c & cT -> T & phant_id (pack c) cT => pack c. 32 | 33 | End ClassDef. 34 | 35 | Module Exports. 36 | Coercion sort : type >-> Sortclass. 37 | Notation eqTypeX := type. 38 | Notation EqMixinX := Mixin. 39 | Notation EqTypeX T m := (@pack T m). 40 | End Exports. 41 | 42 | End EqualityX. 43 | Export EqualityX.Exports. 44 | 45 | Section EqualityConversion. 46 | 47 | Variable U: eqTypeX. 48 | Definition eq_opX T := EqualityX.op (EqualityX.class T). 49 | 50 | Lemma eqxP : Equality.axiom (@eq_opX U). 51 | Proof. by case: U=>s[op a ?]; apply: a. Qed. 52 | 53 | Canonical eqMixinX := EqMixin eqxP. 54 | Canonical eqTypeX' := EqType U eqMixinX. 55 | 56 | End EqualityConversion. 57 | 58 | (* Section EqualityConversion2. *) 59 | 60 | (* Variable U: eqType. *) 61 | (* Local Definition eq_op T := Equality.op (Equality.class T). *) 62 | 63 | (* Lemma eqP' : Equality.axiom (@eq_op U). *) 64 | (* Proof. by case: U=>s[op a ?]; apply: a. Qed. *) 65 | 66 | (* Canonical eqMixinX2 := EqMixinX eqP'. *) 67 | (* Canonical eqTypeX2' := EqTypeX U eqMixinX2. *) 68 | 69 | (* End EqualityConversion2. *) 70 | 71 | -------------------------------------------------------------------------------- /theories/Core/Freshness.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq. 2 | From mathcomp Require Import path. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap seqext. 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | Section Keys. 9 | Variables (K : ordType) (V : Type) (U : union_map_class K V). 10 | Implicit Types (k : K) (v : V) (f : U). 11 | 12 | Lemma keys_last_mono f1 f2 k : 13 | path oleq k (dom f1) -> 14 | path oleq k (dom f2) -> 15 | (forall x, x \in dom f1 -> x \in dom f2) -> 16 | oleq (last k (dom f1)) (last k (dom f2)). 17 | Proof. 18 | rewrite !umEX; case: (UMC.from f1). 19 | - by move=>_ H _; apply: path_lastR H=>//; apply: otrans. 20 | move=>{f1} f1 /= _ H1; case: (UMC.from f2)=>/=. 21 | - by move=>_ /allP; case: (supp f1)=>//; rewrite /oleq eq_refl orbT. 22 | by move=>{f2} f2 /= _; apply: seq_last_monoR H1=>//; apply: otrans. 23 | Qed. 24 | 25 | End Keys. 26 | 27 | (* Last_key and Fresh are constructs that work *) 28 | (* for any union map with integer keys *) 29 | (* Should be developed more generally for any union map class *) 30 | (* with a proof that key U = nat, but I can't bother right now *) 31 | 32 | Section FreshLastKey. 33 | Variable V : Type. 34 | Implicit Type f : union_map [ordType of nat] V. 35 | 36 | Definition last_key f := last 0 (dom f). 37 | 38 | Lemma last_key0 : last_key Unit = 0. 39 | Proof. by rewrite /last_key /Unit /= !umEX. Qed. 40 | 41 | Lemma last_key_dom f : valid f -> last_key f \notin dom f -> f = Unit. 42 | Proof. 43 | rewrite /valid /= /last_key /Unit /= !umEX /= -{4}[f]UMC.tfE. 44 | case: (UMC.from f)=>//=; case=>s H /= H1 _ /seq_last_in. 45 | rewrite /UM.empty UMC.eqE UM.umapE /supp fmapE /= {H H1}. 46 | by elim: s. 47 | Qed. 48 | 49 | Lemma dom_last_key f : valid f -> ~~ unitb f -> last_key f \in dom f. 50 | Proof. by move=>X; apply: contraR; move/(last_key_dom X)=>->; apply: unitb0. Qed. 51 | 52 | Lemma last_key_max f x : x \in dom f -> x <= last_key f. 53 | Proof. 54 | rewrite /last_key /= !umEX; case: (UMC.from f)=>//; case=>s H _ /=. 55 | rewrite /supp /ord /= (leq_eqVlt x) orbC. 56 | by apply: sorted_last_key_maxR (sorted_oleq H)=>//; apply: otrans. 57 | Qed. 58 | 59 | Lemma max_key_last f x : 60 | x \in dom f -> {in dom f, forall y, y <= x} -> last_key f = x. 61 | Proof. 62 | rewrite /last_key !umEX; case: (UMC.from f)=>//; case=>s H _ /=. 63 | move=>H1 /= H2; apply: sorted_max_key_last (sorted_oleq H) H1 _. 64 | - by apply: otrans. 65 | - by apply: oantisym. 66 | by move=>z /(H2 z); rewrite leq_eqVlt orbC. 67 | Qed. 68 | 69 | Lemma last_keyPt (x : nat) v : last_key (x \\-> v) = x. 70 | Proof. by rewrite /last_key /um_pts /= !umEX. Qed. 71 | 72 | Lemma hist_path f : path oleq 0 (dom f). 73 | Proof. 74 | rewrite !umEX; case: (UMC.from f)=>// {f} f /= _; case: f; case=>//= x s H. 75 | rewrite {1}/oleq /ord /= orbC -leq_eqVlt /=. 76 | by apply: sub_path H=>z y; rewrite /oleq=>->. 77 | Qed. 78 | 79 | Lemma last_key_mono f1 f2 : 80 | {subset dom f1 <= dom f2} -> last_key f1 <= last_key f2. 81 | Proof. 82 | rewrite leq_eqVlt orbC=>H; apply: (@keys_last_mono _ _ _ f1 f2); 83 | try by apply: hist_path. 84 | by move=>x /=; move: (H x). 85 | Qed. 86 | 87 | Lemma last_keyfUn f1 f2 : 88 | valid (f1 \+ f2) -> last_key f1 <= last_key (f1 \+ f2). 89 | Proof. by move=>X; apply: last_key_mono=>x; rewrite domUn inE X => ->. Qed. 90 | 91 | Lemma last_keyUnf f1 f2 : 92 | valid (f1 \+ f2) -> last_key f2 <= last_key (f1 \+ f2). 93 | Proof. by rewrite joinC; apply: last_keyfUn. Qed. 94 | 95 | (* freshness *) 96 | 97 | Definition fresh f := (last_key f).+1. 98 | 99 | Lemma dom_ordfresh f x : x \in dom f -> x < fresh f. 100 | Proof. by move/last_key_max. Qed. 101 | 102 | Lemma dom_freshn f n : fresh f + n \notin dom f. 103 | Proof. by apply: contra (@dom_ordfresh _ _) _; rewrite -leqNgt leq_addr. Qed. 104 | 105 | Lemma dom_fresh f : fresh f \notin dom f. 106 | Proof. by move: (dom_freshn f 0); rewrite addn0. Qed. 107 | 108 | Lemma valid_fresh f v : valid (f \+ fresh f \\-> v) = valid f. 109 | Proof. by rewrite joinC validPtUn dom_fresh andbT. Qed. 110 | 111 | Lemma valid_fresh' f v i w : 112 | valid (f \+ i \\-> w) -> 113 | valid (f \+ fresh (f \+ i \\-> w) \\-> v). 114 | Proof. 115 | move=> W; rewrite joinC validPtUn. 116 | move: (dom_fresh (f \+ i \\-> w)); rewrite domUn inE; rewrite W/=. 117 | by rewrite negb_or=>/andP; case=>-> _;move/validL: W=>->. 118 | Qed. 119 | 120 | Lemma last_fresh f v : valid f -> last_key (f \+ fresh f \\-> v) = fresh f. 121 | Proof. 122 | move=>Vf; apply: max_key_last=>[|x] /=. 123 | - by rewrite domUn inE valid_fresh Vf domPt inE eq_refl orbT. 124 | rewrite domUn inE /= valid_fresh Vf /= domPt inE /= orbC eq_sym. 125 | by rewrite leq_eqVlt; case: eqP=>//= _; apply: dom_ordfresh. 126 | Qed. 127 | 128 | End FreshLastKey. 129 | 130 | -------------------------------------------------------------------------------- /theories/Core/InferenceRules.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From htt Require Import domain. 5 | From DiSeL Require Import Freshness State EqTypeX DepMaps Protocols. 6 | From DiSeL Require Import Worlds NetworkSem Rely Actions Injection Process. 7 | From DiSeL Require Import Always HoareTriples InductiveInv. 8 | Set Implicit Arguments. 9 | Unset Strict Implicit. 10 | Import Prenex Implicits. 11 | 12 | (***************************************************************************** 13 | 14 | [Unary Hoare-style specifications and auxiliary lemmas]. 15 | 16 | This file borrows basic definition of binary-to-unary Hoare triple 17 | encoding (i.e., logvar and binarify definitions) from the development 18 | of FCSL by Nanevski et al. 19 | 20 | (FCSL is available at http://software.imdea.org/fcsl) 21 | 22 | 23 | *****************************************************************************) 24 | 25 | (* Spec s is parametrized by a ghost variable of type A *) 26 | Definition logvar {B A} (s : A -> spec B) : spec B := 27 | (fun i => exists x : A, (s x).1 i, 28 | fun y i m => forall x : A, (s x).2 y i m). 29 | 30 | (* Representing q as a unary postcondition, including the precondition *) 31 | Definition binarify {A} (p : pre) (q : cont A) : spec A := 32 | (p, fun i y m => p i -> q y m). 33 | 34 | Notation "'DHT' [ this , W ] ( p , q ) " := 35 | (DTbin this W (binarify p q)) (at level 0, 36 | format "'[hv ' DHT [ this , W ] ( '[' p , '/' q ']' ) ']'"). 37 | 38 | (* A unary Hoare-style specification *) 39 | Notation "{ x .. y }, 'DHT' [ this , W ] ( p , q )" := 40 | (DTbin this W (logvar (fun x => .. (logvar (fun y => binarify p q)) .. ))) 41 | (at level 0, x binder, y binder, right associativity, 42 | format "'[hv ' { x .. y }, '/ ' DHT [ this , W ] ( '[' p , '/' q ']' ) ']'"). 43 | 44 | Section BasicRules. 45 | 46 | Variable this : nid. 47 | 48 | (* We can always assume coherence of the state *) 49 | Lemma vrf_coh W A (e : DT this W A) i r : 50 | (i \In Coh W -> verify i e r) -> verify i e r. 51 | Proof. 52 | by move=>H C; apply: H. 53 | Qed. 54 | 55 | (* stability of preconditions *) 56 | Lemma vrf_pre W A (e : DT this W A) i i' (k : cont A) : 57 | verify i e k -> network_rely W this i i' -> verify i' e k. 58 | Proof. 59 | move=>H M Ci' t H'; case: (rely_coh M)=>Ci _. 60 | by apply: aft_imp (alw_envs (H Ci t H') M). 61 | Qed. 62 | 63 | (* stability of postconditions *) 64 | Lemma vrf_post W A (e : DT this W A) i (k : cont A) : 65 | verify i e k -> 66 | verify i e (fun x m => forall m', network_rely W this m m' -> k x m'). 67 | Proof. 68 | move=>H Ci t H'; move: (alw_envsq (H Ci t H')). 69 | apply: alw_imp=>s p Cs H2 s3 M v E; apply: H2 E _ M. 70 | Qed. 71 | 72 | (* An inference rule for the sequential composition *) 73 | Lemma bind_rule W A B (e1 : DT this W A) (e2 : A -> DT this W B) i 74 | (q : cont A) (r : cont B) : 75 | verify i e1 q -> 76 | (forall y j, q y j -> j \In Coh W -> verify j (e2 y) r) -> 77 | verify i (bind e1 e2) r. 78 | Proof. 79 | move=>H1 H2 Ci t [->|[t'][H3 H4]]. 80 | - by apply: alw_unfin=>//; move/alw_coh: (H1 Unfinished (prog_unfin e1)). 81 | by apply: aft_bnd H3 _; move/(H1 Ci): H4; apply: aft_imp=>y j Cj H; apply: H2. 82 | Qed. 83 | 84 | Arguments bind_rule [W A B e1 e2 i]. 85 | 86 | Lemma step W A B (e1 : DT this W A) (e2 : A -> DT this W B) i (r : cont B) : 87 | verify i e1 (fun y m => verify m (e2 y) r) -> 88 | verify i (bind e1 e2) r. 89 | Proof. by move=>H; apply: (bind_rule (fun y m => verify m (e2 y) r)). Qed. 90 | 91 | (* Inference rules for the calls to an already verified function f *) 92 | Lemma call_rule' W A i (f : DT this W A) (k : cont A) : 93 | (* Verify precondition of the call *) 94 | (i \In Coh W -> pre_of f i) -> 95 | (* Verify the rest out of the postcondition *) 96 | (forall x m, post_of f i x m -> m \In Coh W -> k x m) -> 97 | verify i f k. 98 | Proof. 99 | case: f=>s [e] /= H H1 H2 Ci t H3. 100 | apply: aft_imp (H i t (H1 Ci) Ci H3). 101 | by move=>v m Cm H4; apply: H2. 102 | Qed. 103 | 104 | (* Same lemma for unary postconidtions *) 105 | Lemma call_rule W A (p : Pred state) (q : A -> Pred state) i 106 | {e} (k : cont A) : 107 | (i \In Coh W -> p i) -> 108 | (forall x m, q x m -> m \In Coh W -> k x m) -> 109 | verify i (@with_spec this W A (binarify p q) e) k. 110 | Proof. 111 | move=>H1 H2; apply: vrf_coh=>C; apply: call_rule'=>//. 112 | by move=>x m /(_ (H1 C)); apply: H2. 113 | Qed. 114 | 115 | 116 | (* Lemmas for manipulating with ghost variables *) 117 | Section GhostRules. 118 | 119 | Variables (W : world) (A B C : Type). 120 | 121 | (* Weakening of the continuation postcondition *) 122 | Lemma vrf_mono (e : DT this W A) i (r1 r2 : cont A) : 123 | r1 <== r2 -> verify i e r1 -> verify i e r2. 124 | Proof. by move=>T H1 C' t; move/(H1 C'); apply: aft_imp=>v m _; apply: T. Qed. 125 | 126 | Variable (e : DT this W A). 127 | 128 | (* "Uncurrying" the ghosts in the specification s *) 129 | Lemma ghE (s : B -> C -> spec A) : 130 | conseq e (logvar (fun x => logvar (s x))) <-> 131 | conseq e (logvar (fun xy => s xy.1 xy.2)). 132 | Proof. 133 | split. 134 | - move=>/= H1 i [[x y]] H2. 135 | have: exists x1 y1, (s x1 y1).1 i by exists x, y. 136 | by move/H1; apply: vrf_mono=>y1 m1 T1 [x2 y2]; apply: (T1 x2 y2). 137 | move=>/= H1 i [x][y] H2. 138 | have: exists x, (s x.1 x.2).1 i by exists (x, y). 139 | by move/H1; apply: vrf_mono=>y1 m1 T1 x2 y2; apply: (T1 (x2, y2)). 140 | Qed. 141 | 142 | (* Pulling the ghosts out of the specification *) 143 | Lemma ghC (p : B -> pre) (q : B -> A -> pre) : 144 | (forall i x, p x i -> i \In Coh W -> verify i e (q x)) -> 145 | conseq e (logvar (fun x => binarify (p x) (q x))). 146 | Proof. 147 | move=>H i /= [x Hp] Ci t Ht. 148 | have S : alwsafe i t by apply: alw_imp (H i x Hp Ci Ci t Ht). 149 | by apply/aftA=>// y; apply/aftI=>// /H; apply. 150 | Qed. 151 | 152 | 153 | (********************************************) 154 | (* Lemmas for instantiating ghost variables *) 155 | (********************************************) 156 | Variables (s : C -> spec A) (f : DTbin this W (logvar s)). 157 | 158 | (* helper lemma, to express the instantiation *) 159 | Lemma gh_conseq t : conseq f (s t). 160 | Proof. 161 | case E: (s t)=>[a b] h /= H; apply: call_rule'=>[|x m]. 162 | - by exists t; rewrite E. 163 | by move/(_ t); rewrite E. 164 | Qed. 165 | 166 | (* Instantiating the ghost of a call *) 167 | Lemma gh_ex g i (k : cont A) : 168 | verify i (do' (@gh_conseq g)) k -> 169 | verify i (@with_spec this W A (logvar s) f) k. 170 | Proof. by []. Qed. 171 | 172 | End GhostRules. 173 | 174 | Arguments gh_ex [W A C s f]. 175 | 176 | Lemma act_rule W A (a: action W A this) i (r : cont A) : 177 | (forall j, network_rely W this i j -> a_safe a j /\ 178 | forall y k m, (exists pf : a_safe a j, a_step pf k y) -> network_rely W this k m -> r y m) -> 179 | verify i (act a) r. 180 | Proof. 181 | move=>H C p; case=>Z; subst p; first by apply: (alw_unfin C). 182 | apply: (alw_act C)=>j R; case: (H j R)=>{H}S H; exists S. 183 | split=>//k v m St R' v'[]<-. 184 | have X: (exists pf : a_safe a j, a_step pf k v) by exists S. 185 | by apply: (H _ _ _ X R'). 186 | Qed. 187 | 188 | 189 | Lemma ret_rule W A i (v : A) (r : cont A) : 190 | (forall m, network_rely W this i m -> r v m) -> 191 | verify i (ret this W v) r. 192 | Proof. 193 | move=>H C p; case=>Z; subst p; first by apply: alw_unfin. 194 | by apply: alw_ret=>//m R v'[]<-; apply: H. 195 | Qed. 196 | 197 | End BasicRules. 198 | 199 | 200 | Section InjectLemmas. 201 | 202 | Variable this : nid. 203 | Variables (W V : world) (K : hooks) (A : Type) (w : injects V W K). 204 | Notation W2 := (inj_ext w). 205 | 206 | Variable (e1 : DT this V A). 207 | 208 | Lemma inject_rule i j (r : cont A) : 209 | i \In Coh V -> 210 | verify i e1 (fun x i' => forall j', 211 | i' \+ j' \In Coh W -> network_rely W2 this j j' -> r x (i' \+ j')) -> 212 | verify (i \+ j) (inject w e1) r. 213 | Proof. 214 | move=>Ci H C t [->|[t' [H' ->{t}]]]; first by apply: alw_unfin. 215 | move/aft_inject: {H H'} (H Ci _ H'); move/(_ _ _ w _ C). 216 | apply: aft_imp=>v s Cs [i'][j'][E] Ci' S'. 217 | by rewrite {s}E in Cs *; apply. 218 | Qed. 219 | 220 | End InjectLemmas. 221 | 222 | 223 | Section InductiveInvLemmas. 224 | 225 | 226 | Variable pr : protocol. 227 | 228 | Notation l := (plab pr). 229 | Variable I : dstatelet -> pred nid -> Prop. 230 | Variable ii : InductiveInv pr I. 231 | 232 | (* Tailored modal always-lemma *) 233 | 234 | Variables (A : Type) (this: nid). 235 | Notation V := (mkWorld pr). 236 | Notation W := (mkWorld (ProtocolWithIndInv ii)). 237 | 238 | Variable (e : DT this V A). 239 | 240 | (* 241 | 242 | [Inferences rule for invariant strengthening] 243 | 244 | This rule essentially means that we can always verify the program in 245 | stronger assumptions (i.e., in a protocol, enriched with the inductive 246 | invariant), if we can provide this protocol in the first place. We can 247 | then also make use of the invariant. 248 | 249 | *) 250 | 251 | Notation getS i := (getStatelet i l). 252 | 253 | Lemma with_inv_rule' i (r : cont A) : 254 | verify i e (fun x m => 255 | I (getS m) (nodes pr (getS m)) -> r x m) -> 256 | verify i (with_inv ii e) r. 257 | Proof. 258 | move=> H C t [->|[t' [H' ->{t}]]]; first by apply: alw_unfin. 259 | move/aft_ind_inv: {H H'}(H (with_inv_coh C) _ H')=>/(_ _ _ C). 260 | apply: aft_imp=>v m _[C']; apply. 261 | by case: C'=>_ _ _ _/(_ l); rewrite prEq; case. 262 | Qed. 263 | 264 | Lemma with_inv_rule i (r : cont A) : 265 | verify i e (fun x m => r x m) -> 266 | verify i (with_inv ii e) r. 267 | Proof. 268 | move=>H; apply: with_inv_rule'. 269 | by move=>H1 p H2; move: (H H1 p H2)=>G; apply: (aft_imp _ G). 270 | Qed. 271 | 272 | End InductiveInvLemmas. 273 | -------------------------------------------------------------------------------- /theories/Core/NetworkSem.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import axioms pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX Protocols Worlds. 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | (* Operational semantics of the network *) 10 | 11 | Section NetworkSemantics. 12 | 13 | Variable w : world. 14 | Variable this: nid. 15 | 16 | Notation getl := (getLocal). 17 | Notation gets := (getStatelet). 18 | Notation getp := (@getProtocol w). 19 | 20 | (* Getters for transitions *) 21 | 22 | Definition get_coh l := @coh (getp l). 23 | Definition get_st l := @snd_trans (getp l). 24 | Definition get_rt l := @rcv_trans (getp l). 25 | 26 | Lemma getsE l s : l \in dom s -> find l s = Some (gets s l). 27 | Proof. 28 | move=>D. rewrite /gets; case f: (find l s)=>[v|]=>//. 29 | by move: f; move/find_none/negbTE; rewrite D. 30 | Qed. 31 | 32 | Lemma coh_s l s: Coh w s -> coh (getp l) (gets s l). 33 | Proof. by case=>_ _ _ /(_ l). Qed. 34 | 35 | Lemma Coh_dom l s : l \in dom s -> Coh w s -> 36 | dom (dstate (gets s l)) =i nodes (getp l) (gets s l). 37 | Proof. by move=>D; case:w=>c h [] W V K E /(_ l); apply:cohDom. Qed. 38 | 39 | (* A predicate making all hooks apply to the send-transition with a 40 | tag st of a protocol with label l. *) 41 | Definition all_hooks_fire (h : hooks) l st s n (msg : seq nat) to := 42 | (* For any hook associated with client protocol l and send-tag st *) 43 | forall z lc hk, Some hk = find ((z, lc), (l, st)) h -> 44 | lc \in dom s -> l \in dom s -> 45 | let: core_local := getl n (gets s lc) in 46 | let: client_local := getl n (gets s l) in 47 | hk core_local client_local msg to. 48 | 49 | (* Semantics of the network in the presence of some world *) 50 | (* Defining small-step semantics of the network *) 51 | Inductive network_step (s1 s2 : state) : Prop := 52 | (* Do nothing *) 53 | Idle of s1 \In Coh w /\ s1 = s2 54 | 55 | (* Send message *) 56 | | SendMsg (* Pick a world, send transition and a recipient *) 57 | l st (_ : st \In @get_st l) to msg b 58 | (pf: this \in (nodes (getp l) (gets s1 l))) 59 | (pf' : l \in dom s1) (C: Coh w s1) 60 | 61 | (* It's safe to send *) 62 | (S : send_safe st this to (gets s1 l) msg) 63 | 64 | (* All hooks are applicable *) 65 | (pf_hooks : all_hooks_fire (geth w) l (t_snd st) s1 this msg to) 66 | 67 | (* b is a result of executing the transition *) 68 | (spf : Some b = send_step S) of 69 | 70 | (* Generate the message and the new local state *) 71 | let: d := gets s1 l in 72 | 73 | (* Update the soup and local state *) 74 | let: f' := upd this b (dstate d) in 75 | let: s' := (post_msg (dsoup d) (Msg (TMsg (t_snd st) msg) 76 | this to true)).1 in 77 | s2 = upd l (DStatelet f' s') s1 78 | 79 | | ReceiveMsg l rt (_ : rt \In @get_rt l) i from 80 | (* Pick a world, receive transition and a message *) 81 | (pf: this \in (nodes (getp l)) (gets s1 l)) 82 | (pf': l \in dom s1) (C: Coh w s1) 83 | (msg : TaggedMessage) 84 | (pf': tag msg = t_rcv rt) of 85 | let: d := (gets s1 l) in 86 | let: f := dstate d in 87 | let: s := dsoup d in 88 | 89 | [/\ find i s = Some (Msg msg from this true), 90 | msg_wf rt (coh_s l C) this from msg & 91 | (* The semantics doesn't execute unsafe receive-transitions *) 92 | let loc' := receive_step rt from msg (coh_s l C) pf in 93 | let: f' := upd this loc' f in 94 | let: s'' := consume_msg s i in 95 | s2 = upd l (DStatelet f' s'') s1]. 96 | 97 | 98 | (* The first important result: network stepping preserves overall coherence. 99 | 100 | Intuitively, this follows from the fact that the transitions 101 | preserve coherence. *) 102 | 103 | Lemma step_coh s1 s2: network_step s1 s2 -> 104 | Coh w s1 /\ Coh w s2. 105 | Proof. 106 | case=>[[H1 <-] | l st _ to a loc' pf D C S Ph Spf ->/= | 107 | l rt _ i from pf D C H1 msg [H3 H4->/=]]//; split=>//. 108 | - case: (C)=>W V K E H; split=>//; first by rewrite validU/= V. 109 | + move=>z; rewrite domU/= !inE V. 110 | by case b: (z == l)=>//; move/eqP: b=>?; subst; rewrite E D. 111 | move=>k; case b: (k == l); rewrite /gets findU b/=; last by apply: H. 112 | rewrite V/=; move/eqP: b=>Z; subst k=>/=. 113 | case: st a S Ph Spf => /= t_snd ssafe G1 G2 sstep Y G3 a S Ph Spf. 114 | have X: exists b pf, sstep this to (gets s1 l) a pf = Some b by exists loc', S. 115 | move/Y: X=>X; move: (G1 _ _ _ _ X) (G2 _ _ _ _ X)=>{G1 G2}G1 G2; apply: G3. 116 | rewrite /gets in Spf; rewrite Spf; move: (coh_s l C)=>G1'. 117 | by rewrite -(pf_irr X S). 118 | case: (C)=>W V K E H; split=>//; first by rewrite validU/= V. 119 | - move=>z; rewrite domU/= !inE V. 120 | by case b: (z == l)=>//; move/eqP: b=>?; subst; rewrite E D. 121 | move=>k; case b: (k == l); rewrite /gets findU b/=; last by apply: H. 122 | move: (coh_s l (And5 W V K E H))=>G1. 123 | rewrite V; move/eqP: b=>Z; subst k=>/=. 124 | have pf' : this \in dom (dstate (gets s1 l)) 125 | by move: (pf); rewrite -(Coh_dom D C). 126 | case: rt H1 H3 msg H4=>/= r_rcvwf mwf rstep G msg T F M. 127 | rewrite -(pf_irr (H l) (coh_s l C)) in M. 128 | move: (G (gets s1 l) from this i (H l) pf msg pf' T M F); rewrite /gets. 129 | by move: (H l)=>G1'; rewrite -(pf_irr G1 G1'). 130 | Qed. 131 | 132 | (* Stepping preserves the protocol structure *) 133 | Lemma step_preserves_labels s1 s2 : 134 | network_step s1 s2 -> dom s1 =i dom s2. 135 | Proof. 136 | by move/step_coh=>[[_ _ _ E1 _][_ _ _ E2 _]]z; rewrite -E1 -E2. 137 | Qed. 138 | 139 | (* Stepping only changes the local state of "this" node, 140 | in any of the protocols. *) 141 | 142 | Lemma step_is_local s1 s2 l: network_step s1 s2 -> 143 | forall z, z != this -> 144 | find z (dstate (gets s1 l)) = find z (dstate (gets s2 l)). 145 | Proof. 146 | move=>S z N; case: S; first by case=>_ Z; subst s2. 147 | - move=>k st ? to a b pf D C S Ph Spf Z; subst s2; case B: (l == k); 148 | rewrite /gets findU B //= (cohS C)/=. 149 | by move/negbTE: N; rewrite findU=>->/=; move/eqP: B=>->. 150 | move=>k rt ? i from H1 H2 C msg T/= [H3 H4]Z; subst s2. 151 | case B: (l == k); rewrite /gets findU B //= (cohS C)/=. 152 | by move/negbTE: N; rewrite findU=>->/=; move/eqP: B=>->. 153 | Qed. 154 | 155 | (* Lemma step_other_label s1 s2 l: network_step s1 s2 -> *) 156 | (* forall z l', l' != l -> *) 157 | (* find z (dstate (gets s1 l')) = find z (dstate (gets s2 l')). *) 158 | (* Proof. *) 159 | (* move=>S z l' N; case: S; first by case=>_ Z; subst s2. *) 160 | (* (* Send-transition *) *) 161 | (* move=>k st ? to a b pf D C S Ph Spf Z; subst s2. *) 162 | (* case B: (l' == k); rewrite /gets !findU B ?(cohS C)//=. *) 163 | (* move/eqP: B=>B; subst l'. *) 164 | (* case: dom_find D=>//d -> E _. rewrite findU. *) 165 | (* Search _ (dom_find_spec). *) 166 | (* (* Receive-transition *) *) 167 | (* Qed. *) 168 | 169 | Lemma stepV1 s1 s2: network_step s1 s2 -> valid s1. 170 | Proof. by case/step_coh=>/cohS. Qed. 171 | 172 | Lemma stepV2 s1 s2: network_step s1 s2 -> valid s2. 173 | Proof. by case/step_coh=>_ /cohS. Qed. 174 | 175 | (* 176 | Network steps do not allocate/deallocate nodes 177 | (although this might change soon) 178 | *) 179 | Lemma step_preserves_node_ids s1 s2 l: 180 | l \in dom s1 -> network_step s1 s2 -> 181 | dom (dstate (gets s1 l)) =i dom (dstate (gets s2 l)). 182 | Proof. 183 | move=>D S; case: (S); first by case=>C<-. 184 | - move=> l' st H to msg b H1 H2 C _ _ _ Z; subst s2. 185 | rewrite /gets findU; case B: (l == l')=>//=; rewrite (stepV1 S)/==>n. 186 | move/eqP: B=>B; subst l'; rewrite domU/= !inE; case B: (n == this)=>//. 187 | move/eqP:B=>B; subst n; rewrite -(Coh_dom D C) in H1; rewrite H1. 188 | by case: C=>_ _ _ _/(_ l)/cohVl->. 189 | move=>l' rt _ m from H1 D' C msg E[F]W/=Z; subst s2. 190 | rewrite /gets findU; case B: (l == l')=>//=; rewrite (stepV1 S)/==>n. 191 | move/eqP: B=>B; subst l'; rewrite domU/= !inE; case B: (n == this)=>//. 192 | move/eqP:B=>B; subst n; clear S; rewrite -(Coh_dom D C) in H1; rewrite H1. 193 | by case: (C)=>_ _ _ _/(_ l)/cohVl->. 194 | Qed. 195 | 196 | End NetworkSemantics. 197 | 198 | 199 | 200 | -------------------------------------------------------------------------------- /theories/Core/NewStatePredicates.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX DepMaps. 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | Section NewSoupPredicates. 10 | 11 | (*****************************************************) 12 | (* More elaborated message predicates *) 13 | (*****************************************************) 14 | 15 | 16 | Definition msg_in_soup' from to t (cond : seq nat -> bool) (d : soup) := 17 | (exists! i, exists c, 18 | find i d = Some (Msg (TMsg t c) from to true)) /\ 19 | forall i c, find i d = Some (Msg (TMsg t c) from to true) -> cond c. 20 | 21 | Definition msg_spec' from to tg cnt := 22 | msg_in_soup' from to tg (fun y => (y == cnt)). 23 | 24 | Definition no_msg_from_to' from to 25 | (criterion : nat -> seq nat -> bool) (d : soup) := 26 | forall i t c, 27 | find i d = Some (Msg (TMsg t c) from to true) -> ~~criterion t c. 28 | 29 | Lemma no_msg_from_to_consume' from to cond s i: 30 | valid s -> 31 | no_msg_from_to' from to cond s -> 32 | no_msg_from_to' from to cond (consume_msg s i). 33 | Proof. 34 | move=>V H m t c . 35 | rewrite /consume_msg; case: (find i s); last by move=>F; apply: (H m t c F). 36 | move=>ms; case B: (m == i). 37 | - by move/eqP: B=>B; subst m; rewrite findU eqxx/= V. 38 | by rewrite findU B/==>/(H m t c). 39 | Qed. 40 | 41 | Lemma no_msg_spec_consume s from to tg cnt cond i : 42 | valid s -> 43 | find i s = Some {| content := TMsg tg cnt; 44 | from := from; to := to; active := true |} -> 45 | msg_in_soup' from to tg cond s -> 46 | no_msg_from_to' from to (fun x y => (x == tg)) (consume_msg s i). 47 | Proof. 48 | move=>V F[][j][[c]]F' H1 H2. 49 | move=>m t' c'; rewrite /consume_msg; move: (find_some F). 50 | case: dom_find=>// msg->_ _; case B: (m == i). 51 | - by move/eqP: B=>B; subst m; rewrite findU eqxx/= V. 52 | have X: j = i by apply: (H1 i); exists cnt. 53 | subst j; rewrite findU B/==>H. 54 | case X: (t' == tg)=>//=. 55 | move/eqP: X=>X; subst t'. 56 | suff X: i = m by subst i; rewrite eqxx in B. 57 | by apply: (H1 m); exists c'. 58 | Qed. 59 | 60 | Lemma msg_spec_consumeE i d from to from' to' t c' t' cond: 61 | valid d -> 62 | find i d = Some (Msg (TMsg t' c') from' to' true) -> 63 | msg_in_soup' from to t cond d -> 64 | [|| (from != from'), (to != to') | (t != t')] -> 65 | msg_in_soup' from to t cond (consume_msg d i). 66 | Proof. 67 | move=>V E S N. 68 | case: S=>[][j][[c]F]H1 H2. 69 | have Nij: i != j. 70 | - case H: (i == j)=>//. 71 | move/eqP in H; subst i; move: E; rewrite F=>[][???]; subst. 72 | move: N=>/orP []/eqP; first by congruence. 73 | move/eqP/orP; case; first by move=>X Z; subst to'; rewrite eqxx in X. 74 | by rewrite eqxx. 75 | split. 76 | - exists j; split; first by exists c; rewrite mark_other// eq_sym; apply/negbTE. 77 | move=> x [c1] E'. 78 | case H: (x == i). 79 | + by move/eqP in H; subst x; rewrite (find_consume _ E) in E'. 80 | by apply: H1; exists c1; rewrite mark_other in E'. 81 | move=>k c1. 82 | case H: (k == i); first by move/eqP in H; subst k; rewrite (find_consume _ E). 83 | by rewrite mark_other//; apply: H2. 84 | Qed. 85 | 86 | 87 | End NewSoupPredicates. 88 | -------------------------------------------------------------------------------- /theories/Core/Process.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX DepMaps Protocols. 5 | From DiSeL Require Import Worlds NetworkSem Actions Injection InductiveInv. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | Section ProcessSyntax. 12 | 13 | Variable this : nid. 14 | 15 | (* Syntax for process *) 16 | Inductive proc (W : world) A := 17 | Unfinished | Ret of A | Act of action W A this | 18 | Seq B of proc W B & B -> proc W A | 19 | Inject V K of injects V W K & proc V A | 20 | WithInv p I (ii : InductiveInv p I) of 21 | W = mkWorld (ProtocolWithIndInv ii) & proc (mkWorld p) A. 22 | 23 | Definition pcat W A B (t : proc W A) (k : A -> Pred (proc W B)) := 24 | [Pred s | exists q, s = Seq t q /\ forall x, q x \In k x]. 25 | 26 | Inductive schedule := 27 | ActStep | SeqRet | SeqStep of schedule | 28 | InjectStep of schedule | InjectRet | 29 | WithInvStep of schedule | WithInvRet. 30 | 31 | End ProcessSyntax. 32 | 33 | Arguments Unfinished {this W A}. 34 | Arguments Ret [this W A]. 35 | Arguments Act [this W A]. 36 | Arguments Seq [this W A B]. 37 | Arguments WithInv [this W A]. 38 | 39 | Section ProcessSemantics. 40 | 41 | Variable this : nid. 42 | 43 | Fixpoint step (W : world) A (s1 : state) (p1 : proc this W A) 44 | sc (s2 : state) (p2 : proc this W A) : Prop := 45 | match sc, p1 with 46 | (* Action - make a step *) 47 | | ActStep, Act a => exists v pf, @a_step _ _ _ a s1 pf s2 v /\ p2 = Ret v 48 | (* Sequencing - apply a continuation *) 49 | | SeqRet, Seq _ (Ret v) k => s2 = s1 /\ p2 = k v 50 | | SeqStep sc', Seq _ p' k1 => 51 | exists p'', step s1 p' sc' s2 p'' /\ p2 = Seq p'' k1 52 | (* Injection of a non-reduced term *) 53 | | InjectRet, Inject V K pf (Ret v) => 54 | exists s1', [/\ s2 = s1, p2 = Ret v & extends pf s1 s1'] 55 | | InjectStep sc', Inject V K pf t1' => 56 | exists s1' s2' s t2', 57 | [/\ p2 = Inject pf t2', s1 = s1' \+ s, s2 = s2' \+ s, 58 | s1' \In Coh V & step s1' t1' sc' s2' t2'] 59 | (* Imposing an inductive invariant on a non-reduced term *) 60 | | WithInvRet, WithInv p inv ii pf (Ret v) => 61 | exists s1', [/\ s2 = s1, p2 = Ret v & s1 = s1'] 62 | | WithInvStep sc', WithInv p inv ii pf t1' => 63 | exists t2', p2 = WithInv p inv ii pf t2' /\ 64 | step s1 t1' sc' s2 t2' 65 | | _, _ => False 66 | end. 67 | 68 | Fixpoint good (W : world) A (p : proc this W A) sc : Prop := 69 | match sc, p with 70 | | ActStep, Act _ => True 71 | | SeqRet, Seq _ (Ret _) _ => True 72 | | SeqStep sc', Seq _ p' _ => good p' sc' 73 | | InjectStep sc', Inject _ _ _ p' => good p' sc' 74 | | InjectRet, Inject _ _ _ (Ret _) => True 75 | | WithInvStep sc', WithInv _ _ _ _ p' => good p' sc' 76 | | WithInvRet, WithInv _ _ _ _ (Ret _) => True 77 | | _, _ => False 78 | end. 79 | 80 | (* 81 | 82 | [Safety in small-step semantics] 83 | 84 | The safety (in order to make the following step) with respect to the 85 | schedule is defined inductively on the shape of the program and the 86 | schedule. Omitting the schedule is not a good idea, at it's required 87 | in order to "sequentialize" the execution of the program 88 | structure. Once it's dropped, this structure is lost. 89 | 90 | *) 91 | 92 | Fixpoint safe (W : world) A (p : proc this W A) sc (s : state) : Prop := 93 | match sc, p with 94 | | ActStep, Act a => a_safe a s 95 | | SeqRet, Seq _ (Ret _) _ => True 96 | | SeqStep sc', Seq _ p' _ => safe p' sc' s 97 | | InjectStep sc', Inject V K pf p' => 98 | exists s', extends pf s s' /\ safe p' sc' s' 99 | | InjectRet, Inject V K pf (Ret _) => exists s', extends pf s s' 100 | | WithInvStep sc', WithInv _ _ _ _ p' => safe p' sc' s 101 | | WithInvRet, WithInv _ _ _ _ (Ret _) => True 102 | | _, _ => True 103 | end. 104 | 105 | Definition pstep (W : world) A s1 (p1 : proc this W A) sc s2 p2 := 106 | [/\ s1 \In Coh W, safe p1 sc s1 & step s1 p1 sc s2 p2]. 107 | 108 | (* Some sanity lemmas wrt. stepping *) 109 | 110 | Lemma pstep_safe (W : world) A s1 (t : proc this W A) sc s2 q : 111 | pstep s1 t sc s2 q -> safe t sc s1. 112 | Proof. by case. Qed. 113 | 114 | 115 | (* 116 | 117 | The following lemma established the operational "progress" property: a 118 | program, which is safe and also the schedule is appropriate. Together, 119 | this implies that we can do a step. 120 | *) 121 | 122 | Lemma proc_progress W A s (p : proc this W A) sc : 123 | s \In Coh W -> safe p sc s -> good p sc -> 124 | exists s' (p' : proc this W A), pstep s p sc s' p'. 125 | Proof. 126 | move=>C H1 H2; elim: sc W A s p H2 H1 C=>[||sc IH|sc IH||sc IH|]W A s. 127 | - case=>//=a _/= H; move/a_step_total: (H)=>[s'][r]H'. 128 | by exists s', (Ret r); split=>//=; exists r, H. 129 | - by case=>//; move=>B p k/=; case: p=>//b _ _; exists s, (k b). 130 | - case=>//B p k/=H1 H2 C. 131 | case: (IH W B s p H1 H2 C)=>s'[p'][G1 G2]. 132 | by exists s', (Seq p' k); split=>//; exists p'. 133 | - case=>// V K pf p/=H1 [z][E]H2 C. 134 | case: (E)=>s3[Z] C1 C2. 135 | case: (IH V A z p H1 H2 C1) =>s'[p']H3; case: H3=>S St. 136 | exists (s' \+ s3), (Inject pf p'); split=>//; first by exists z. 137 | by subst s; exists z, s', s3, p'. 138 | - case=>//V K pf; case=>// v/=_[s'] E C. 139 | by exists s, (Ret v); split=>//=; exists s'. 140 | - case=>//pr I ii E p/= H1 H2 C. 141 | have C' : s \In Coh (mkWorld pr) by subst W; apply: (with_inv_coh C). 142 | case: (IH (mkWorld pr) A s p H1 H2 C')=>s'[p']H3. 143 | exists s', (WithInv pr I ii E p'); split=>//=. 144 | by exists p'; split=>//; case: H3. 145 | - case=>//pr I ii E; case=>//v/=_ _ C. 146 | by exists s, (Ret v); split=>//=; exists s. 147 | Qed. 148 | 149 | (* Some view lemmas for processes and corresponding schedules *) 150 | 151 | Lemma stepUnfin W A s1 sc s2 (t : proc this W A) : 152 | pstep s1 Unfinished sc s2 t <-> False. 153 | Proof. by split=>//; case; case: sc. Qed. 154 | 155 | Lemma stepRet W A s1 sc s2 (t : proc this W A) v : 156 | pstep s1 (Ret v) sc s2 t <-> False. 157 | Proof. by split=>//; case; case: sc. Qed. 158 | 159 | Lemma stepAct W A s1 a sc s2 (t : proc this W A) : 160 | pstep s1 (Act a) sc s2 t <-> 161 | exists v pf, [/\ sc = ActStep, t = Ret v & @a_step _ _ _ a s1 pf s2 v]. 162 | Proof. 163 | split; first by case=>C; case: sc=>//= c [v [pf [H ->]]]; exists v, pf. 164 | case=>v[pf] [->-> H]; split=>//; last by exists v, pf. 165 | by apply: (a_safe_coh pf). 166 | Qed. 167 | 168 | Lemma stepSeq W A B s1 (t : proc this W B) k sc s2 (q : proc this W A) : 169 | pstep s1 (Seq t k) sc s2 q <-> 170 | (exists v, [/\ sc = SeqRet, t = Ret v, q = k v, s2 = s1 & 171 | s1 \In Coh W]) \/ 172 | exists sc' p', 173 | [/\ sc = SeqStep sc', q = Seq p' k & pstep s1 t sc' s2 p']. 174 | Proof. 175 | split; last first. 176 | - case; first by case=>v [->->->->]. 177 | by case=>sc' [t'][->->][S H]; do !split=>//; exists t'. 178 | case; case: sc=>//[|sc] C. 179 | - by case: t=>//= v _ [->->]; left; exists v. 180 | by move=>G /= [p' [H1 ->]]; right; exists sc, p'. 181 | Qed. 182 | 183 | Lemma stepInject V W K A (em : injects V W K) 184 | s1 (t : proc this V A) sc s2 (q : proc this W A) : 185 | pstep s1 (Inject em t) sc s2 q <-> 186 | (* Case 1 : stepped to the final state s1' of the inner program*) 187 | (exists s1' v, [/\ sc = InjectRet, t = Ret v, q = Ret v, s2 = s1 & 188 | extends em s1 s1']) \/ 189 | (* Case 2 : stepped to the nextx state s12 of the inner program*) 190 | exists sc' t' s1' s2' s, 191 | [/\ sc = InjectStep sc', q = Inject em t', 192 | s1 = s1' \+ s, s2 = s2' \+ s, s1 \In Coh W & 193 | pstep s1' t sc' s2' t']. 194 | Proof. 195 | split; last first. 196 | - case. 197 | + case=>s1' [v][->->->->] E. 198 | split=>//=; [by case: E=>x[] | by exists s1'|by exists s1']. 199 | case=>sc' [t'][s1'][s2'][s][->->->-> C][[C' S] T]. 200 | split=>//=; last by exists s1', s2', s, t'. 201 | by exists s1'; split=>//; exists s. 202 | case=>C; case: sc=>//=; last first. 203 | - case: t=>//= v [C1 S][s1'][->->{s2 q}] X. 204 | by left; exists s1'; exists v. 205 | move=>sc /= [s'][X] S [s1'][s2'][t'][t2'][??? C1'] T; subst q s1 s2. 206 | right; exists sc, t2', s1', s2', t'; do !split=>//. 207 | by case: X=>t'' [E] Cs' _; rewrite (coh_prec (cohS C) _ Cs' E). 208 | Qed. 209 | 210 | Lemma stepWithInv W A pr I (ii : InductiveInv pr I) s1 211 | (t : proc this (mkWorld pr) A) sc s2 (q : proc this W A) pf : 212 | pstep s1 (WithInv pr I ii pf t) sc s2 q <-> 213 | (exists v, [/\ sc = WithInvRet, t = Ret v, q = Ret v, s2 = s1, 214 | s1 \In Coh W & W = mkWorld (ProtocolWithIndInv ii)]) \/ 215 | exists sc' t' , [/\ sc = WithInvStep sc', q = WithInv pr I ii pf t', 216 | W = mkWorld (ProtocolWithIndInv ii), 217 | s1 \In Coh W & pstep s1 t sc' s2 t']. 218 | Proof. 219 | split; last first. 220 | - case. 221 | + by case=>v[->->->->{s2}]C E; split=>//=; exists s1. 222 | by case=>sc' [t'][->->{sc q}]E C[C' S]T; split=>//=; exists t'. 223 | case=>C; case: sc=>//=; last first. 224 | - by case: t=>//=v _[s1'][Z1]Z2 Z3; subst s2 s1' q; left; exists v. 225 | move=>sc /=S[t'][->{q}T]; right; exists sc, t'; split=>//. 226 | by split=>//; subst W; apply: (with_inv_coh C). 227 | Qed. 228 | 229 | (* 230 | 231 | [Stepping and network semantics] 232 | 233 | The following lemma ensures that the operational semantics of our 234 | programs respect the global network semantics. 235 | 236 | *) 237 | 238 | Lemma pstep_network_sem (W : world) A s1 (t : proc this W A) sc s2 q : 239 | pstep s1 t sc s2 q -> network_step W this s1 s2. 240 | Proof. 241 | elim: sc W A s1 s2 t q=>/=. 242 | - move=>W A s1 s2 p q; case: p; do?[by case|by move=>?; case]. 243 | + by move=>a/stepAct [v][pf][Z1]Z2 H; subst q; apply: (a_step_sem H). 244 | + by move=>???; case. 245 | + by move=>????; case. 246 | by move=>?????; case. 247 | - move=>W A s1 s2 p q; case: p; do?[by case|by move=>?; case]. 248 | + move=>B p p0/stepSeq; case=>[[v][_]??? C|[sc'][p'][]]//. 249 | by subst p s2; apply: Idle. 250 | by move=>????/stepInject; case=>[[?][?][?]|[?][?][?][?][?][?]]//. 251 | by move=>?????; case. 252 | - move=>sc HI W A s1 s2 p q; case: p; do?[by case|by move=>?; case]. 253 | + move=>B p p0/stepSeq; case=>[[?][?]|[sc'][p'][][]? ?]//. 254 | by subst sc' q; apply: HI. 255 | by move=>????; case=>? _. 256 | by move=>?????; case. 257 | - move=>sc HI W A s1 s2 p q; case: p; do?[by case|by move=>?; case]. 258 | + by move=>B p p0; case. 259 | move=>V K pf p/stepInject; case=>[[?][?][?]|[sc'][t'][s1'][s2'][s][][]????]//. 260 | subst sc' q s1 s2=>C; move/HI=>S; apply: (sem_extend pf)=>//. 261 | apply/(cohE pf); exists s2', s; case: (step_coh S)=>C1 C2; split=>//. 262 | move/(cohE pf): (C)=>[s1][s2][E]C' H. 263 | by move: (coh_prec (cohS C) C1 C' E)=>Z; subst s1'; rewrite (joinxK (cohS C) E). 264 | by move=>?????; case. 265 | - move=>W A s1 s2 p q; case: p; do?[by case|by move=>?; case]. 266 | + by move=>???; case. 267 | + move=>V K i p; case/stepInject=>[[s1'][v][_]??? X|[?][?][?][?][?][?]]//. 268 | by subst p q s2; apply: Idle; split=>//; case: X=>x []. 269 | by move=>?????; case. 270 | 271 | - move=>sc HI W A s1 s2 p q; case: p; 272 | do?[by case|by move=>?; case|by move=>???; case|by move=>????; case]. 273 | move=>pr I ii E p; case/(stepWithInv s1); first by case=>?; case. 274 | case=>sc'[t'][][]Z1 Z2 _ C1; subst q sc'. 275 | by move/HI=>T; subst W; apply: with_inv_step. 276 | move=>W A s1 s2 t q; do?[by case|by move=>?; case|by move=>???; case]. 277 | case=>C; case: t=>//pr I ii E; case=>//=v _[s1'][Z1]Z2 Z3. 278 | by subst s1' s2 q; apply: Idle. 279 | Qed. 280 | 281 | (* 282 | 283 | [Inductive invariants and stepping] 284 | 285 | The following lemma is the crux of wrapping into inductive invariants, as 286 | it leverages the proof of the fact that each transition preserves the invariant. 287 | 288 | *) 289 | 290 | Lemma pstep_inv A pr I (ii : InductiveInv pr I) s1 s2 sc 291 | (t t' : proc this (mkWorld pr) A): 292 | s1 \In Coh (mkWorld (ProtocolWithIndInv ii)) -> 293 | pstep s1 t sc s2 t' -> 294 | s2 \In Coh (mkWorld (ProtocolWithIndInv ii)). 295 | Proof. by move=>C1; case/pstep_network_sem/(with_inv_step C1)/step_coh. Qed. 296 | 297 | End ProcessSemantics. 298 | -------------------------------------------------------------------------------- /theories/Core/Protocols.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX. 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | (* Definition of the protocols, including coherence predicate, tags, 10 | messages and transitions. *) 11 | 12 | Definition getLocal (n : nid) (d : dstatelet) : heap := 13 | match find n (dstate d) with 14 | | Some h => h 15 | | None => Unit 16 | end. 17 | 18 | Lemma getLocalU n m d s : 19 | valid (dstate d) -> m \in dom (dstate d) -> 20 | getLocal n d = (getLocal n {| dstate := upd m (getLocal m d) (dstate d); dsoup := s |}). 21 | Proof. 22 | move=>V H2; move/um_eta: (H2)=>[v2][F2 _]. 23 | rewrite /getLocal F2/=; case X: (n == m); last by rewrite findU X/=. 24 | by move/eqP: X=>X; subst m; rewrite findU eqxx/=V F2. 25 | Qed. 26 | 27 | (* Definition castEqX T (t t' : eqTypeX) (r : t = t') (e : T t) := *) 28 | (* match r in (_ = t') return T t' with erefl => e end. *) 29 | 30 | (* Definition eqcEqX X m' (r : m' = m') (e : X m') : castEqX r e = e. *) 31 | (* Proof. by move: r; apply: Streicher_K. Qed. *) 32 | 33 | Module Coherence. 34 | 35 | Section CohDef. 36 | 37 | (* Represent nodes as a decidable predicate, 38 | which depends on the state *) 39 | Variable nodes: dstatelet -> pred nid. 40 | 41 | Notation protocol_soup := (soup (TaggedMessage)). 42 | 43 | Structure mixin_of (coh : Pred dstatelet) := Mixin { 44 | _ : forall d, coh d -> valid (dstate d); 45 | _ : forall d, coh d -> valid (dsoup d); 46 | _ : forall d, coh d -> dom (dstate d) =i nodes d; 47 | }. 48 | 49 | End CohDef. 50 | 51 | Section ClassDef. 52 | 53 | Variable nodes: dstatelet -> pred nid. 54 | 55 | Notation class_of := mixin_of (only parsing). 56 | 57 | Structure cohpred : Type := Pack {sort : dstatelet -> Prop; 58 | _ : class_of nodes sort}. 59 | Local Coercion sort : cohpred >-> Funclass. 60 | 61 | Variables (T : dstatelet -> Prop) (cT : cohpred). 62 | 63 | Definition class := let: Pack _ c as cT' := cT 64 | return class_of nodes cT' in c. 65 | 66 | Definition pack c := @Pack T c. 67 | Definition clone := fun c & T = cT & phant_id (pack c) cT => pack c. 68 | 69 | End ClassDef. 70 | 71 | Module Exports. 72 | Section Exports. 73 | 74 | Variable Lstate : Type. 75 | Variable nodes: dstatelet -> pred nid. 76 | 77 | Coercion sort : cohpred >-> Funclass. 78 | Definition cohpred := cohpred. 79 | Definition CohPredMixin := Mixin. 80 | Definition CohPred T m := (@pack T m). 81 | 82 | Notation "[ 'cohPredMixin' 'of' T ]" := (class _ : mixin_of T) 83 | (at level 0, format "[ 'cohPredMixin' 'of' T ]") : form_scope. 84 | Notation "[ 'cohpred' 'of' T 'for' C ]" := (@clone T C _ (erefl _) id) 85 | (at level 0, format "[ 'cohpred' 'of' T 'for' C ]") : form_scope. 86 | Notation "[ 'cohpred' 'of' T ]" := (@clone T _ _ (erefl _) id) 87 | (at level 0, format "[ 'cohpred' 'of' T ]") : form_scope. 88 | 89 | Canonical cohpred_PredType := mkPredType (@sort nodes). 90 | 91 | Variable coh : cohpred nodes. 92 | 93 | Lemma cohVl d : d \In coh -> valid (dstate d). 94 | Proof. by case: coh=>p [H1 H2 H3]; apply: H1. Qed. 95 | 96 | Lemma cohVs d : d \In coh -> valid (dsoup d). 97 | Proof. by case: coh=>p [H1 H2 H3]; apply: H2. Qed. 98 | 99 | Lemma cohDom d : d \In coh -> dom (dstate d) =i nodes d. 100 | Proof. by case: coh=>p [H1 H2 H3]; apply: H3. Qed. 101 | 102 | End Exports. 103 | End Exports. 104 | End Coherence. 105 | 106 | Export Coherence.Exports. 107 | 108 | Module Transitions. 109 | Section Transitions. 110 | 111 | Variable nodes: dstatelet -> pred nid. 112 | 113 | Variable coh : cohpred nodes. 114 | 115 | Notation lstate := heap%type. 116 | 117 | Definition send_step_t (send_safe : nid -> nid -> dstatelet -> seq nat -> Prop) := 118 | forall (this to : nid) (d : dstatelet) 119 | (msg : seq nat) (pf : send_safe this to d msg), 120 | option lstate. 121 | 122 | Definition s_step_coh_t t_snd 123 | (send_safe : nid -> nid -> dstatelet -> seq nat -> Prop) 124 | (send_step : send_step_t send_safe) := 125 | forall this to d msg (pf : send_safe this to d msg) b, 126 | let: f := dstate d in 127 | let: s := dsoup d in 128 | Some b = @send_step this to d msg pf -> 129 | let: f' := upd this b f in 130 | let: tms := TMsg t_snd msg in 131 | let: s' := (post_msg s (Msg tms this to true)).1 in 132 | coh (DStatelet f' s'). 133 | 134 | Structure send_trans := SendTrans 135 | { 136 | t_snd : nat; 137 | 138 | send_safe : nid -> nid -> dstatelet -> seq nat -> Prop; 139 | s_safe_coh : forall this to d m, send_safe this to d m -> coh d; 140 | s_safe_in : forall this to d m, send_safe this to d m -> 141 | this \in nodes d /\ to \in nodes d; 142 | 143 | (* Send is a partially defined function, initially it is allowed 144 | to observe the entire statelet d to avoif a complex 145 | precondition *) 146 | send_step : send_step_t send_safe; 147 | 148 | s_safe_def : forall this to d msg, 149 | send_safe this to d msg <-> 150 | exists b pf, @send_step this to d msg pf = Some b; 151 | 152 | (* Sending preserves coherence *) 153 | s_step_coh : s_step_coh_t t_snd send_step 154 | }. 155 | 156 | 157 | Definition receive_step_t := 158 | forall (this from: nid) (m : seq nat) 159 | (d : dstatelet) (pf : coh d) 160 | (pf' : this \in nodes d), lstate. 161 | 162 | Definition r_step_coh_t (msg_wf : forall d, coh d -> nid -> nid -> TaggedMessage -> bool) 163 | t_rcv (receive_step : receive_step_t) := 164 | forall (d : dstatelet) from this i (C : coh d) (pf' : this \in nodes d) 165 | (m : TaggedMessage), 166 | let: f := dstate d in 167 | let: s := dsoup d in 168 | this \in dom f -> 169 | find i s = Some (Msg m from this true) -> 170 | msg_wf d C this from m -> tag m = t_rcv -> 171 | let: loc' := receive_step this from m d C pf' in 172 | let: s'' := consume_msg s i in 173 | let: f' := upd this loc' f in 174 | coh (DStatelet f' s''). 175 | 176 | 177 | Structure receive_trans := ReceiveTrans 178 | { 179 | t_rcv : nat; 180 | 181 | msg_wf : forall d, coh d -> nid -> nid -> TaggedMessage -> bool; 182 | 183 | (* The semantics ensures the "well-formedness" of a message 184 | being reveived. The following transition, defined as a total 185 | function, is only executed if m satisfies the msg_wf 186 | check. However, we still need the coherence passed in order 187 | to provide facilities for dependently-typed programming. *) 188 | receive_step : receive_step_t; 189 | 190 | (* Receiving preserves coherence *) 191 | r_step_coh : r_step_coh_t msg_wf t_rcv receive_step 192 | }. 193 | 194 | End Transitions. 195 | 196 | Module Exports. 197 | 198 | Definition SendTrans := SendTrans. 199 | Definition send_trans := send_trans. 200 | Definition ReceiveTrans := ReceiveTrans. 201 | Definition receive_trans := receive_trans. 202 | 203 | Definition t_snd := t_snd. 204 | Definition send_safe := send_safe. 205 | Definition send_step := send_step. 206 | Definition send_step_t := send_step_t. 207 | 208 | Definition s_safe_coh := s_safe_coh. 209 | Definition s_safe_in := s_safe_in. 210 | Definition s_safe_def := s_safe_def. 211 | Definition s_step_coh := s_step_coh. 212 | Definition s_step_coh_t := s_step_coh_t. 213 | 214 | Definition t_rcv := t_rcv. 215 | Definition msg_wf := msg_wf. 216 | 217 | Definition receive_step := receive_step. 218 | Definition receive_step_t := receive_step_t. 219 | Definition r_step_coh := r_step_coh. 220 | Definition r_step_coh_t := r_step_coh_t. 221 | 222 | End Exports. 223 | 224 | End Transitions. 225 | 226 | Export Transitions.Exports. 227 | 228 | Module Protocols. 229 | Section Protocols. 230 | 231 | Definition snd_tags {nodes} {coh : cohpred nodes} 232 | (sts : seq (send_trans coh)) := 233 | map (@t_snd nodes _) sts. 234 | 235 | Definition rcv_tags {nodes} {coh : cohpred nodes} (sts : seq (receive_trans coh)) := 236 | map (@t_rcv nodes _) sts. 237 | 238 | Structure protocol := Protocol { 239 | nodes: dstatelet -> pred nid; 240 | plab : Label; 241 | coh : cohpred nodes ; 242 | snd_trans : seq (send_trans coh); 243 | rcv_trans : seq (receive_trans coh); 244 | 245 | (* All transition tags are unique *) 246 | snd_uniq : uniq (snd_tags snd_trans); 247 | rcv_uniq : uniq (rcv_tags rcv_trans); 248 | }. 249 | 250 | End Protocols. 251 | 252 | Module Exports. 253 | Section Exports. 254 | 255 | Definition protocol := protocol. 256 | Definition Protocol := Protocol. 257 | Definition plab := plab. 258 | Definition nodes := nodes. 259 | Definition coh := coh. 260 | Definition snd_trans := snd_trans. 261 | Definition rcv_trans := rcv_trans. 262 | 263 | (* Tags for transitions *) 264 | Definition snd_tags p := snd_tags (snd_trans p). 265 | Definition rcv_tags p := rcv_tags (rcv_trans p). 266 | 267 | Definition snd_uniq := snd_uniq. 268 | Definition rcv_uniq := rcv_uniq. 269 | 270 | Definition cohMT d := d = empty_dstatelet. 271 | 272 | Lemma pred0v1 d: cohMT d -> valid (dstate d). 273 | Proof. 274 | by rewrite /cohMT=>->; apply: valid_mt_state. 275 | Qed. 276 | 277 | Lemma pred0v2 d: cohMT d -> valid (dsoup d). 278 | Proof. 279 | by rewrite /cohMT=>->; apply: valid_mt_soup. 280 | Qed. 281 | 282 | Lemma pred0v3 d: cohMT d -> dom (dstate d) =i [::]. 283 | Proof. by rewrite /cohMT=>->; apply: mt_nodes. Qed. 284 | 285 | Definition EmptyProtMixin := CohPredMixin pred0v1 pred0v2 pred0v3. 286 | Definition empty_coh := CohPred EmptyProtMixin. 287 | 288 | Lemma snd_uniq0 {nodes} {coh : cohpred nodes} : 289 | uniq (@Protocols.snd_tags _ coh ([::] : seq (send_trans coh))). 290 | Proof. by []. Qed. 291 | 292 | Lemma rcv_uniq0 {nodes} {coh : cohpred nodes} : 293 | uniq (@Protocols.rcv_tags nodes _ ([::] : seq (receive_trans coh))). 294 | Proof. by []. Qed. 295 | 296 | Definition EmptyProt i : protocol := 297 | @Protocol (fun _ => pred0) i empty_coh [::] [::] snd_uniq0 rcv_uniq0. 298 | 299 | End Exports. 300 | End Exports. 301 | 302 | End Protocols. 303 | 304 | Export Protocols.Exports. 305 | 306 | (* TODO: switch to dynamic values to avoid constant casts *) 307 | -------------------------------------------------------------------------------- /theories/Core/Rely.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX Protocols Worlds NetworkSem. 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | (* Rely-transitions of the network in the presence of the given world *) 10 | 11 | Section Rely. 12 | 13 | Variable w : world. 14 | Variable this: nid. 15 | 16 | Notation getl := (getLocal). 17 | Notation gets := getStatelet. 18 | Notation getp := (@getProtocol _ w). 19 | 20 | (* The following is the "rely" relation *) 21 | Fixpoint network_rely' n s1 s2 := 22 | if n is n'.+1 23 | then exists z s3, 24 | [/\ this != z, network_step w z s1 s3 & network_rely' n' s3 s2] 25 | else s1 = s2 /\ s1 \In Coh w. 26 | 27 | Definition network_rely s1 s2 := exists n, network_rely' n s1 s2. 28 | 29 | (* Basic properties: reflexivity and transitifity *) 30 | Lemma rely_refl s : s \In Coh w -> network_rely s s. 31 | Proof. move=>H; by exists 0. Qed. 32 | 33 | Lemma rely_trans s1 s2 s3 : 34 | network_rely s1 s2 -> network_rely s2 s3 -> network_rely s1 s3. 35 | Proof. 36 | case=>n; elim: n s1 s2=>[?? [<-]|n Hi s1 s2]//. 37 | move=>[z][s4][N]H1 H2 H3; case: (Hi _ _ H2 H3)=>m H4. 38 | by exists m.+1, z, s4. 39 | Qed. 40 | 41 | Lemma rely_coh' n s1 s2 : 42 | network_rely' n s1 s2 -> Coh w s1 /\ Coh w s2. 43 | Proof. 44 | by elim:n s1=>[s1[<-]|n Hi s1]//=[z][s3][N]/step_coh[]H1 H2 /Hi[]. 45 | Qed. 46 | 47 | Lemma rely_coh s1 s2 : 48 | network_rely s1 s2 -> Coh w s1 /\ Coh w s2. 49 | Proof. by case=>n/rely_coh'. Qed. 50 | 51 | (* With the rely-steps, this' local is untouched *) 52 | Lemma rely_loc s1 s2 l: 53 | network_rely s1 s2 -> find this (dstate (gets s1 l)) = find this (dstate (gets s2 l)). 54 | Proof. 55 | case=>n; elim: n s1=>/=[s1 [E C]|n Ih s1 [z][s''][N]S R]; first by subst s2. 56 | by rewrite -(@Ih s'' R); clear R Ih; apply: (step_is_local l S N). 57 | Qed. 58 | 59 | Lemma step_consume_other l s s' m tm from z: 60 | this != z -> network_step w z s s' -> 61 | find m (dsoup (gets s l)) = Some (Msg tm from this true) -> 62 | find m (dsoup (gets s' l)) = Some (Msg tm from this true). 63 | Proof. 64 | move=>N S. 65 | case: (S)=>[[H1 <-] | k st _ to a loc' pf D C S' Pf Spf ->/= | 66 | k rt _ m' from' pf D C tm' T [H2 H3->/=]]//; 67 | move: (coh_coh l C); 68 | rewrite /gets findU; case B: (l == k)=>//=; move/eqP: B=>B; subst k; 69 | rewrite (stepV1 S). 70 | - case: (dom_find l s)=>[|d->_]; first by move/find_none; rewrite D. 71 | move=> C' E; rewrite -E; rewrite joinC findPtUn2; last first. 72 | + rewrite joinC valid_fresh; apply: (cohVs C'). 73 | case: ifP=>///eqP; move/find_some: E=>F Z. 74 | by move/negbTE: (dom_fresh (dsoup d)); rewrite -Z F. 75 | move: H2=>{H3}; move: (coh_s l C) pf; rewrite /gets. 76 | case: (dom_find l s)=>[|d-> _ C' pf H2 _]; first by move/find_none; rewrite D. 77 | case B: (m == m'); do[move/eqP: B=>Z; subst|move=>H]. 78 | - by rewrite H2; case=>Z1 Z2 Z3; subst z; move/negbTE: N; rewrite eqxx. 79 | (* Well, this should be easier *) 80 | rewrite /consume_msg; case B: (find m' (dsoup d))=>[v|]//= H. 81 | by rewrite findU; move/eqP/negbTE: Z=>->/=. 82 | Qed. 83 | 84 | (* Nobody consumes my messages *) 85 | Lemma rely_consume_other l s s' m tm from: 86 | network_rely s s' -> 87 | find m (dsoup (gets s l)) = Some (Msg tm from this true) -> 88 | find m (dsoup (gets s' l)) = Some (Msg tm from this true). 89 | Proof. 90 | case=>n; elim: n s=>/=[?[-> C]|n Ih s [z][s''][N] S R E]//. 91 | by rewrite -(@Ih s'' R)=>//; clear Ih; apply: (step_consume_other N S). 92 | Qed. 93 | 94 | Lemma step_send_other l s s' m tm to b z: 95 | this != z -> network_step w z s s' -> 96 | find m (dsoup (gets s' l)) = Some (Msg tm this to b) -> 97 | exists b', find m (dsoup (gets s l)) = Some (Msg tm this to b') /\ (b -> b'). 98 | Proof. 99 | move=>N S. 100 | case: (S)=>[[H1 <-->] | k st _ to' a loc' pf D C S' Ph Spf ->/= | 101 | k rt _ m' from' pf D C tm' T [H2 H3->/=]]//; do?[by exists b]; 102 | move: (coh_coh l C); 103 | rewrite /gets findU; case B: (l == k)=>//=; do?[by exists b]; 104 | move/eqP: B=>B; subst k; rewrite (stepV1 S). 105 | - case: (dom_find l s)=>[|d->_ C']; first by move/find_none; rewrite D. 106 | rewrite joinC findPtUn2; last first. 107 | + rewrite joinC valid_fresh; apply: (cohVs C'). 108 | case B: (m == fresh (dsoup d)); first by case=>_ Z _; subst; move/eqP: N. 109 | by move=>H; exists b; split. 110 | move: H2; move: (coh_s l C) pf; rewrite /gets; 111 | case B: (m == m'); do[move/eqP: B=>Z; subst m'|]; 112 | case: (dom_find l s)=>[|d->_ C' pf H2 _]; do?[by move=>->? ? _; rewrite/consume_msg !find0E]. 113 | - rewrite /consume_msg; case B: (find m (dsoup d))=>[v|]; last by rewrite B. 114 | rewrite /mark_msg findU eqxx/= (cohVs C')/==>E; rewrite B in H2; clear B. 115 | case: v H2 E=>c x y a; case=>Z1 Z2 Z3 Z4; subst c x y a=>/=. 116 | by case=>Z1 Z2 Z3 Z4; subst b to from' tm'; exists true; split. 117 | rewrite/consume_msg; case B': (find m' (dsoup d))=>[v|]; last by exists b. 118 | by rewrite findU B/==>->; exists b. 119 | Qed. 120 | 121 | (* A backwards lemma: no one can send messages on my behalf, i.e., no new messages appear *) 122 | Lemma rely_send_other l s s' m tm to b: 123 | network_rely s s' -> 124 | find m (dsoup (gets s' l)) = Some (Msg tm this to b) -> 125 | exists b', find m (dsoup (gets s l)) = Some (Msg tm this to b') /\ (b -> b'). 126 | Proof. 127 | case=>n; elim: n s=>/=[?[-> C]|n Ih s [z][s''][N] S R E]//; first by exists b. 128 | case: (@Ih s'' R E)=>b''[H1 H2]. 129 | by case: (step_send_other N S H1)=>c[H3 H4]; exists c; split=>// Z; auto. 130 | Qed. 131 | 132 | 133 | Lemma step_send_other' l s s' m tm to b z: 134 | this != z -> network_step w z s s' -> 135 | find m (dsoup (gets s l)) = Some (Msg tm this to b) -> 136 | exists b', find m (dsoup (gets s' l)) = Some (Msg tm this to b') /\ (b' -> b). 137 | Proof. 138 | move=>N S. 139 | case: (S)=>[[H1 <-->] | k st _ to' a loc' pf D C S' Ph Spf ->/= | 140 | k rt _ m' from' pf D C tm' T [H2 H3->/=]]//; do?[by exists b]; 141 | move: (coh_coh l C); 142 | rewrite /gets findU; case B: (l == k)=>//=; do?[by exists b]; 143 | move/eqP: B=>B; subst k; rewrite (stepV1 S). 144 | - case: (dom_find l s)=>[|d->_ C']; first by move/find_none; rewrite D. 145 | rewrite joinC findPtUn2; last first. 146 | + rewrite joinC valid_fresh; apply: (cohVs C'). 147 | case B: (m == fresh (dsoup d)); last by move=>->; exists b. 148 | move/eqP:B=>B; subst m; move: (dom_fresh (dsoup d))=>B. 149 | by move/find_some=>E; rewrite E in B. 150 | move: H2; move: (coh_s l C) pf; rewrite /gets; 151 | case B: (m == m'); do[move/eqP: B=>Z; subst m'|]; 152 | case: (dom_find l s)=>[|d->_ C' pf H2 _]; do?[by move=>->? ? _; rewrite/consume_msg !find0E]. 153 | - rewrite /consume_msg; case B: (find m (dsoup d))=>[v|]; last by rewrite B. 154 | rewrite /mark_msg findU eqxx/= (cohVs C')/==>E; rewrite B in H2; clear B. 155 | case: v H2 E=>c x y a; case=>Z1 Z2 Z3 Z4; subst c x y a=>/=. 156 | by case=>Z1 Z2 Z3 Z4; subst b to from' tm'; exists false. 157 | rewrite/consume_msg; case B': (find m' (dsoup d))=>[v|]; last by exists b. 158 | by rewrite findU B/==>->; exists b. 159 | Qed. 160 | 161 | (* A forward lemma: messages sent on my behalf don't disappear but might get consumed *) 162 | Lemma rely_send_other' l s s' m tm to b: 163 | network_rely s s' -> 164 | find m (dsoup (gets s l)) = Some (Msg tm this to b) -> 165 | exists b', find m (dsoup (gets s' l)) = Some (Msg tm this to b') /\ (b' -> b). 166 | Proof. 167 | case=>n; elim: n s b; first by move=>s b[Z C]; subst s'; exists b. 168 | move=>n Ih s b [z][s''][N] S R H. 169 | case: (step_send_other' N S H)=>c[H3 H4]. 170 | by case: (@Ih s'' c R H3)=>b'[G1 G2]; exists b'; split=>//; auto. 171 | Qed. 172 | 173 | Notation loc i l := (getLocal this (getStatelet i l)). 174 | Notation msgs i l := (dsoup (getStatelet i l)). 175 | 176 | Lemma rely_loc' l i j : network_rely i j -> loc j l = loc i l. 177 | Proof. 178 | move => R. 179 | now rewrite /getLocal(rely_loc _ R). 180 | Qed. 181 | 182 | End Rely. 183 | 184 | -------------------------------------------------------------------------------- /theories/Core/State.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness DepMaps EqTypeX. 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | (* Shared state, as implemented by the message soup. 10 | 11 | At this point, the implementation is based on top of standard union 12 | maps. This defines the procedure for allocating new messages: just 13 | by taking the next-to-the largest id in the corresponding 14 | batch. Indeed, this is not particularly nice, as it assumes the 15 | _global_ message soup. 16 | 17 | It's not clear at this moment, what will be the best representation 18 | of the soup so it would be in the same time _local_ and also would 19 | allow for th allocation. Perhaps, we should just consider local 20 | soups, ensuring that they all carry distinct labels, and then when 21 | cojoin them, make sure that for clashing message id's protocol 22 | labels are different. 23 | 24 | *) 25 | 26 | Section TaggedMessages. 27 | 28 | Structure TaggedMessage := 29 | TMsg { 30 | tag: nat; 31 | (* Okay, this is a big omissin, but for now I'm sick and tired 32 | to deal with casts everywhere, so for the moment the 33 | contents of the messages are going to be just sequences of 34 | natural number, and it's up to the client-supplied 35 | coherence predicate to restrict them appropriately, relating this thing to tags *) 36 | tms_cont :> seq nat 37 | }. 38 | 39 | End TaggedMessages. 40 | 41 | Section Shared. 42 | 43 | Definition Label := [ordType of nat]. 44 | 45 | (* (Heterogenious) messages are parametrized by 46 | 47 | - lab - protocol Label 48 | - ptype - protocol, defining the content type 49 | - content - the contents of the message 50 | - from/to - IDs of the sender.receiver node 51 | - active - a bit, indicating whether the message hasn't been consumed yet (i.e., read) 52 | 53 | I'm not sure, if we're going to need anything else. *) 54 | Structure msg (mtype : Type) := 55 | Msg {content : mtype; 56 | from : nat; 57 | to : nat; 58 | active : bool }. 59 | 60 | (* Message IDs: pairs Label * id, where Label comes from the protocol. *) 61 | Definition mid := [ordType of nat]. 62 | 63 | (* Message soup (for a specific protocol) is just a partial finite 64 | map from message IDs (mid) to arbitrary Messages. *) 65 | Definition soup : Type := 66 | union_map mid (msg (TaggedMessage)). 67 | 68 | Variables (s: soup) (V: valid s). 69 | 70 | (* Allocating new message in the soup *) 71 | Definition post_msg m : soup * mid := 72 | let: f := fresh s in (s \+ f \\-> m, f). 73 | 74 | Lemma post_valid m : valid (post_msg m).1. 75 | Proof. by rewrite ?valid_fresh. Qed. 76 | 77 | Lemma post_fresh m : (post_msg m).2 \notin dom s. 78 | Proof. by rewrite ?dom_fresh. Qed. 79 | 80 | (* Marking is *) 81 | Definition mark_msg T (m : msg T) : msg T := 82 | Msg (content m) (from m) (to m) false. 83 | 84 | (* Updating the message soup, consuming the message id *) 85 | Definition consume_msg (s : soup) (id : mid) : soup := 86 | let: mr := find id s in 87 | if mr is Some m then upd id (mark_msg m) s else s. 88 | 89 | Definition is_active (id : mid) := 90 | exists m, find id s = Some m /\ active m. 91 | 92 | Definition is_consumed (id : mid) := 93 | exists m, find id s = Some m /\ ~~ active m. 94 | 95 | (* TODO: consumes "truth table" -- three possible scenarios (how to express?) *) 96 | 97 | (* Obvious fact about marking message *) 98 | Lemma find_consume s' (id: mid) m: 99 | valid s' -> find id s' = Some m -> 100 | find id (consume_msg s' id) = Some (mark_msg m). 101 | Proof. by move=>V' E; rewrite/consume_msg E findU eqxx V'/=. Qed. 102 | 103 | Lemma find_mark m s' msg : 104 | valid s' -> find m (consume_msg s' m) = Some msg -> 105 | exists msg', find m s' = Some msg' /\ msg = mark_msg msg'. 106 | Proof. 107 | move=>V'; rewrite /consume_msg; case D: (m \in dom s'). 108 | - move/um_eta: D=>[msg'][->]_; rewrite findU eqxx/= V'. 109 | by case=><-; eexists _. 110 | by case: dom_find (D)=>//->_; move/find_some=>Z; rewrite Z in D. 111 | Qed. 112 | 113 | Lemma mark_other m m' s' : 114 | valid s' -> m' == m = false -> find m' (consume_msg s' m) = find m' s'. 115 | Proof. 116 | move=>V' N; rewrite /consume_msg; case D: (m \in dom s'). 117 | by case: dom_find (D)=>//v->_ _; rewrite findU N. 118 | by case: dom_find (D)=>//->_. 119 | Qed. 120 | 121 | Lemma consume_valid s' m : valid s' -> valid (consume_msg s' m). 122 | Proof. 123 | move=>V'; rewrite /consume_msg; case (find m s')=>//v. 124 | by rewrite /mark_msg validU. 125 | Qed. 126 | 127 | Lemma consumeUn (s': soup) (i : mid) mm 128 | (j : mid) : valid (s' \+ i \\-> mm) -> 129 | consume_msg (s' \+ i \\-> mm) j = 130 | if i == j then s' \+ i \\-> mark_msg mm 131 | else (consume_msg s' j) \+ (i \\-> mm). 132 | Proof. 133 | rewrite ![_ \+ i \\-> _]joinC; rewrite eq_sym. 134 | move=>V'; case B: (j==i); rewrite /consume_msg findPtUn2// B. 135 | - by move/eqP: B=>?; subst j; rewrite updPtUn. 136 | by case X: (find j s')=>//; rewrite updUnL domPt inE eq_sym B. 137 | Qed. 138 | 139 | Notation "'{{' m 'in' s 'at' id '}}'" := (find id s = Some m). 140 | Notation "'{{' m 'in' s '}}'" := (exists id, {{m in s at id}}). 141 | 142 | 143 | 144 | End Shared. 145 | 146 | (* Local per-protocol state with per-node resources *) 147 | Section Local. 148 | 149 | Variable U : Type. 150 | 151 | Definition nid := nat. 152 | 153 | (* Local state of a a protocol is simply a partial map from node ids 154 | to their local contributions, along with the validity of the 155 | cumulative contribution. *) 156 | 157 | Definition lstate_type := union_map [ordType of nid] U. 158 | 159 | End Local. 160 | 161 | (* 162 | Definition um_all {A:ordType} {B} (p : A -> B -> bool) (u : union_map A B) : bool := 163 | um_recf false true (fun k v f rec Hval Hpath => p k v && rec) u. 164 | 165 | Definition um_some {A:ordType} {B} (p : A -> B -> bool) (u : union_map A B) : bool := 166 | um_recf false false (fun k v f rec Hval Hpath => p k v || rec) u. 167 | *) 168 | 169 | Section Statelets. 170 | 171 | (* A particular statelet instance. 172 | The Label and the PCM are the parameters and are defined by the protocol. 173 | The lstate and dsop are subject of the evolution. 174 | *) 175 | Structure dstatelet := 176 | DStatelet { 177 | (* Not sure if it's the best way to represent information 178 | about kinds of messages in this particular dstatelet, but 179 | let's think of tags as of integers for now, so dTagToCont 180 | will map the tags to specific types. *) 181 | 182 | (* Local state for each node as a pair of heaps; first heap is 183 | real, second heap is a ghost one. Let's deal with this 184 | model for now before we figure out how to discharge 185 | equalities in a better way *) 186 | dstate : lstate_type heap; 187 | dsoup : soup 188 | }. 189 | 190 | Fixpoint empty_lstate (ns : seq nid) := 191 | if ns is n :: ns' 192 | then n \\-> Heap.empty \+ (empty_lstate ns') 193 | else Unit. 194 | 195 | (* Definition empty_dstatelet ns : dstatelet := *) 196 | (* @DStatelet (empty_lstate (undup ns)) Unit. *) 197 | 198 | (* Lemma valid_mt_soup ns : valid (dsoup (empty_dstatelet ns)). *) 199 | (* Proof. by rewrite /= valid_unit. Qed. *) 200 | 201 | (* Lemma dom_mt ns : *) 202 | (* valid (empty_lstate (undup ns)) /\ dom (empty_lstate (undup ns)) =i undup ns. *) 203 | (* Proof. *) 204 | (* elim: ns=>//=[|n ns [H1 H2]]; first by rewrite dom0. *) 205 | (* case B: (n \in ns)=>//=; split. *) 206 | (* - by rewrite gen_validPtUn/= H1 H2/=; apply/negbT; rewrite mem_undup. *) 207 | (* move=> z; rewrite um_domPtUn inE/= gen_validPtUn/= H1 H2/=. *) 208 | (* rewrite -mem_undup in B; rewrite B/=. *) 209 | (* case C: (n == z)=>//=; first by rewrite in_cons eq_sym C. *) 210 | (* by rewrite H2 in_cons eq_sym C/=. *) 211 | (* Qed. *) 212 | 213 | (* Lemma valid_mt_state ns : valid (dstate (empty_dstatelet ns)). *) 214 | (* Proof. *) 215 | (* elim:ns=>//=n ns H; case I: (n \in ns)=>//=. *) 216 | (* by rewrite gen_validPtUn H/=; case: (dom_mt ns)=>_->; rewrite mem_undup I. *) 217 | (* Qed. *) 218 | 219 | (* Lemma mt_nodes ns : dom (dstate (empty_dstatelet ns)) =i ns. *) 220 | (* Proof. *) 221 | (* by case: (dom_mt ns)=>_ H2 z; rewrite -mem_undup -H2. *) 222 | (* Qed. *) 223 | 224 | Definition empty_dstatelet : dstatelet := 225 | @DStatelet (empty_lstate [::]) Unit. 226 | 227 | Lemma valid_mt_soup : valid (dsoup empty_dstatelet). 228 | Proof. by rewrite /= valid_unit. Qed. 229 | 230 | Lemma valid_mt_state : valid (dstate empty_dstatelet). 231 | Proof. by rewrite valid_unit. Qed. 232 | 233 | Lemma mt_nodes : dom (dstate empty_dstatelet) =i [::]. 234 | Proof. by rewrite dom0. Qed. 235 | 236 | End Statelets. 237 | 238 | 239 | Module StateGetters. 240 | Section StateGetters. 241 | 242 | Definition state := union_map Label dstatelet. 243 | 244 | (* Retrieve statelet from the state *) 245 | Definition getStatelet (s: state) (i : Label) : dstatelet := 246 | match find i s with 247 | | Some d => d 248 | | None => empty_dstatelet 249 | end. 250 | 251 | End StateGetters. 252 | End StateGetters. 253 | 254 | 255 | Export StateGetters. 256 | -------------------------------------------------------------------------------- /theories/Core/StatePredicates.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX DepMaps. 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | Section SoupPredicates. 10 | 11 | (*****************************************************) 12 | (* Message predicates 13 | 14 | [Valid messages in soup] 15 | 16 | The following generic definition "msg_in_souop" specifies which 17 | messages are considered valid in the specific state and the soup. 18 | 19 | The derived definition come next. 20 | 21 | *) 22 | 23 | Definition msg_in_soup (from to : nid) (criterion : nat -> seq nat -> bool) 24 | (d : soup) : Prop := 25 | (exists! i, exists t c, 26 | find i d = Some (Msg (TMsg t c) from to true)) /\ 27 | forall i t c, 28 | find i d = Some (Msg (TMsg t c) from to true) -> 29 | criterion t c. 30 | 31 | (* Fix specific tag and content *) 32 | Definition msg_spec from to tg cnt := 33 | msg_in_soup from to (fun x y => (x == tg) && (y == cnt)). 34 | 35 | Definition no_msg_from (from : nid) (d : soup) : Prop := 36 | forall i to tms b, find i d = Some (Msg tms from to b) -> b = false. 37 | 38 | Definition no_msg_to (to : nid) (d : soup) : Prop := 39 | forall i from tms b, find i d = Some (Msg tms from to b) -> b = false. 40 | 41 | 42 | Lemma no_msg_from_post (from from' to : nid) (s : soup) tms : 43 | valid s -> 44 | no_msg_from from s -> from' != from -> 45 | no_msg_from from (post_msg s (Msg tms from' to true)).1. 46 | Proof. 47 | move=>V H/negbTE N i to' tms' b/=. 48 | rewrite findUnR ?valid_fresh?V//. 49 | case: ifP; last by move=>_/H. 50 | rewrite domPt inE/==>/eqP Z; subst i. 51 | rewrite findPt/=; case=>Z1 Z2 Z3; subst to' tms' from'. 52 | by rewrite eqxx in N. 53 | Qed. 54 | 55 | Lemma no_msg_from_consume from from' to s i m : 56 | find i s = Some {| content := m; from := from'; to := to; active := true |} -> 57 | valid s -> 58 | no_msg_from from s -> 59 | no_msg_from from (consume_msg s i). 60 | Proof. 61 | move=>F V NM j to' tms b. 62 | case H: (j == i). 63 | - move /eqP in H. subst j. 64 | rewrite (find_consume _ F) //. 65 | by case. 66 | rewrite mark_other//. 67 | exact: NM. 68 | Qed. 69 | 70 | Definition no_msg_from_to from to (d : soup) := 71 | forall i tms b, 72 | find i d = Some (Msg tms from to b) -> b = false. 73 | 74 | Lemma no_msg_from_to_consume from to s i: 75 | valid s -> 76 | no_msg_from_to from to s -> 77 | no_msg_from_to from to (consume_msg s i). 78 | Proof. 79 | move=>V H m tms b . 80 | rewrite /consume_msg; case: (find i s); last by move=>F; apply: (H m tms b F). 81 | move=>ms; case B: (m == i). 82 | - by move/eqP: B=>B; subst m; rewrite findU eqxx/= V; case. 83 | by rewrite findU B/==>/(H m tms b). 84 | Qed. 85 | 86 | Lemma msg_spec_consume s from to tg cnt cnt' i : 87 | valid s -> 88 | find i s = Some {| content := TMsg tg cnt'; 89 | from := from; to := to; active := true |} -> 90 | msg_spec from to tg cnt s -> 91 | no_msg_from_to from to (consume_msg s i). 92 | Proof. 93 | move=>V E[][j][[t][c]]F H1 H2. 94 | move=>m tms b; rewrite /consume_msg; move: (find_some E). 95 | case: dom_find=>// msg->_ _; case B: (m == i). 96 | - by move/eqP: B=>B; subst m; rewrite findU eqxx/= V; case. 97 | have X: j = i by apply: (H1 i); exists tg, cnt'. 98 | subst j; rewrite findU B/=; case: b=>// E'. 99 | suff X: i = m by subst i; rewrite eqxx in B. 100 | by apply: (H1 m); case: tms E'=>t' c' E'; exists t', c'. 101 | Qed. 102 | 103 | Lemma msg_specE_consume s pt from to to' tg cnt i m : 104 | valid s -> 105 | find i s = 106 | Some {| content := m; from := from; to := to'; active := true |} -> 107 | (pt != from) || (to != to') -> 108 | msg_spec pt to tg cnt s -> 109 | msg_spec pt to tg cnt (consume_msg s i). 110 | Proof. 111 | move=>V E N[][j][[t][c]]F H1 H2. 112 | have Nij: i != j. 113 | - case H: (i == j)=>//. 114 | move/eqP in H. subst i. 115 | move: E. rewrite F. case. intros. subst. 116 | move: N=>/orP[]/eqP; congruence. 117 | split. 118 | - exists j. 119 | split. 120 | + exists t, c. rewrite mark_other// eq_sym. by apply /negbTE. 121 | + move => x [t'][c']. 122 | case H: (x == i). 123 | * move /eqP in H. subst x. 124 | by rewrite (find_consume _ E)//. 125 | * rewrite mark_other//. 126 | eauto. 127 | - move=>k t' c'. 128 | case H: (k == i). 129 | + move /eqP in H. subst. 130 | rewrite (find_consume _ E) //. 131 | + rewrite mark_other//. 132 | eauto. 133 | Qed. 134 | 135 | Lemma msg_specE_consume1 s pt from to to' tg cnt i m : 136 | valid s -> 137 | find i s = 138 | Some {| content := m; from := from; to := to'; active := true |} -> 139 | (pt != from) -> 140 | msg_spec pt to tg cnt s -> 141 | msg_spec pt to tg cnt (consume_msg s i). 142 | Proof. 143 | intros. 144 | eapply msg_specE_consume; eauto. 145 | apply /orP; auto. 146 | Qed. 147 | 148 | Lemma msg_specE_consume2 s pt from to to' tg cnt i m : 149 | valid s -> 150 | find i s = 151 | Some {| content := m; from := from; to := to'; active := true |} -> 152 | (to != to') -> 153 | msg_spec pt to tg cnt s -> 154 | msg_spec pt to tg cnt (consume_msg s i). 155 | Proof. 156 | intros. 157 | eapply msg_specE_consume; eauto. 158 | apply /orP; auto. 159 | Qed. 160 | 161 | Definition no_msg_from_imp from to d : 162 | no_msg_from from d -> no_msg_from_to from to d. 163 | Proof. by move=>H i; move: (H i to). Qed. 164 | 165 | 166 | Lemma no_msg_from_toE from to s tms to': 167 | valid s -> 168 | no_msg_from_to from to s -> to == to' = false -> 169 | no_msg_from_to from to (post_msg s (Msg tms from to' true)).1. 170 | Proof. 171 | move=>V H X/= i m b; rewrite findUnR ?valid_fresh?V//. 172 | case: ifP; last by move=>_/H. 173 | rewrite domPt inE/==>/eqP Z; subst i. 174 | by rewrite findPt/=; case=>_ Z; subst to'; rewrite eqxx in X. 175 | Qed. 176 | 177 | Lemma no_msg_from_toE' from to s tms from' to': 178 | valid s -> 179 | no_msg_from_to from to s -> from' == from = false -> 180 | no_msg_from_to from to (post_msg s (Msg tms from' to' true)).1. 181 | Proof. 182 | move=>V H X/= i m b; rewrite findUnR ?valid_fresh?V//. 183 | case: ifP; last by move=>_/H. 184 | rewrite domPt inE/==>/eqP Z; subst i. 185 | by rewrite findPt/=; case=>Z' Z; subst from'; rewrite eqxx in X. 186 | Qed. 187 | 188 | Lemma msg_specE s from to tg cnt : 189 | valid s -> 190 | no_msg_from_to from to s -> 191 | msg_spec from to tg cnt (post_msg s (Msg (TMsg tg cnt) from to true)).1. 192 | Proof. 193 | move=>V H; split=>/=; last first. 194 | - move=>i t c; rewrite findUnR ?valid_fresh?V//. 195 | case: ifP; last by move=>_/H. 196 | rewrite domPt inE/==>/eqP Z; subst i. 197 | by rewrite findPt/=; case=>E Z; subst c t; rewrite !eqxx. 198 | exists (fresh s); split=>[|z[t][c]]. 199 | - exists tg, cnt; rewrite findUnR ?valid_fresh?V//. 200 | by rewrite domPt inE eqxx/=findPt/=. 201 | rewrite findUnR ?valid_fresh?V// domPt !inE/=. 202 | by case: ifP=>[|_/H]//; move/eqP=>->. 203 | Qed. 204 | 205 | Lemma msg_specE' s from to to' tg cnt tms : 206 | valid s -> to == to' = false -> 207 | msg_spec from to tg cnt s -> 208 | msg_spec from to tg cnt (post_msg s (Msg tms from to' true)).1. 209 | Proof. 210 | move=>V N H; split=>//=; last first. 211 | - move=>i t c; rewrite findUnR ?valid_fresh?V//. 212 | rewrite domPt inE/=; case:ifP; last by move=>_; move/(proj2 H). 213 | move/eqP=>Z; subst i; rewrite findPt/=; case=>_ Z. 214 | by subst to'; rewrite eqxx in N. 215 | case: (H)=>H' _; case: H'=>i; case=>[[t]][c] U1 U2. 216 | exists i; split=>//. 217 | - exists t, c; rewrite findUnR ?valid_fresh?V//. 218 | rewrite domPt inE/=; case:ifP=>//. 219 | move/eqP=>Z; subst i. 220 | by move/find_some: U1=>E; move:(dom_fresh s); rewrite E. 221 | move=>z[t'][c']; rewrite findUnR ?valid_fresh?V//. 222 | rewrite domPt inE/=; case:ifP=>//; last first. 223 | - by move=>_ G; apply: (U2 z); exists t', c'. 224 | move/eqP=>Z; subst z. 225 | rewrite findPt/=; case=>Z1 Z2. 226 | by subst to'; rewrite eqxx in N. 227 | Qed. 228 | 229 | Lemma msg_specE'' s from from' to to' tg cnt tms : 230 | valid s -> from == from' = false -> 231 | msg_spec from to tg cnt s -> 232 | msg_spec from to tg cnt (post_msg s (Msg tms from' to' true)).1. 233 | Proof. 234 | move=>V N H; split=>//=; last first. 235 | - move=>i t c; rewrite findUnR ?valid_fresh?V//. 236 | rewrite domPt inE/=; case:ifP; last by move=>_; move/(proj2 H). 237 | move/eqP=>Z; subst i; rewrite findPt/=; case=>_ Z. 238 | by subst from'; rewrite eqxx in N. 239 | case: (H)=>H' _; case: H'=>i; case=>[[t]][c] U1 U2. 240 | exists i; split=>//. 241 | - exists t, c; rewrite findUnR ?valid_fresh?V//. 242 | rewrite domPt inE/=; case:ifP=>//. 243 | move/eqP=>Z; subst i. 244 | by move/find_some: U1=>E; move:(dom_fresh s); rewrite E. 245 | move=>z[t'][c']; rewrite findUnR ?valid_fresh?V//. 246 | rewrite domPt inE/=; case:ifP=>//; last first. 247 | - by move=>_ G; apply: (U2 z); exists t', c'. 248 | move/eqP=>Z; subst z. 249 | rewrite findPt/=; case=>Z1 Z2. 250 | by subst from'; rewrite eqxx in N. 251 | Qed. 252 | 253 | End SoupPredicates. 254 | 255 | (************************************************************) 256 | (* List lemmas *) 257 | (************************************************************) 258 | 259 | Lemma has_all_true xs (ps : seq nid) x: 260 | perm_eq [seq i.1 | i <- xs] ps -> 261 | all id [seq i.2 | i <- xs] -> 262 | x \in ps -> (x, true) \in xs. 263 | Proof. 264 | move=>P A D; move: (perm_mem P x). 265 | rewrite D=>/mapP[z] I Z; subst x. 266 | rewrite all_map/= in A; move/allP: A=>/(_ z I)/=<-. 267 | by rewrite -surjective_pairing. 268 | Qed. 269 | 270 | Lemma has_some_false (xs : seq (nid * bool)) ps x: 271 | perm_eq [seq i.1 | i <- xs] ps -> 272 | x \in ps -> exists b, (x, b) \in xs. 273 | Proof. 274 | move=>P D; move: (perm_mem P x). 275 | rewrite D=>/mapP[z] I Z; subst x. 276 | by exists z.2; rewrite -surjective_pairing. 277 | Qed. 278 | 279 | (********************************************************) 280 | (*** More elaborated versions of the same predicates ***) 281 | (********************************************************) 282 | 283 | Definition no_msg_from_to' from to 284 | (criterion : nat -> seq nat -> bool) (d : soup) := 285 | forall i t c, 286 | find i d = Some (Msg (TMsg t c) from to true) -> 287 | ~~criterion t c. 288 | 289 | Lemma no_msg_from_to_consume' from to cond s i: 290 | valid s -> 291 | no_msg_from_to' from to cond s -> 292 | no_msg_from_to' from to cond (consume_msg s i). 293 | Proof. 294 | move=>V H m t c . 295 | rewrite /consume_msg; case: (find i s); last by move=>F; apply: (H m t c F). 296 | move=>ms; case B: (m == i). 297 | - by move/eqP: B=>B; subst m; rewrite findU eqxx/= V. 298 | by rewrite findU B/==>/(H m t c). 299 | Qed. 300 | 301 | (* Lemma msg_spec_consume' s from to tg cnt cond i : *) 302 | (* valid s -> *) 303 | (* find i s = Some {| content := TMsg tg cnt; *) 304 | (* from := from; to := to; active := true |} -> *) 305 | (* msg_in_soup from to cond s -> *) 306 | (* no_msg_from_to' from to cond (consume_msg s i). *) 307 | (* Proof. *) 308 | (* move=>V E[][j][[t][c]]F H1 H2. *) 309 | (* move=>m t' c'; rewrite /consume_msg; move: (find_some E). *) 310 | (* case: dom_find=>// msg->_ _; case B: (m == i). *) 311 | (* - by move/eqP: B=>B; subst m; rewrite findU eqxx/= V. *) 312 | (* have X: j = i by apply: (H1 i); exists tg, cnt. *) 313 | (* subst j; rewrite findU B/=. case: b=>// E' _. *) 314 | (* suff X: i = m by subst i; rewrite eqxx in B. *) 315 | (* by apply: (H1 m); exists t', c'. *) 316 | (* Qed. *) 317 | -------------------------------------------------------------------------------- /theories/Core/While.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX DepMaps Protocols. 5 | From DiSeL Require Import Worlds NetworkSem Rely Actions Injection. 6 | From DiSeL Require Import Process Always HoareTriples InferenceRules. 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Import Prenex Implicits. 10 | Obligation Tactic := idtac. 11 | 12 | Section While. 13 | Variable this : nid. 14 | Variable W : world. 15 | 16 | Variable A B : Type. 17 | Variable cond : B -> bool. 18 | Variable I : A -> cont B. 19 | Variable I_stable : forall a b s0 s1, I a b s0 -> network_rely W this s0 s1 -> I a b s1. 20 | 21 | Notation body_spec' := 22 | (fun b a => binarify (fun s => cond b /\ I a b s) (fun b' s1 => I a b' s1)). 23 | 24 | Notation body_spec := (forall b : B, DTbin this W (logvar (body_spec' b))). 25 | 26 | Variable body : body_spec. 27 | 28 | Definition loop_spec := forall b, 29 | {a : A}, DHT [this, W] 30 | (fun s => I a b s, fun b' s1 => ~~ cond b' /\ I a b' s1). 31 | 32 | Program Definition while b0 : 33 | {a : A}, DHT [this, W] 34 | (fun s => I a b0 s, 35 | fun b' s1 => ~~ cond b' /\ I a b' s1) := 36 | Do (ffix (fun (rec : loop_spec) (b : B) => 37 | Do (if cond b 38 | then (b' <-- body b; 39 | rec b') 40 | else ret _ _ b)) b0). 41 | Next Obligation. 42 | move => b0 rec b. 43 | apply: ghC=>s0 a/= HI0 C. 44 | case: ifP=> Hcond; last by apply: ret_rule=>s1 R1; split;[rewrite Hcond | eauto]. 45 | apply: step. 46 | apply: call_rule'; first by move=> _; exists a. 47 | move=> b' s1 HI1 C1. 48 | apply: (gh_ex (g:=a)). 49 | apply: call_rule'; first by move=>_; apply: HI1. 50 | by move=>x m; case=>//; apply: HI1. 51 | Qed. 52 | 53 | Next Obligation. 54 | move => b0 s0/= HI0. 55 | by apply: call_rule'. 56 | Qed. 57 | 58 | End While. 59 | -------------------------------------------------------------------------------- /theories/Core/Worlds.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX Protocols. 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | Module WorldGetters. 10 | Section WorldGetters. 11 | 12 | (* It's okay to have duplicating nodes in this list *) 13 | 14 | (* World is a dependent partial map of protocols *) 15 | 16 | Definition context := union_map Label protocol. 17 | 18 | (* 19 | The hooks are dependencies between: 20 | 21 | 1. a hook's unique id 22 | 2. a core protocol 23 | 3. a client protocol 24 | 4. a send-transition (represented by its tag) of a client protocol 25 | 26 | *) 27 | Definition hook_domain := [ordType of ((nat * Label) * (Label * nat))%type]. 28 | 29 | (* 30 | 31 | A hook is a constraint from the local state wrt. core protocol (1st 32 | heap argument), relating the local state wrt. the client protocol (2ns 33 | heap argument), message to be sent, and the destination node id. 34 | 35 | *) 36 | Definition hook_type := heap -> heap -> seq nat -> nid -> Prop. 37 | 38 | Definition hooks := union_map hook_domain hook_type. 39 | Definition world := (context * hooks)%type. 40 | 41 | Definition getc (w: world) : context := fst w. 42 | Coercion getc : world >-> context. 43 | 44 | Definition geth (w: world) : hooks := snd w. 45 | Coercion geth : world >-> hooks. 46 | 47 | Variable w : world. 48 | 49 | Variables (p : protocol). 50 | 51 | (* The function is, in fact, partially defined and returns Empty 52 | Protocol for a non-present label. *) 53 | Definition getProtocol i : protocol:= 54 | match find i (getc w) with 55 | | Some p => p 56 | | None => EmptyProt i 57 | end. 58 | 59 | End WorldGetters. 60 | End WorldGetters. 61 | 62 | Export WorldGetters. 63 | 64 | (* Defining coherence of a state with respect to the world *) 65 | 66 | Module Worlds. 67 | 68 | Module Core. 69 | Section Core. 70 | 71 | (* The following definition ties together worlds and states *) 72 | 73 | Definition hooks_consistent (c : context) (h : hooks) : Prop := 74 | forall z lc ls t, ((z, lc), (ls, t)) \in dom h -> 75 | (lc \in dom c) && (ls \in dom c). 76 | 77 | Definition hook_complete w := hooks_consistent (getc w) (geth w). 78 | 79 | Lemma hook_complete0 c : hook_complete (c, Unit). 80 | Proof. by move=>????; rewrite dom0. Qed. 81 | 82 | Definition Coh (w : world) : Pred state := fun s => 83 | let: c := fst w in 84 | let: h := snd w in 85 | [/\ valid w, valid s, hook_complete w, 86 | dom c =i dom s & 87 | forall l, coh (getProtocol w l) (getStatelet s l)]. 88 | 89 | Lemma cohW w s : Coh w s -> valid w. 90 | Proof. by case w=>[c h]; case. Qed. 91 | 92 | Lemma cohS w s : Coh w s -> valid s. 93 | Proof. by case w=>[c h]; case. Qed. 94 | 95 | Lemma cohH w s : Coh w s -> hook_complete w. 96 | Proof. by case w=>[c h]; case. Qed. 97 | 98 | Lemma cohD w s : Coh w s -> dom (getc w) =i dom s. 99 | Proof. by case w=>[c h]; case. Qed. 100 | 101 | Lemma coh_coh w s l : Coh w s -> coh (getProtocol w l) (getStatelet s l). 102 | Proof. by case w=>[c h]; case. Qed. 103 | 104 | (* Now we need to establish a bunch of natural properties with respect 105 | to coherence of worlds and states. *) 106 | 107 | Lemma unit_coh w s : 108 | Coh w s -> w = Unit <-> s = Unit. 109 | Proof. 110 | case: (w)=>[c h]. 111 | case=>V V' Hc E H; split. 112 | case=>Z1 Z2; subst c h; rewrite dom0 in E; last by rewrite (dom0E V'). 113 | move=>Z; subst s; move/andP: V=>/=[V1 V2]. 114 | have Z: c = Unit by apply: (dom0E V1); move=>z; rewrite E dom0. 115 | subst c; suff Z: (h = Unit) by subst h. 116 | simpl in Hc; clear E H V1 V'. 117 | apply: (dom0E V2); move=> x; case X: (x \in dom h)=>//. 118 | by move: x X=>[[z lc] [ls t]]/Hc/andP[]; rewrite !dom0. 119 | Qed. 120 | 121 | Lemma Coh0 (w : world) (s : state) : 122 | w = Unit -> s = Unit -> Coh w s. 123 | Proof. 124 | move=>->->{w s}; split; rewrite ?valid_unit ?dom0=>//=; last first. 125 | - by move=>l; rewrite /getProtocol /getStatelet !find0E. 126 | by move=>z lc ls t; rewrite dom0. 127 | Qed. 128 | 129 | Lemma CohUn (w1 w2 : world) (s1 s2 : state) : 130 | Coh w1 s1 -> Coh w2 s2 -> 131 | valid (w1 \+ w2) -> Coh (w1 \+ w2) (s1 \+ s2). 132 | Proof. 133 | case: w1=>[c1 h1]; case: w2=>[c2 h2]; move=>C1 C2 V. 134 | case: (C1)=>_ G1 K1 J1 H1; case: (C2)=>_ G2 K2 J2 H2. 135 | case/andP: V=>V V'; simpl in V, V'. 136 | have X: valid (s1 \+ s2). 137 | - case: validUn=>//; [by rewrite G1|by rewrite G2|move=>l; rewrite -J1 -J2=>D1 D2]. 138 | by case: validUn V=>//=V1 V2; move/(_ _ D1); rewrite D2. 139 | have Y: dom (c1 \+ c2) =i dom (s1 \+ s2). 140 | - by move=>z; rewrite !domUn !inE/=;rewrite V X/= J1 J2. 141 | have Z1: valid ((c1, h1) \+ (c2, h2)) by rewrite /valid/= V V'. 142 | split=>//[|l]; last first. 143 | - rewrite /getProtocol /getStatelet. 144 | case: (dom_find l (s1 \+ s2))=>[|v]Z. 145 | - by move/find_none: (Z); rewrite -Y; case: dom_find=>//->_; rewrite Z. 146 | move/find_some: (Z)=>D; rewrite Z; rewrite -Y in D=> E. 147 | case: dom_find D=>// p Z' _ _; rewrite Z'. 148 | rewrite findUnL // in Z; rewrite findUnL // J1 in Z'. 149 | by case: ifP Z Z'=>_ F1 F2; [move: (H1 l)|move: (H2 l)]; 150 | rewrite /getProtocol /getStatelet F1 F2. 151 | by move=>z lc ls t/=; rewrite domUn inE=>/andP[_]/orP[];[move/K1|move/K2]; 152 | move/andP=>[A1 A2]; rewrite !domUn !inE A1 A2 V -?(orbC true). 153 | Qed. 154 | 155 | (* Coherence is trivially precise wrt. statelets *) 156 | Lemma coh_prec w: precise (Coh w). 157 | Proof. 158 | move=>s1 s2 t1 t2 V C1 C2. 159 | case: C1 => H1 G1 K1 D1 _. 160 | case: C2 => H2 G2 K2 D2 _ H. 161 | by apply: (@dom_prec _ _ _ _ s1 s2 t1 t2) =>//z; rewrite -D1 -D2. 162 | Qed. 163 | 164 | Lemma locE i n k x y : 165 | k \in dom i -> valid i -> valid (dstate (getStatelet i k)) -> 166 | getLocal n (getStatelet (upd k 167 | {| dstate := upd n x (dstate (getStatelet i k)); 168 | dsoup := y |} i) k) = x. 169 | Proof. 170 | move=>D V; rewrite /getStatelet; case:dom_find (D) =>//d->_ _. 171 | by rewrite findU eqxx/= V /getLocal/= findU eqxx/==>->. 172 | Qed. 173 | 174 | Lemma locE' d n x y : 175 | valid (dstate d) -> 176 | getLocal n {| dstate := upd n x (dstate d); 177 | dsoup := y |} = x. 178 | Proof. by move=>V; rewrite /getLocal findU eqxx/= V. Qed. 179 | 180 | Lemma locU n n' x st s : 181 | n != n' -> 182 | valid st -> 183 | getLocal n {| dstate := upd n' x st; dsoup := s |} = 184 | getLocal n {| dstate := st; dsoup := s |}. 185 | Proof. 186 | by move=>/negbTE N V; rewrite /getLocal findU/= N. 187 | Qed. 188 | 189 | 190 | Section MakeWorld. 191 | 192 | Variable p : protocol. 193 | Notation l := (plab p). 194 | 195 | Definition mkWorld : world := (l \\-> p, Unit). 196 | 197 | Lemma prEq : (getProtocol mkWorld l) = p. 198 | Proof. by rewrite /getProtocol findPt. Qed. 199 | 200 | (* 201 | 202 | Here's an incomplete list of procedures and facts, which might be 203 | useful eventually: 204 | 205 | - Define getters for particular transitions of worlds; 206 | 207 | *) 208 | 209 | End MakeWorld. 210 | 211 | (* TODO: try_recv should be restricted by a set of labels and a set of 212 | protocols *) 213 | End Core. 214 | End Core. 215 | 216 | End Worlds. 217 | 218 | Export Worlds.Core. 219 | -------------------------------------------------------------------------------- /theories/Core/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name DiSeL.Core) 3 | (package coq-disel) 4 | (synopsis "Core framework files for Disel, a separation-style logic for compositional verification of distributed systems in Coq") 5 | (modules :standard \ InjectionOld) 6 | (flags :standard 7 | -w -notation-overridden 8 | -w -local-declaration 9 | -w -duplicate-clear 10 | -w -redundant-canonical-projection 11 | -w -projection-no-head-constant)) 12 | -------------------------------------------------------------------------------- /theories/Examples/Calculator/CalculatorClientLib.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import axioms pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX Protocols Worlds NetworkSem. 5 | From DiSeL Require Import Rely Actions Injection Process Always HoareTriples. 6 | From DiSeL Require Import InferenceRules InductiveInv While. 7 | From DiSeL Require Import SeqLib CalculatorProtocol CalculatorInvariant. 8 | 9 | Obligation Tactic := Tactics.program_simpl. 10 | 11 | Section CalculatorRecieve. 12 | 13 | Variable l : Label. 14 | 15 | Variable f : input -> option nat. 16 | Variable prec : input -> bool. 17 | 18 | Variable cs: seq nid. 19 | Variable cls : seq nid. 20 | (* All nodes *) 21 | Notation nodes := (cs ++ cls). 22 | (* All nodes are unique *) 23 | Hypothesis Huniq : uniq nodes. 24 | 25 | (* Protocol and its transitions *) 26 | 27 | Notation cal := (cal_with_inv l f prec cs cls). 28 | Notation sts := (snd_trans cal). 29 | Notation rts := (rcv_trans cal). 30 | 31 | Notation W := (mkWorld cal). 32 | 33 | (* Variable d : dstatelet. *) 34 | (* Hypothesis C : coh cal d. *) 35 | (* Check proj2 C. *) 36 | (* Check cal_inv_resp _ _ _ _ _ _ _ _ _ _ _ _ (proj1 C)(proj2 C). *) 37 | 38 | Variable cl : nid. 39 | Hypothesis Hc : cl \in cls. 40 | 41 | Program Definition tryrecv_resp_act := act (@tryrecv_action_wrapper W cl 42 | (fun k _ t b => (k == l) && (t == resp)) _). 43 | Next Obligation. by case/andP:H=>/eqP->; rewrite domPt inE/=. Qed. 44 | 45 | Notation loc i := (getLocal cl (getStatelet i l)). 46 | Notation st := (ptr_nat 1). 47 | 48 | Export CalculatorProtocol. 49 | 50 | (* The following spec relates outstanding requests in 51 | pre/postconditions and also ensures that we've got the right 52 | answer. *) 53 | Program Definition tryrecv_resp : 54 | {rs : reqs}, DHT [cl, W] 55 | (fun i => loc i = st :-> rs, 56 | fun (r : option perm) m => 57 | match r with 58 | | Some (from, _, ms) => 59 | let v := head 0 ms in 60 | let args := behead ms in 61 | exists rs' : reqs, 62 | [/\ loc m = st :-> rs', 63 | perm_eq rs ((cl, from, args) :: rs') & 64 | f args = Some v] 65 | | None => loc m = st :-> rs 66 | end) 67 | := Do tryrecv_resp_act. 68 | Next Obligation. 69 | apply: ghC=>i1 rs L1 C. 70 | apply: act_rule=>i2 R1/=; split; first by case: (rely_coh R1). 71 | move=>r i3 i4[Sf]S R3/=; rewrite -(rely_loc' l R1) in L1. 72 | case: Sf=>_ _ _ _ /(_ l); clear C=>C. 73 | case: S=>C2[|[l'][mid][tms][from][rt][pf][][E]Hin E1 Hw/=]. 74 | - by case=>?->Z; subst i3; rewrite (rely_loc' _ R3). 75 | case/andP=>/eqP Z G; subst l'; set d := (getStatelet i2 l) in C E pf Hw *. 76 | move=>Z->{r}; subst i3. 77 | move: rt pf (coh_s l C2) Hin E1 Hw R3 C G. 78 | rewrite prEq=>rt pf cohs Hin E1 Hw R3 C G. 79 | case: Hin=>/=Z; do?[subst rt|case: Z]=>//Z; subst rt. 80 | simpl in E1, Hw, R3; clear G. 81 | rewrite /cr_wf/= in Hw. 82 | case: tms E E1 R3 Hw=>t tms/= E E1 R3 Hw; subst t. 83 | have A1: exists s', dsoup d = mid \\-> (Msg (TMsg resp tms) from cl true) \+ s'. 84 | + by move/esym/um_eta2: E=>->; exists (free (dsoup d) mid). 85 | case: A1=>s' Es. 86 | 87 | (* Some auxiliary facts *) 88 | have Y : tms = head 0 tms :: behead tms. 89 | - suff M: exists x xs, tms = x::xs by case:M=>x [xs]E'; subst tms. 90 | by case/andP: Hw=>_; case: (tms)=>//x xs _; exists x, xs. 91 | have Y' : from \in cs. 92 | - case: (proj1 C)=>Cs _ _ _. case: Cs=>Vs/(_ mid)Cs. 93 | rewrite Es in Vs Cs; move: (findPtUn Vs)=>Ez. 94 | by move: (Cs _ Ez)=>/=; rewrite/cohMsg/==>H; case: H. 95 | 96 | (* Using the invariant *) 97 | move: ((proj2 C) (proj1 C) cl from (head 0 tms) (behead tms) mid s' Hc Y')=>//=. 98 | rewrite -!Y; move/(_ Es)=>F. 99 | rewrite Y in Hw. 100 | 101 | (* Proving the change in permissions *) 102 | have X: (cl, from, (behead tms)) \in rs. 103 | - by case/andP: Hw; rewrite (getStK (proj1 cohs) L1). 104 | have P1: valid (dstate d) by apply: (cohVl C). 105 | have P2: valid i2 by apply: (cohS (proj2 (rely_coh R1))). 106 | have P3: l \in dom i2 by rewrite -(cohD(proj2(rely_coh R1)))domPt inE/=. 107 | rewrite (rely_loc' _ R3)/= locE// /cr_step (getStK (proj1 cohs) L1)/=. 108 | clear R3 Hw P1 P2 P3; exists (remove_elem rs (cl, from, (behead tms))). 109 | move: (remove_elem_in rs (cl, from, (behead tms))); rewrite X. 110 | by rewrite perm_sym=>H. 111 | Qed. 112 | 113 | 114 | Definition receive_loop_cond (res : option nat) := res == None . 115 | 116 | Definition receive_loop_inv (rs : reqs) := 117 | fun r i => 118 | match r with 119 | | Some v => 120 | exists (rs' : reqs) from args , 121 | [/\ loc i = st :-> rs', 122 | perm_eq rs ((cl, from, args) :: rs') & 123 | f args = r] 124 | | None => loc i = st :-> rs 125 | end. 126 | 127 | Program Definition receive_loop' : 128 | {(rs : reqs)}, DHT [cl, W] 129 | (fun i => loc i = st :-> rs, 130 | fun (res : option nat) m => 131 | exists (rs' : reqs) v from args , 132 | [/\ res = Some v, loc m = st :-> rs', 133 | perm_eq rs ((cl, from, args) :: rs') & 134 | f args = res]) := 135 | Do _ (@while cl W _ _ receive_loop_cond receive_loop_inv _ 136 | (fun r => Do _ ( 137 | r <-- tryrecv_resp; 138 | match r with 139 | | Some (_, _, msg) => ret _ _ (Some (head 0 msg)) 140 | | None => ret _ _ None 141 | end)) None). 142 | 143 | Next Obligation. by apply: with_spec x. Defined. 144 | Next Obligation. 145 | by move:H; rewrite /receive_loop_inv (rely_loc' _ H0). 146 | Qed. 147 | Next Obligation. 148 | apply:ghC=>i1 rs[];rewrite /receive_loop_cond. 149 | move/eqP=>->/=E1 C1; apply: step; apply: (gh_ex (g:=rs)). 150 | apply: call_rule=>//={r}res i2; case: res; last first. 151 | - move=>E2 C; apply:ret_rule=>i3 R2. 152 | by rewrite /receive_loop_inv (rely_loc' _ R2). 153 | case; case=>from v msg[rs'][E2]P F C2. 154 | apply:ret_rule=>i3 R2; rewrite /receive_loop_inv (rely_loc' _ R2). 155 | by exists rs', from, (behead msg). 156 | Qed. 157 | 158 | Next Obligation. 159 | apply: ghC=>i rs E1 C1; apply: (gh_ex (g:=rs)). 160 | apply: call_rule=>//res m[]. 161 | rewrite /receive_loop_cond; case: res=>//=v _. 162 | move=>[rs'][from][args][E2]Hp F C2. 163 | by exists rs', v, from, args. 164 | Qed. 165 | 166 | (* Blocking receive-loop that always returns a result (but may not 167 | terminate) *) 168 | Program Definition blocking_receive_resp : 169 | {(rs : reqs)}, DHT [cl, W] 170 | (fun i => loc i = st :-> rs, 171 | fun (res : nat) m => 172 | exists (rs': reqs) from args , 173 | [/\ loc m = st :-> rs', 174 | perm_eq rs ((cl, from, args) :: rs') & 175 | f args = Some res]) := 176 | Do _ (r <-- receive_loop'; 177 | match r with 178 | | Some res => ret _ _ res 179 | | None => ret _ _ 0 180 | end). 181 | Next Obligation. 182 | apply: ghC=>i rs E1 C1; apply: step; apply: (gh_ex (g:=rs)). 183 | apply: call_rule=>//res i2[rs'][v][from][args][Z]E2 H1 H2. 184 | subst res=>C2; apply: ret_rule=>i3 R2. 185 | by exists rs', from, args; rewrite (rely_loc' _ R2). 186 | Qed. 187 | 188 | (* Simple send_transition *) 189 | 190 | Definition client_send_trans := 191 | ProtocolWithInvariant.snd_transI (s2 l f prec cs cls). 192 | 193 | Program Definition send_request server args := 194 | act (@send_action_wrapper W cal cl l (prEq cal) client_send_trans _ 195 | args server). 196 | Next Obligation. by rewrite InE; right; rewrite InE. Qed. 197 | 198 | 199 | Program Definition compute_f (server : nid) (args: seq nat) : 200 | DHT [cl, W] 201 | (fun i => 202 | [/\ loc i = st :-> ([::] : reqs), 203 | prec args & server \in cs], 204 | fun (res : nat) m => loc m = st :-> ([::] : reqs) /\ 205 | f args = Some res) := 206 | Do _ (send_request server args;; 207 | blocking_receive_resp). 208 | Next Obligation. 209 | move=>i1/=[E1 H2 H3]. 210 | apply: step; apply: act_rule=>i2 R1. 211 | case: (rely_coh R1)=>_ C2. 212 | have C': coh cal (getStatelet i2 l) by case: C2=>_ _ _ _/(_ l);rewrite prEq. 213 | split=>//=. 214 | - split=>//=. 215 | + by split=>//; case: C'. 216 | + rewrite/Actions.can_send -(cohD C2)/=domPt inE/= eqxx. 217 | by rewrite mem_cat Hc orbC. 218 | + rewrite/Actions.filter_hooks umfilt0=>???. 219 | move => F. 220 | apply sym_eq in F. 221 | move: F. 222 | by move/find_some; rewrite dom0. 223 | move=>y i3 i4[S]/=;case=>Z[b]/=[F]E3 R3; subst y. 224 | case: F=>/=F; subst b i3=>/=. 225 | rewrite -(rely_loc' _ R1) in E1. 226 | rewrite (getStK _ E1) in R3. 227 | apply: (gh_ex (g:=[:: (cl, server, args)])). 228 | apply: call_rule=>//. 229 | - move=>C4; rewrite (rely_loc' _ R3) locE//; last by apply: (cohVl C'). 230 | + by rewrite -(cohD C2) domPt inE/=. 231 | by apply: (cohS C2). 232 | clear R3=>v i5[rs'][from][args'][E5]P5 R C. 233 | suff X: args = args' /\ rs' = [::] by case: X=>Z X; subst args' rs'. 234 | suff X': rs' = [::]. 235 | - subst rs'; split=>//; move/perm_mem: P5=>P5. 236 | move/P5: (cl, server, args). 237 | by rewrite inE eqxx inE/==>/esym/eqP; case=>_->. 238 | by case/perm_size: P5=>/esym/size0nil. 239 | Qed. 240 | 241 | (**************************************************) 242 | (* 243 | Overall Implementation effort: 244 | 245 | 5 person-hours 246 | 247 | *) 248 | (**************************************************) 249 | 250 | 251 | (* More elaborated client program, compting a list of values *) 252 | 253 | Definition compute_list_spec server ys := 254 | forall (xs_acc : (seq input) * (seq (input * nat))), 255 | DHT [cl, W] 256 | (fun i => 257 | let: (xs, acc) := xs_acc in 258 | [/\ loc i = st :-> ([::] : reqs), 259 | all prec xs, 260 | all (fun e => f e.1 == Some e.2) acc, 261 | ys = map fst acc ++ xs & 262 | server \in cs], 263 | fun (res : seq (input * nat)) m => 264 | [/\ loc m = st :-> ([::] : reqs), 265 | all (fun e => f e.1 == Some e.2) res & 266 | ys = map fst res]). 267 | 268 | Program Definition compute_list_f server (xs : seq input) : 269 | DHT [cl, W] 270 | (fun i => 271 | [/\ loc i = st :-> ([::] : reqs), 272 | all prec xs & 273 | server \in cs], 274 | fun (res : seq (input * nat)) m => 275 | [/\ loc m = st :-> ([::] : reqs), 276 | all (fun e => f e.1 == Some e.2) res & 277 | xs = map fst res]) 278 | := 279 | Do (ffix (fun (rec : compute_list_spec server xs) xsa => 280 | Do _ (let: (xs, acc) := xsa in 281 | if xs is x :: xs' 282 | then r <-- compute_f server x; 283 | let: acc' := rcons acc (x, r) in 284 | rec (xs', acc') 285 | else ret _ _ acc)) (xs, [::])). 286 | 287 | Next Obligation. 288 | move=>i1/=[L1]; move:l0 l4=>zs acc H1 H2 H3 H4. 289 | case: zs H1 H3=>//=[_|z zs/andP[H1]H5] H3. 290 | - by rewrite cats0 in H3; 291 | apply: ret_rule=>i2 R1; split=>//; rewrite ?(rely_loc' _ R1)//. 292 | apply: step; apply: call_rule=>//r i2[L2]F C2. 293 | apply: call_rule=>//_; split=>//; first by rewrite all_rcons/= F eqxx. 294 | by rewrite map_rcons/= -cats1 -catA cat_cons/=. 295 | Qed. 296 | 297 | Next Obligation. 298 | by move=>i1/=[L1]??; apply: call_rule=>//; rewrite cats0. 299 | Qed. 300 | 301 | End CalculatorRecieve. 302 | -------------------------------------------------------------------------------- /theories/Examples/Calculator/CalculatorInvariant.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import axioms pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX Protocols Worlds NetworkSem. 5 | From DiSeL Require Import Rely Actions Injection Process Always HoareTriples. 6 | From DiSeL Require Import InferenceRules InductiveInv StatePredicates. 7 | From DiSeL Require Import CalculatorProtocol. 8 | 9 | Section CalculatorInductiveInv. 10 | 11 | Variable l : Label. 12 | 13 | Variable f : input -> option nat. 14 | Variable prec : input -> bool. 15 | Hypothesis prec_valid : 16 | forall i, prec i -> exists v, f i = Some v. 17 | 18 | Variable cs: seq nid. 19 | Variable cls : seq nid. 20 | (* All nodes *) 21 | Notation nodes := (cs ++ cls). 22 | (* All nodes are unique *) 23 | Hypothesis Huniq : uniq nodes. 24 | 25 | (* Protocol and its transitions *) 26 | Notation cal := (CalculatorProtocol f prec cs cls l). 27 | Notation sts := (snd_trans cal). 28 | Notation rts := (rcv_trans cal). 29 | 30 | Definition reqs := cstate. 31 | Notation coh := (coh cal). 32 | 33 | Notation loc n d := (getLocal n d). 34 | 35 | Lemma nodes_falso z : z \in cs -> z \in cls -> False. 36 | Proof. 37 | move=>H1 H2. 38 | move: (Huniq); rewrite cat_uniq=>/andP[_]/andP[/negP H]_. 39 | by apply: H; apply/hasP; exists z. 40 | Qed. 41 | 42 | Definition CalcInv d := 43 | forall (C: coh d) n to v args i s', 44 | n \in cls -> to \in cs -> 45 | dsoup d = i \\-> (Msg (TMsg resp (v::args)) to n true) \+ s' -> 46 | f args = Some v. 47 | 48 | Notation cal' := (CalculatorProtocol f prec cs cls l). 49 | Notation coh' := (coh cal). 50 | Notation Sinv := (@S_inv cal (fun d _ => CalcInv d)). 51 | Notation Rinv := (@R_inv cal (fun d _ => CalcInv d)). 52 | Notation PI := pf_irr. 53 | 54 | Program Definition s1: Sinv (server_send_trans f prec cs cls). 55 | Proof. 56 | move=>this to d msg S b. 57 | move=>/= Hi E G C' n to' v' args' i s1 N1 N2/= Es. 58 | case: (S)=>_[_][C]/hasP[[[me cc]args]]_. 59 | case/andP=>/eqP Z1/andP[/eqP Y]/eqP Z2. 60 | move: (cohVs C')=>V; rewrite joinC/= in Es V. 61 | move: (cancel2 V Es)=>/=; case: ifP. 62 | - move=>_; case. case=>Z3 Z4 Z5 Z6; subst s1 to to' msg. 63 | by simpl in Y; case: Z2=>->. 64 | move=>_[E1]/=E2 E3; subst to. clear Es V. 65 | by apply: (Hi C n to' v' args' i _ _ _ E2). 66 | Qed. 67 | 68 | 69 | Program Definition s2: Sinv (client_send_trans prec cs cls). 70 | Proof. 71 | move=>this to d msg S b. 72 | move=>/= Hi E G C' n to' v' args' i s1 N1 N2/= Es. 73 | move: (cohVs C')=>V; rewrite joinC/= in Es V. 74 | move: (cancel2 V Es)=>/=; case: ifP; last first. 75 | - move=>_[E1]/=E2 E3; clear Es V. 76 | by case: (S)=>_ _ C _; apply: (Hi C n to' v' args' i _ _ _ E2). 77 | move/eqP=>Z; subst i; by case; discriminate. 78 | Qed. 79 | 80 | Program Definition r1: Rinv (server_recv_trans prec cs cls). 81 | Proof. 82 | move=>d from this i C m pf Hi F D Hw Et _. 83 | move=> C' n to v args i' s1 N1 N2/=Es. 84 | suff Es' : exists s', dsoup d = 85 | i' \\-> {| content := {| tag := resp; tms_cont := v :: args |}; 86 | from := to; to := n; 87 | active := true |} \+ s'. 88 | by case: Es'=>s' Es'; apply: (Hi C n to v args i' _ N1 N2 Es'). 89 | case B: (i \in dom (dsoup d)); last first. 90 | by move: dom_find B Es; rewrite /consume_msg; case=>//->_->; exists s1. 91 | move/um_eta: B=>[vm][_]S1. 92 | move: (cohVs C)=>V; rewrite S1 in V. 93 | rewrite S1 joinC consumeUn ?eqxx joinC// in Es. 94 | suff V': valid (i \\-> mark_msg vm \+ 95 | free (cT:=union_mapUMC mid (msg TaggedMessage)) (dsoup d) i). 96 | - move: (cancel2 V' Es); case: ifP=>B. 97 | - move/eqP:B=>B{S1 V V' Es}; subst i'. 98 | by case: vm=>????/=; rewrite /mark_msg/=; case; discriminate. 99 | by case=>_ X2 _; rewrite X2 joinCA in S1; rewrite S1; eexists _. 100 | move: (consume_valid i V). 101 | rewrite /consume_msg/= findUnL// ?domPt inE/= eqxx findPt/=. 102 | by rewrite updUnL/= domPt/=!inE eqxx !updPt/=. 103 | Qed. 104 | 105 | Program Definition r2: Rinv (client_recv_trans prec cs cls). 106 | Proof. 107 | move=>d from this i C m pf Hi F D Hw Et _. 108 | move=> C' n to v args i' s1 N1 N2/=Es. 109 | suff Es' : exists s', dsoup d = 110 | i' \\-> {| content := {| tag := resp; tms_cont := v :: args |}; 111 | from := to; to := n; 112 | active := true |} \+ s'. 113 | by case: Es'=>s' Es'; apply: (Hi C n to v args i' _ N1 N2 Es'). 114 | case B: (i \in dom (dsoup d)); last first. 115 | by move: dom_find B Es; rewrite /consume_msg; case=>//->_->; exists s1. 116 | move/um_eta: B=>[vm][_]S1. 117 | move: (cohVs C)=>V; rewrite S1 in V. 118 | rewrite S1 joinC consumeUn ?eqxx joinC// in Es. 119 | suff V': valid (i \\-> mark_msg vm \+ 120 | free (cT:=union_mapUMC mid (msg TaggedMessage)) (dsoup d) i). 121 | - move: (cancel2 V' Es); case: ifP=>B. 122 | - move/eqP:B=>B{S1 V V' Es}; subst i'. 123 | by case: vm=>????/=; rewrite /mark_msg/=; case; discriminate. 124 | by case=>_ X2 _; rewrite X2 joinCA in S1; rewrite S1; eexists _. 125 | move: (consume_valid i V). 126 | rewrite /consume_msg/= findUnL// ?domPt inE/= eqxx findPt/=. 127 | by rewrite updUnL/= domPt/=!inE eqxx !updPt/=. 128 | Qed. 129 | 130 | Definition sts' := [:: SI s1; SI s2]. 131 | Definition rts' := [:: RI r1; RI r2]. 132 | 133 | Program Definition ii := @ProtocolWithInvariant.II _ _ sts' rts' _ _. 134 | 135 | Definition cal_with_inv := ProtocolWithIndInv ii. 136 | 137 | (**************************************************) 138 | (* 139 | Overall Implementation effort: 140 | 141 | 1 person-day 142 | 143 | *) 144 | (**************************************************) 145 | 146 | 147 | 148 | End CalculatorInductiveInv. 149 | 150 | -------------------------------------------------------------------------------- /theories/Examples/Calculator/CalculatorServerLib.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import axioms pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX Protocols Worlds NetworkSem. 5 | From DiSeL Require Import Rely Actions Injection Process Always HoareTriples. 6 | From DiSeL Require Import InferenceRules InductiveInv While. 7 | From DiSeL Require Import SeqLib CalculatorProtocol CalculatorInvariant. 8 | From DiSeL Require Import CalculatorClientLib. 9 | 10 | Section CalculatorServerLib. 11 | 12 | Variable l : Label. 13 | Variable f : input -> option nat. 14 | Variable prec : input -> bool. 15 | Variables (cs cls : seq nid). 16 | Notation nodes := (cs ++ cls). 17 | Hypothesis Huniq : uniq nodes. 18 | 19 | Notation cal := (CalculatorProtocol f prec cs cls l). 20 | Notation sts := (snd_trans cal). 21 | Notation rts := (rcv_trans cal). 22 | Notation W := (mkWorld cal). 23 | 24 | (* A server node *) 25 | Variable sv : nid. 26 | Hypothesis Hs : sv \in cs. 27 | Notation loc i := (getLocal sv (getStatelet i l)). 28 | 29 | (***********************) 30 | (* Server receive loop *) 31 | (***********************) 32 | 33 | Export CalculatorProtocol. 34 | 35 | Program Definition tryrecv_req_act := act (@tryrecv_action_wrapper W sv 36 | (fun k _ t b => (k == l) && (t == req)) _). 37 | Next Obligation. by case/andP:H=>/eqP->; rewrite domPt inE/=. Qed. 38 | 39 | (* Receive-transition for the calculator *) 40 | Program Definition tryrecv_req : 41 | {ps : reqs}, DHT [sv, W] 42 | (fun i => loc i = st :-> ps, 43 | fun (r : option perm) m => 44 | match r with 45 | | Some (from, t, args) => 46 | [/\ loc m = st :-> ((from, sv, args) :: ps), 47 | prec args & from \in cls] 48 | | None => loc m = st :-> ps 49 | end) 50 | := Do tryrecv_req_act. 51 | Next Obligation. 52 | apply: ghC=>i1 ps E1 C1. 53 | apply: act_rule=>i2 R1; split=>//=; first by apply: (proj2 (rely_coh R1)). 54 | move=>r i3 i4[_]/=St R3. 55 | case: St=>C2; case. 56 | - by move=>[]?->Z; subst i3;rewrite (rely_loc' _ R3) (rely_loc' _ R1). 57 | case=>k[m][tms][from][rt][pf'][[F]]H1 H2 H3/andP[/eqP Z]H4/= Z'->; subst k i3. 58 | move: rt pf' (coh_s l C2) H1 H2 H3 H4 R3. 59 | rewrite prEq=>rt pf' cohs H1 H2 H3 H4 R3. 60 | case: H1 H4; last by case=>//=->. 61 | move=>Z _; subst rt; move: H3; rewrite /msg_wf/=/sr_wf=>->; split=>//. 62 | set d := (getStatelet i2 l). 63 | have P1: valid (dstate d) by apply: (cohVl cohs). 64 | have P2: valid i2 by apply: (cohS (proj2 (rely_coh R1))). 65 | have P3: l \in dom i2 by rewrite -(cohD(proj2(rely_coh R1)))domPt inE/=. 66 | rewrite -(rely_loc' _ R1) in E1. 67 | - by rewrite (rely_loc' _ R3)/= locE//=/sr_step Hs/= (getStK cohs E1). 68 | case: (cohs)=>Cs _ _ _. move/esym: F=> F. 69 | by case: Cs=>_/(_ _ _ F); rewrite /cohMsg/= H2/=; case. 70 | Qed. 71 | 72 | Definition receive_req_loop_cond (res : option (nid * input)) := res == None. 73 | 74 | Definition receive_req_loop_inv (ps : reqs) := 75 | fun (r : option (nid * input)) i => 76 | match r with 77 | | Some (from, args) => 78 | [/\ loc i = st :-> ((from, sv, args) :: ps), 79 | prec args & from \in cls] 80 | | None => loc i = st :-> ps 81 | end. 82 | 83 | Program Definition receive_req_loop : 84 | {ps : reqs}, DHT [sv, W] 85 | (fun i => loc i = st :-> ps, 86 | fun (r : option (nid * input)) m => 87 | exists from args, 88 | [/\ r = Some (from, args), 89 | loc m = st :-> ((from, sv, args) :: ps), 90 | from \in cls & 91 | prec args]) := 92 | Do _ (@while sv W _ _ receive_req_loop_cond receive_req_loop_inv _ 93 | (fun r => Do _ ( 94 | r <-- tryrecv_req; 95 | match r with 96 | | Some (from, _, args) => ret _ _ (Some (from, args)) 97 | | None => ret _ _ None 98 | end)) None). 99 | 100 | Next Obligation. by apply: with_spec x. Defined. 101 | Next Obligation. 102 | by move:H; rewrite /receive_req_loop_inv (rely_loc' _ H0). 103 | Qed. 104 | Next Obligation. 105 | apply:ghC=>i1 ps/=[/eqP H1]L1 C1; subst r. 106 | apply: step; apply: (gh_ex (g:=ps)). 107 | apply: call_rule=>//r i2/=; case: r; last first. 108 | - by move=>L2 C2; apply: ret_rule=>i3 R2; rewrite -(rely_loc' _ R2) in L2. 109 | case=>[[from to] args]E2 C2; apply: ret_rule=>i3 R2/=. 110 | by rewrite (rely_loc' _ R2). 111 | Qed. 112 | Next Obligation. 113 | apply: ghC=>i ps E1 C1; apply: (gh_ex (g:=ps)). 114 | apply: call_rule=>//res m[]. 115 | rewrite /receive_req_loop_cond; case: res=>//=[[from args]]_ [H1 H2]C2. 116 | by exists from, args. 117 | Qed. 118 | 119 | Program Definition blocking_receive_req : 120 | {ps : reqs}, DHT [sv, W] 121 | (fun i => loc i = st :-> ps, 122 | fun (r : nid * input) m => 123 | [/\ loc m = st :-> ((r.1, sv, r.2) :: ps), 124 | r.1 \in cls & 125 | prec r.2]) := 126 | Do _ (r <-- receive_req_loop; 127 | match r with 128 | | Some res => ret _ _ res 129 | | None => ret _ _ (0, [::]) 130 | end). 131 | Next Obligation. 132 | apply: ghC=>i ps E1 C1; apply: step; apply: (gh_ex (g:=ps)). 133 | apply: call_rule=>//res i2[from][args][Z]E2 H1 H2 C2. 134 | by subst res; apply: ret_rule=>i3 R2/=; rewrite (rely_loc' _ R2). 135 | Qed. 136 | 137 | 138 | (***************************) 139 | (* Server sending messages *) 140 | (***************************) 141 | 142 | 143 | (* Generic server' send that assumes a permission to respond *) 144 | 145 | Program Definition send_ans_act to msg := 146 | act (@send_action_wrapper W cal sv l (prEq cal) 147 | (server_send_trans f prec cs cls) _ msg to). 148 | Next Obligation. by rewrite /cal_sends /InMem/=; left. Qed. 149 | 150 | Program Definition send_answer (to : nid) (args : seq nat) (ans : nat) : 151 | {ps : reqs}, DHT [sv, W] 152 | (fun i => [/\ loc i = st :-> ps, to \in cls, 153 | (to, sv, args) \in ps & 154 | f args = Some ans], 155 | fun (r : seq nat) m => 156 | [/\ loc m = st :-> (remove_elem ps (to, sv, args)) & 157 | r = ans :: args]) 158 | := Do send_ans_act to (ans :: args). 159 | Next Obligation. 160 | apply: ghC=>i1 ps [L1]H1 H2 H3 C1. 161 | apply: act_rule=>i2 R1. 162 | move: (proj2 (rely_coh R1))=>C2. 163 | case: (C2)=>_ _ _ _/(_ l); rewrite prEq=>C. 164 | set d := (getStatelet i2 l). 165 | split=>//[|r i3 i4[Sf]St R3]. 166 | - split=>//; first 1 last. 167 | + by rewrite/Actions.can_send mem_cat Hs/= 168 | -(cohD C2)/= domPt/= inE eqxx. 169 | + rewrite/Actions.filter_hooks umfilt0=>???. 170 | move => F. 171 | apply sym_eq in F. 172 | move: F. 173 | move/find_some. 174 | by rewrite dom0. 175 | split=>//; split=>//. 176 | exists C; rewrite -(rely_loc' _ R1) in L1; rewrite (getStK C L1). 177 | by apply/hasP; exists (to, sv, args)=>//=; rewrite H3 !eqxx. 178 | rewrite (rely_loc' _ R3)=>{R3}. 179 | case: St=>->[b]/=[][]->->/=; split=>//. 180 | have P1: valid (dstate (getStatelet i2 l)). by apply: (cohVl C). 181 | have P2: valid i2 by apply: (cohS (proj2 (rely_coh R1))). 182 | have P3: l \in dom i2 by rewrite -(cohD(proj2(rely_coh R1))) domPt inE/=. 183 | rewrite -(rely_loc' _ R1) in L1. 184 | by rewrite (pf_irr (ss_safe_coh _ ) C) locE// (getStK C L1). 185 | Qed. 186 | 187 | (**************************************************) 188 | (* 189 | Overall Implementation effort: 190 | 191 | 2 person-hours 192 | 193 | *) 194 | (**************************************************) 195 | 196 | 197 | End CalculatorServerLib. 198 | -------------------------------------------------------------------------------- /theories/Examples/Calculator/DelegatingCalculatorServer.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX Protocols Worlds NetworkSem. 5 | From DiSeL Require Import Rely Actions Injection Process Always HoareTriples. 6 | From DiSeL Require Import InferenceRules InductiveInv While. 7 | From DiSeL Require Import CalculatorProtocol CalculatorInvariant. 8 | From DiSeL Require Import CalculatorClientLib CalculatorServerLib. 9 | 10 | Export CalculatorProtocol. 11 | 12 | Section DelegatingCalculator. 13 | 14 | Variables (l1 l2 : Label). 15 | Hypothesis (lab_disj : l2 != l1). 16 | 17 | Variable f : input -> option nat. 18 | Variable prec : input -> bool. 19 | Variables (cs1 cls1 : seq nid). 20 | Variables (cs2 cls2 : seq nid). 21 | Notation nodes1 := (cs1 ++ cls1). 22 | Notation nodes2 := (cs2 ++ cls2). 23 | Hypothesis Huniq1 : uniq nodes1. 24 | Hypothesis Huniq2 : uniq nodes2. 25 | 26 | (* Protocol I'm a server in *) 27 | Notation cal1 := (cal_with_inv l1 f prec cs1 cls1). 28 | Notation cal2 := (cal_with_inv l2 f prec cs2 cls2). 29 | 30 | Notation W1 := (mkWorld cal1). 31 | Notation W2 := (mkWorld cal2). 32 | 33 | (* Composite world *) 34 | Definition V := W1 \+ W2. 35 | Lemma validV : valid V. 36 | Proof. 37 | rewrite /V; apply/andP=>/=. 38 | split; first by rewrite validPtUn/= validPt/= domPt inE/=. 39 | by rewrite unitR valid_unit. 40 | Qed. 41 | 42 | (* This server node *) 43 | Variable sv : nid. 44 | (* It's a server in protocol cal1 *) 45 | Hypothesis Hs1 : sv \in cs1. 46 | (* It's a client in protocol cal2 *) 47 | Hypothesis Hc2 : sv \in cls2. 48 | (* Delegate server *) 49 | Variable sd : nid. 50 | Hypothesis Hs2 : sd \in cs2. 51 | 52 | Notation loc i k := (getLocal sv (getStatelet i k)). 53 | Notation loc1 i := (loc i l1). 54 | Notation loc2 i := (loc i l2). 55 | 56 | (* Delegate computation to someone else *) 57 | Definition delegate_f := compute_f l2 f prec cs2 cls2 _ Hc2 sd. 58 | 59 | Notation cal_ii := (ii l1 f prec cs1 cls1). 60 | 61 | Definition receive_msg := 62 | with_inv cal_ii (blocking_receive_req l1 f prec cs1 cls1 _ Hs1). 63 | Definition send_ans to args ans := 64 | with_inv cal_ii (send_answer l1 f prec cs1 cls1 _ Hs1 to args ans). 65 | 66 | Definition delegating_body_spec := 67 | forall _ : unit, 68 | DHT [sv, V] 69 | (fun i => 70 | loc1 i = st :-> ([::]:reqs) /\ 71 | loc2 i = st :-> ([::]:reqs), 72 | fun (r : unit) m => 73 | loc1 m = st :-> ([::]:reqs) /\ 74 | loc2 m = st :-> ([::]:reqs)). 75 | 76 | Program Definition delegating_body : 77 | delegating_body_spec := fun (_ : unit) => 78 | Do _ ( 79 | r <-- uinject (receive_msg); 80 | let: (from, args) := r in 81 | (* Delegate computations *) 82 | ans <-- uinject (delegate_f args); 83 | uinject (send_ans from args ans);; 84 | ret sv V tt). 85 | 86 | Lemma hook_complete_unit (c : context) : hook_complete (c, Unit). 87 | Proof. by move=>????; rewrite dom0. Qed. 88 | 89 | Lemma hooks_consistent_unit (c : context) : hooks_consistent c Unit. 90 | Proof. by move=>????; rewrite dom0. Qed. 91 | 92 | Next Obligation. 93 | rewrite -(unitR V)/V. 94 | have @V: valid (W1 \+ W2 \+ Unit) by rewrite unitR validV. 95 | apply: (injectL V); do?[apply: hook_complete_unit | apply: hooks_consistent_unit]. 96 | by move=>??????; rewrite dom0. 97 | Defined. 98 | 99 | Next Obligation. 100 | rewrite -(unitR V)/V. 101 | have @V: valid (W1 \+ W2 \+ Unit) by rewrite unitR validV. 102 | apply: (injectR V); do?[apply: hook_complete_unit | apply: hooks_consistent_unit]. 103 | by move=>??????; rewrite dom0. 104 | Qed. 105 | 106 | Next Obligation. 107 | rewrite -(unitR V)/V. 108 | have @V: valid (W1 \+ W2 \+ Unit) by rewrite unitR validV. 109 | apply: (injectL V); do?[apply: hook_complete_unit | apply: hooks_consistent_unit]. 110 | by move=>??????; rewrite dom0. 111 | Defined. 112 | 113 | Lemma hcomp l : hook_complete (mkWorld l). 114 | Proof. by move=>????; rewrite dom0. Qed. 115 | 116 | Next Obligation. 117 | move=>i/=[K1 L1]; apply: vrf_coh=>CD1; apply: step. 118 | move: (coh_split CD1 (hcomp cal1) (hcomp cal2))=>[i1[j1]][C1 D1 Z]; subst i. 119 | apply: inject_rule=>//. 120 | have E1 : loc (i1 \+ j1) l1 = loc i1 l1 121 | by rewrite (locProjL CD1 _ C1)// domPt inE/=. 122 | rewrite E1 in K1. 123 | apply: with_inv_rule=>//. 124 | apply: (gh_ex (g:=[::])). 125 | apply: call_rule=>//[[from args]] i2/=[K2]H1 H2 _ j2 CD2 R1. 126 | have E2 : loc (i1 \+ j1) l2 = loc j1 l2. 127 | by rewrite (locProjR CD1 _ D1)// domPt inE/=. 128 | (* Adapt the second protocol's view *) 129 | rewrite E2 -(rely_loc' l2 R1) in L1. 130 | apply: step; clear C1 D1. 131 | have D2: j2 \In Coh W2 by case: (rely_coh R1)=>/= _; rewrite injExtL//(cohW CD1). 132 | clear R1; rewrite joinC; apply: inject_rule=>//. 133 | apply: call_rule=>//ans j3[L3]F D3 i3 CD3/= R2. 134 | have C3: i3 \In Coh W1 by case: (rely_coh R2)=>/= _; rewrite injExtR//(cohW CD3). 135 | apply: step; rewrite joinC. 136 | rewrite -(rely_loc' _ R2) in K2; move:K2=>K3; clear R2. 137 | apply: inject_rule=>//; apply: with_inv_rule=>//. 138 | apply: (gh_ex (g:=[:: (from, sv, args)])). 139 | apply: call_rule; first by rewrite inE eqxx. 140 | move=>_ i4 [K4 _] _ j4 CD4 R3. 141 | rewrite -(rely_loc' _ R3) in L3; move: L3=>L4. 142 | apply: ret_rule=>m R _; rewrite (rely_loc' _ R). 143 | move/rely_coh: (R3)=>[]; rewrite injExtL ?(cohW CD2)//. 144 | move=>_ D4; clear R3; rewrite !(rely_loc' _ R); clear R. 145 | have X: l2 \in dom W2.1 by rewrite domPt inE eqxx. 146 | rewrite (@locProjR _ _ _ _ _ CD4 X D4); split=>//. 147 | have X': l1 \in dom W1.1 by rewrite domPt inE eqxx. 148 | rewrite /= eqxx in K4; rewrite (@locProjL _ _ _ _ _ CD4 X' _)//. 149 | by apply: (cohUnKL CD4 D4); apply: hook_complete_unit. 150 | Qed. 151 | 152 | Definition delegating_server_loop_cond (res : unit) := true. 153 | 154 | Definition delegating_server_loop_inv := 155 | fun (_ r : unit) i => 156 | loc1 i = st :-> ([::]:reqs) /\ 157 | loc2 i = st :-> ([::]:reqs). 158 | 159 | Program Definition delegating_server_loop : 160 | DHT [sv, V] 161 | (fun i => loc1 i = st :-> ([::]:reqs) /\ 162 | loc2 i = st :-> ([::]:reqs), 163 | fun (r : unit) m => False) := 164 | Do _ (@while sv V _ _ delegating_server_loop_cond delegating_server_loop_inv _ 165 | (fun r => Do _ (delegating_body r))) tt. 166 | 167 | Next Obligation. by apply: with_spec (x x0). Defined. 168 | Next Obligation. 169 | by move:H; rewrite /delegating_server_loop_inv !(rely_loc' _ H0). 170 | Qed. 171 | Next Obligation. by apply: with_spec x. Defined. 172 | Next Obligation. 173 | by apply: ghC=>i1 s[H1 H2] C1/=; apply: call_rule. 174 | Qed. 175 | Next Obligation. 176 | move=>i/=E1; apply: call_rule'=>//. 177 | - by move=>C1; exists tt=>//. 178 | by move=>s' m/(_ s')/=; case. 179 | Qed. 180 | 181 | End DelegatingCalculator. 182 | -------------------------------------------------------------------------------- /theories/Examples/Calculator/SimpleCalculatorApp.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX Protocols Worlds NetworkSem. 5 | From DiSeL Require Import Rely Actions Injection Process Always. 6 | From DiSeL Require Import HoareTriples InferenceRules InductiveInv While. 7 | From DiSeL Require Import CalculatorProtocol CalculatorInvariant. 8 | From DiSeL Require Import CalculatorClientLib CalculatorServerLib. 9 | From DiSeL Require Import DelegatingCalculatorServer SimpleCalculatorServers. 10 | 11 | Export CalculatorProtocol. 12 | 13 | Section CalculatorApp. 14 | 15 | Definition l1 := 1. 16 | Definition l2 := 2. 17 | Lemma lab_dis : l2 != l1. Proof. by []. Qed. 18 | 19 | Definition f args := 20 | match args with 21 | | x::y::_ => Some (x + y) 22 | | _ => None 23 | end. 24 | 25 | Definition prec (args : input) := 26 | if args is x::y::_ then true else false. 27 | 28 | Lemma prec_valid : 29 | forall i, prec i -> exists v, f i = Some v. 30 | Proof. by move=>i; case: i=>//=x; case=>//y _ _; eexists _. Qed. 31 | 32 | (* Two overlapping calculator systems *) 33 | (* System 1: one server, one client *) 34 | Definition cs1 := [::1]. 35 | Definition cls1 := [::2]. 36 | 37 | (* System 2: one server, one client *) 38 | Definition cs2 := [::3]. 39 | Definition cls2 := [::1]. 40 | 41 | Notation nodes1 := (cs1 ++ cls1). 42 | Notation nodes2 := (cs2 ++ cls2). 43 | Lemma Huniq1 : uniq nodes1. Proof. by []. Qed. 44 | Lemma Huniq2 : uniq nodes2. Proof. by []. Qed. 45 | 46 | (* Protocol I'm a server in *) 47 | Notation cal1 := (cal_with_inv l1 f prec cs1 cls1). 48 | Notation cal2 := (cal_with_inv l2 f prec cs2 cls2). 49 | 50 | Notation W1 := (mkWorld cal1). 51 | Notation W2 := (mkWorld cal2). 52 | 53 | (* Composite world *) 54 | Definition V := W1 \+ W2. 55 | Lemma validV : valid V. 56 | Proof. 57 | rewrite /V; apply/andP=>/=. 58 | split; first by rewrite validPtUn/= validPt/= domPt inE/=. 59 | by rewrite unitR valid_unit. 60 | Qed. 61 | 62 | (* This server node *) 63 | Definition sv : nid := 1. 64 | Definition cl : nid := 2. 65 | (* It's a server in protocol cal1 *) 66 | Lemma Hs1 : sv \in cs1. Proof. by []. Qed. 67 | (* It's a client in protocol cal2 *) 68 | Lemma Hc2 : sv \in cls2. Proof. by []. Qed. 69 | Lemma Hc1 : cl \in cls1. Proof. by []. Qed. 70 | (* Delegate server *) 71 | Definition sd := 3. 72 | Lemma Hs2 : sd \in cs2. Proof. by []. Qed. 73 | 74 | Notation loc i k := (getLocal sv (getStatelet i k)). 75 | Notation loc1 i := (loc i l1). 76 | Notation loc2 i := (loc i l2). 77 | 78 | (****************************************************) 79 | (*********** Initial state ***************) 80 | (****************************************************) 81 | 82 | Definition init_loc := st :-> ([::] : reqs). 83 | 84 | Definition init_dstate1 := sv \\-> init_loc \+ cl \\-> init_loc. 85 | Definition init_dstate2 := sv \\-> init_loc \+ sd \\-> init_loc. 86 | 87 | Lemma valid_init_dstate1 : valid init_dstate1. 88 | Proof. 89 | case: validUn=>//=; 90 | do?[case: validUn=>//; do?[rewrite ?validPt/=//]|by rewrite validPt/=]. 91 | by move=>k; rewrite !domPt !inE/==>/eqP<-/eqP. 92 | Qed. 93 | 94 | Lemma valid_init_dstate2 : valid init_dstate2. 95 | Proof. 96 | case: validUn=>//=; 97 | do?[case: validUn=>//; do?[rewrite ?validPt/=//]|by rewrite validPt/=]. 98 | by move=>k; rewrite !domPt !inE/==>/eqP<-/eqP. 99 | Qed. 100 | 101 | Notation init_dstatelet1 := (DStatelet init_dstate1 Unit). 102 | Notation init_dstatelet2 := (DStatelet init_dstate2 Unit). 103 | 104 | Definition init_state : state := 105 | l1 \\-> init_dstatelet1 \+ l2 \\-> init_dstatelet2. 106 | 107 | Lemma validI : valid init_state. 108 | Proof. 109 | case: validUn=>//=; do?[case: validUn=>//; 110 | do?[rewrite ?gen_validPt/=//]|by rewrite validPt/=]; 111 | by move=>k; rewrite !domPt !inE/==>/eqP<-/eqP. 112 | Qed. 113 | 114 | Lemma coh1': calcoh prec cs1 cls1 init_dstatelet1 /\ 115 | CalcInv l1 f prec cs1 cls1 init_dstatelet1. 116 | Proof. 117 | split; last by move=>?????????/=/esym/unitbP/=; rewrite um_unitbPtUn. 118 | split=>//; rewrite ?valid_init_dstate1//. 119 | - split; first by rewrite valid_unit. 120 | by move=>m ms; rewrite find0E. 121 | - move=>z; rewrite /=/init_dstate1 domUn !inE/= valid_init_dstate1/=. 122 | by rewrite !domPt !inE !(eq_sym z). 123 | move=>n/=; rewrite inE=>/orP; case=>//=. 124 | - move/eqP=>->/=; exists [::]=>/=. 125 | rewrite /getLocal/init_dstate1/= findUnL?valid_init_dstate1//. 126 | by rewrite domPt/= findPt/=. 127 | rewrite inE=>/eqP=>->; exists [::]=>/=. 128 | rewrite /getLocal/init_dstate1/= findUnL?valid_init_dstate1//. 129 | by rewrite domPt/= findPt. 130 | Qed. 131 | 132 | Lemma coh1 : l1 \\-> init_dstatelet1 \In Coh W1. 133 | Proof. 134 | split=>//. 135 | - apply/andP; split; last by rewrite valid_unit. 136 | by rewrite ?validPt. 137 | - by rewrite validPt/=. 138 | - by apply: hook_complete_unit. 139 | - by move=>z; rewrite !domPt !inE/=. 140 | move=>k; case B: (l1==k); last first. 141 | - have X: (k \notin dom W1.1). 142 | by rewrite /init_state/W1/=!domPt !inE/=; move/negbT: B. 143 | by rewrite /getProtocol /getStatelet/= ?findPt2 eq_sym !B/=. 144 | move/eqP:B=>B; subst k; rewrite prEq/getStatelet/init_state findPt/=. 145 | exact: coh1'. 146 | Qed. 147 | 148 | Lemma coh2' : calcoh prec cs2 cls2 init_dstatelet2 /\ 149 | CalcInv l2 f prec cs2 cls2 init_dstatelet2. 150 | Proof. 151 | split; last by move=>?????????/=/esym/unitbP/=; rewrite um_unitbPtUn. 152 | split=>//; rewrite ?valid_init_dstate2//. 153 | - split; first by rewrite valid_unit. 154 | by move=>m ms; rewrite find0E//. 155 | - move=>z; rewrite /=/init_dstate2 domUn !inE/= valid_init_dstate2//=. 156 | by rewrite !domPt !inE !(eq_sym z) orbC. 157 | move=>n/=; rewrite inE=>/orP; case=>//=. 158 | - move/eqP=>->/=; exists [::]=>/=. 159 | rewrite /getLocal/init_dstate2/= findUnL?valid_init_dstate2//. 160 | by rewrite domPt/= findPt/=. 161 | rewrite inE=>/eqP=>->; exists [::]=>/=. 162 | rewrite /getLocal/init_dstate2/= findUnL?valid_init_dstate2//. 163 | by rewrite domPt/= findPt. 164 | Qed. 165 | 166 | Lemma coh2 : l2 \\-> init_dstatelet2 \In Coh W2. 167 | Proof. 168 | split. 169 | - apply/andP; split; last by rewrite valid_unit. 170 | by rewrite ?validPt. 171 | - by rewrite validPt/=. 172 | - by apply: hook_complete_unit. 173 | - by move=>z; rewrite !domPt !inE/=. 174 | move=>k; case B: (l2==k); last first. 175 | - have X: (k \notin dom W2.1). 176 | by rewrite /init_state/W2/=!domPt !inE/=; move/negbT: B. 177 | by rewrite /getProtocol /getStatelet/= ?findPt2 eq_sym !B/=. 178 | move/eqP:B=>B; subst k; rewrite prEq/getStatelet/init_state findPt/=. 179 | exact: coh2'. 180 | Qed. 181 | 182 | Lemma init_coh : init_state \In Coh V. 183 | Proof. 184 | split=>//; first by apply: validV. 185 | - by apply: validI. 186 | - rewrite /V/=/init_state/==>z. 187 | - by move=>???; rewrite domUn !inE/= dom0 andbC. 188 | - rewrite /V/init_state=>z; rewrite !domUn !inE; case/andP:validV=>->_/=. 189 | by rewrite validI/= !domPt. 190 | move=>k; case B: ((l1 == k) || (l2 == k)); last first. 191 | - have X: (k \notin dom V.1). 192 | + by rewrite /V domUn inE/= !domPt!inE/= B andbC. 193 | rewrite /getProtocol /getStatelet/=. 194 | case: dom_find (X)=>//->_/=; rewrite /init_state. 195 | case/negbT/norP: B=>/negbTE N1/negbTE N2. 196 | rewrite findUnL; rewrite ?validI// domPt inE N1. 197 | rewrite findPt2 eq_sym N1/=. 198 | by rewrite findPt2 eq_sym N2/=. 199 | case/andP: validV=>V1 V2. 200 | case/orP:B=>/eqP Z; subst k; 201 | rewrite /getProtocol/V findUnL/= ?V1 ?domPt ?inE/= ?findPt; 202 | rewrite /getStatelet ?findUnL/= ?validI// ?domPt ?inE/= ?findPt; 203 | [by case: coh1'|by case coh2']. 204 | Qed. 205 | 206 | (****************************************************) 207 | (*********** Runnable programs ***************) 208 | (****************************************************) 209 | 210 | Definition client_input := 211 | [:: [::1; 2]; [::3; 4]; [::5; 6]; [::7; 8]; [::9; 10]]. 212 | 213 | Definition compute_input := compute_list_f l1 f prec cs1 cls1 cl Hc1 sv. 214 | 215 | (* [C] A simple client, evaluating a serives of requests *) 216 | Program Definition client_run (u : unit) : 217 | DHT [cl, V] 218 | (fun i => network_rely V cl init_state i, 219 | fun (res : seq (input * nat)) m => 220 | [/\ all (fun e => f e.1 == Some e.2) res & 221 | client_input = map fst res]) := 222 | Do (uinject (compute_input client_input)). 223 | 224 | Next Obligation. 225 | rewrite -(unitR V)/V. 226 | have @V: valid (W1 \+ W2 \+ Unit) by rewrite unitR validV. 227 | apply: (injectL V); do?[apply: hook_complete_unit | apply: hooks_consistent_unit]. 228 | by move=>??????; rewrite dom0. 229 | Qed. 230 | 231 | Next Obligation. 232 | move=>i/=R. 233 | have X: injects W1 V Unit. 234 | - move: (@injectL W1 W2 Unit)=>/=; rewrite !unitR =>H. 235 | apply: H=>//; do? [by apply: hook_complete0]. 236 | + by rewrite -[Unit]unitR; move: validV. 237 | by move=>l _=>????; rewrite dom0. 238 | case: (rely_ext X coh1 R)=>i1[j1][Z]C'; subst i. 239 | apply: inject_rule=>//. 240 | apply: call_rule=>C1{C'}/=; last by move=>m[H1]H2 H3. 241 | have E: (getStatelet i1 l1) = (getStatelet (i1 \+ j1) l1). 242 | - by rewrite (locProjL (proj2 (rely_coh R)) _ C1)=>//; rewrite /W1 domPt. 243 | rewrite E (rely_loc' _ R)/getLocal/=/getStatelet/=. 244 | rewrite findUnL ?validI// domPt inE eqxx findPt/=. 245 | by rewrite /init_dstate1 findUnR?valid_init_dstate1// domPt/= findPt/=. 246 | Qed. 247 | 248 | (* [S1] Delegating server, serving the client's needs *) 249 | Definition delegating_server (u : unit) := 250 | delegating_server_loop l1 l2 lab_dis f prec cs1 cls1 cs2 cls2 sv 251 | Hs1 Hc2 sd Hs2. 252 | 253 | Program Definition server1_run (u : unit) : 254 | DHT [sv, V] 255 | (fun i => network_rely V sv init_state i, 256 | fun (res : unit) m => False) := 257 | Do (delegating_server u). 258 | Next Obligation. 259 | move=>i/=R; apply: call_rule=>C1//=. 260 | rewrite (rely_loc' _ R)/getLocal/=/getStatelet/=. 261 | rewrite findUnL ?validI ?valid_init_dstate1//. 262 | rewrite domPt inE eqxx findPt/=. 263 | rewrite findUnR ?validI ?valid_init_dstate1//=. 264 | rewrite domPt inE/= findPt/=; split=>//. 265 | rewrite -(rely_loc _ R)/=/getStatelet findUnR ?validI ?valid_init_dstate1//=. 266 | rewrite domPt inE/= findPt/= /init_dstate2/=. 267 | rewrite findUnL ?validI ?valid_init_dstate2//. 268 | by rewrite domPt inE/= findPt/= /init_dstate2/=. 269 | Qed. 270 | 271 | (* [S2] A memoizing server, serving as a delegate *) 272 | 273 | Definition secondary_server (u : unit) := 274 | with_inv (ii l2 f prec cs2 cls2) 275 | (memoizing_server l2 f prec prec_valid cs2 cls2 sd Hs2). 276 | 277 | Program Definition server2_run (u : unit) : 278 | DHT [sd, V] 279 | (fun i => network_rely V sd init_state i, 280 | fun (res : unit) m => False) := 281 | Do _ (@inject sd W2 V Unit _ _ (secondary_server u);; ret _ _ tt). 282 | 283 | Next Obligation. 284 | rewrite -(unitR V)/V. 285 | have @V: valid (W1 \+ W2 \+ Unit) by rewrite unitR validV. 286 | apply: (injectR V); do?[apply: hook_complete_unit | apply: hooks_consistent_unit]. 287 | by move=>??????; rewrite dom0. 288 | Qed. 289 | 290 | Next Obligation. 291 | move=>i/=R; apply: step. 292 | rewrite /init_state joinC. 293 | 294 | have X: injects W2 V Unit. 295 | - move: (@injectL W2 W1 Unit)=>/=; rewrite !unitR=>H. 296 | rewrite /V joinC;apply: H=>//; do? [by apply: hook_complete0]. 297 | + by rewrite joinC -[Unit]unitR; move: validV. 298 | by move=>l _=>????; rewrite dom0. 299 | rewrite /V joinC in R X; rewrite /init_state [l1 \\->_ \+ _]joinC in R. 300 | case: (rely_ext X coh2 R)=>j1[i1][Z]C'; subst i. 301 | apply: inject_rule=>//=. 302 | apply: with_inv_rule; apply:call_rule=>//_. 303 | have E: (getStatelet j1 l2) = (getStatelet (j1 \+ i1) l2). 304 | - by rewrite (locProjL (proj2 (rely_coh R)) _ C')=>//; rewrite /W1 domPt. 305 | rewrite E (rely_loc' _ R)/getLocal/=/getStatelet/=. 306 | rewrite findUnL ?validI//; last by rewrite joinC validI. 307 | rewrite domPt/= findPt/=. 308 | by rewrite /init_dstate2 findUnL ?valid_init_dstate2 ?domPt/= ?findPt. 309 | Qed. 310 | 311 | End CalculatorApp. 312 | 313 | (***************************************************) 314 | (* Now all three programs run in the same world! *) 315 | (***************************************************) 316 | 317 | Definition c_runner (u : unit) := client_run u. 318 | Definition s_runner1 (u : unit) := server1_run u. 319 | Definition s_runner2 (u : unit) := server2_run u. 320 | -------------------------------------------------------------------------------- /theories/Examples/Querying/QueryPlusTPC.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import Freshness State EqTypeX Protocols Worlds NetworkSem Rely. 5 | From DiSeL Require Import NewStatePredicates. 6 | From DiSeL Require Import SeqLib. 7 | From DiSeL Require Import Actions Injection Process Always HoareTriples InferenceRules. 8 | From DiSeL Require Import TwoPhaseProtocol TwoPhaseCoordinator TwoPhaseParticipant. 9 | From DiSeL Require TwoPhaseInductiveProof. 10 | From DiSeL Require Import QueryProtocol QueryHooked. 11 | 12 | Section QueryPlusTPC. 13 | 14 | (* Querying on behalf of the coordinator (it's easier this way, thanks *) 15 | (* to cn_agreement lemma). In order to query on behald of the *) 16 | (* participan, a different invariant-based fact should be proven. *) 17 | 18 | (****************************************************************) 19 | (************* Basic definitions ******************) 20 | (****************************************************************) 21 | 22 | Variables (lc lq : Label). 23 | Variables (cn : nid) (pts : seq nid). 24 | Hypothesis Lab_neq: lq != lc. 25 | Hypothesis Hnin : cn \notin pts. 26 | Hypothesis Puniq : uniq pts. 27 | Hypothesis PtsNonEmpty : pts != [::]. 28 | 29 | (* Core protocol *) 30 | Definition pc : protocol := TwoPhaseInductiveProof.tpc_with_inv lc [::] Hnin. 31 | Definition Data : Type := (nat * Log). 32 | Definition qnodes := cn :: pts. 33 | 34 | (* Serialization of logs *) 35 | Variable serialize : Data -> seq nat. 36 | Variable deserialize : seq nat -> Data. 37 | Hypothesis ds_inverse : left_inverse serialize deserialize. 38 | 39 | (* This one is in the init state *) 40 | Definition local_indicator (d : Data) := 41 | [Pred h | h = st :-> (d.1, CInit) \+ log :-> d.2]. 42 | 43 | (* Data is just a log *) 44 | Definition core_state_to_data n h (d : Data) := 45 | if n == cn 46 | then h = st :-> (d.1, CInit) \+ log :-> d.2 47 | else h = st :-> (d.1, PInit) \+ log :-> d.2. 48 | 49 | Lemma core_state_to_data_inj n h d d' : 50 | core_state_to_data n h d -> core_state_to_data n h d' -> d = d'. 51 | Proof. 52 | rewrite/core_state_to_data. 53 | case:ifP=>_ E; rewrite E ![_ \+ log :-> _]joinC=>{E}E. 54 | - have V: valid (log :-> d.2 \+ st :-> (d.1, CInit)). 55 | - by case: validUn=>//k; rewrite !domPt !inE/==>/eqP<-. 56 | case: (hcancelV V E)=>E2=>{V E}V E. 57 | case: (hcancelPtV V E)=>E1. 58 | by rewrite [d]surjective_pairing [d']surjective_pairing E1 E2. 59 | have V: valid (log :-> d.2 \+ st :-> (d.1, PInit)). 60 | - by case: validUn=>//k; rewrite !domPt !inE/==>/eqP<-. 61 | case: (hcancelV V E)=>E2=>{V E}V E. 62 | case: (hcancelPtV V E)=>E1. 63 | by rewrite [d]surjective_pairing [d']surjective_pairing E1 E2. 64 | Qed. 65 | 66 | Lemma cn_in_qnodes : cn \in qnodes. 67 | Proof. by rewrite inE eqxx. Qed. 68 | 69 | Notation getLc s n := (getLocal n (getStatelet s lc)). 70 | Notation cn_agree := TwoPhaseInductiveInv.cn_log_agreement. 71 | 72 | (****************************************************************) 73 | (************* Necessary properties of TPC ******************) 74 | (****************************************************************) 75 | 76 | Lemma core_state_stable_step z s d s' n : 77 | cn != z -> network_step (mkWorld pc) z s s' -> 78 | n \in qnodes -> 79 | local_indicator d (getLc s cn) -> 80 | core_state_to_data n (getLc s n) d -> 81 | core_state_to_data n (getLc s' n) d. 82 | Proof. 83 | move=>N S Qn L H0; case: (step_coh S)=>C1 C2. 84 | have R: network_rely (plab pc \\-> pc, Unit) cn s s' by exists 1, z, s'. 85 | rewrite -(rely_loc' _ R) in L. 86 | case: C2=>V1 V2 _ D /(_ lc)/=; rewrite prEq=>/=[[C2] Inv]. 87 | case/orP: Qn=>[|P]; first by move/eqP=>Z; subst n; rewrite /core_state_to_data eqxx. 88 | move: (@cn_agree lc cn pts [::] Hnin (getStatelet s' lc) d.1 d.2 n C2 L Inv P)=>H. 89 | rewrite /core_state_to_data; case:ifP=>//; by move=>/eqP Z; subst n. 90 | Qed. 91 | 92 | (*************** Intermediate definitions **********************) 93 | 94 | (* Composite world *) 95 | Definition W := QueryHooked.W lq pc Data qnodes serialize core_state_to_data. 96 | 97 | Notation loc_qry s := (getLocal cn (getStatelet s lq)). 98 | Notation loc_tpc' s n := (getLocal n (getStatelet s lc)). 99 | Notation loc_tpc s := (loc_tpc' s cn). 100 | Notation qry_init := (query_init_state lq Data qnodes serialize cn). 101 | 102 | Lemma loc_imp_core s d n : 103 | Coh W s -> n \in qnodes -> local_indicator d (loc_tpc s) -> 104 | core_state_to_data n (loc_tpc' s n) d. 105 | Proof. 106 | move=>C Nq E. 107 | case/orP: Nq=>[|P]; first by move/eqP=>z; subst n; rewrite /core_state_to_data eqxx. 108 | case: (C)=>_ _ _ _/(_ lc); rewrite prEqC//=; case=> C2 Inv. 109 | move: (@cn_agree lc cn pts [::] Hnin (getStatelet s lc) d.1 d.2 n C2 E Inv P)=>->. 110 | rewrite /core_state_to_data; case:ifP=>//. 111 | move=>/eqP Z; subst n; move/negbTE: Hnin=>Z. 112 | suff X: cn \in pts by rewrite X in Z. 113 | done. 114 | Qed. 115 | 116 | Lemma find_empty l i : l \notin dom i -> getStatelet i l = empty_dstatelet. 117 | Proof. by rewrite /getStatelet; case: dom_find=>//->. Qed. 118 | 119 | 120 | Definition cn_request_log := 121 | request_data_program _ pc _ _ _ _ ds_inverse _ core_state_to_data_inj Lab_neq _ cn_in_qnodes 122 | local_indicator core_state_stable_step (0, [::]). 123 | 124 | (* Coordinator loop *) 125 | Definition coordinator ds := 126 | with_inv (TwoPhaseInductiveProof.ii _ _ _) 127 | (coordinator_loop_zero lc cn pts [::] Hnin Puniq PtsNonEmpty ds). 128 | 129 | 130 | (****************************************************************) 131 | (************* Overall program combining the two *************) 132 | (****************************************************************) 133 | 134 | (* The following program first initiates a series of TPC rounds as a *) 135 | (* coordinator, and then, on behalf of the coordinator queries a *) 136 | (* particular pariticipant via the side protocol for querying. The *) 137 | (* goal is to show that the resul obtained from querying is coherent *) 138 | (* with respect to coordinator's state. *) 139 | 140 | Program Definition coordinate_and_query (ds : seq data) to : 141 | {rr : seq (nid * nat) * seq (nid * nat)}, DHT [cn, W] 142 | (fun i => 143 | let: (reqs, resp) := rr in 144 | [/\ loc_tpc i = st :-> (0, CInit) \+ log :-> ([::] : seq (bool * data)), 145 | to \in qnodes, 146 | loc_qry i = qst :-> (reqs, resp) & 147 | qry_init to i], 148 | fun (res : Data) m => 149 | let: (reqs, resp) := rr in 150 | exists (chs : seq bool), 151 | let: d := (size ds, seq.zip chs ds) in 152 | [/\ loc_tpc m = st :-> (d.1, CInit) \+ log :-> d.2, 153 | loc_qry m = qst :-> (reqs, resp), 154 | qry_init to m & 155 | res = d]) 156 | := Do _ ( 157 | iinject (coordinator ds);; 158 | cn_request_log to). 159 | 160 | Next Obligation. 161 | by exact : (query_hookz lq pc Data qnodes serialize core_state_to_data). 162 | Defined. 163 | 164 | Next Obligation. 165 | exact: (injW lq pc Data qnodes serialize core_state_to_data Lab_neq). 166 | Defined. 167 | 168 | Next Obligation. 169 | apply:ghC=>i0[rq rs][P1 P2 P3 P4]C0; apply: step. 170 | (*Preparing to split the state. *) 171 | move: (C0)=>CD0; rewrite /W eqW in CD0; move: (coh_hooks CD0)=>{CD0}CD0. 172 | case: (coh_split CD0); try apply: hook_complete0. 173 | move=>i1[j1][C1 D1 Z]. 174 | subst i0; apply: inject_rule=>//. 175 | have E : loc_tpc (i1 \+ j1) = loc_tpc i1 by rewrite (locProjL CD0 _ C1)// domPt inE andbC eqxx. 176 | rewrite E{E} in P1. 177 | apply: with_inv_rule'. 178 | apply: call_rule=>//_ i2 [chs]L2 C2 Inv j2 CD2/= R. 179 | (* Massaging the complementary state *) 180 | have E : loc_qry (i1 \+ j1) = loc_qry j1 by rewrite (locProjR CD0 _ D1)// domPt inE andbC eqxx. 181 | rewrite E {E} -(rely_loc' _ R) in P3. 182 | case: (rely_coh R)=>_ D2. 183 | rewrite /W eqW in CD2; move: (coh_hooks CD2)=>{CD2}CD2. 184 | rewrite /mkWorld/= in C2. 185 | have C2': i2 \In Coh (plab pc \\-> pc, Unit). 186 | - split=>//=. 187 | + by rewrite valid_unit validPt. 188 | + by apply: (cohS C2). 189 | + by apply: hook_complete0. 190 | + by move=>z; rewrite -(cohD C2) !domPt. 191 | move=>l; case B: (lc == l). 192 | + move/eqP:B=>B; subst l; rewrite /getProtocol findPt; split=>//. 193 | by move: (coh_coh lc C2); rewrite /getProtocol findPt. 194 | have X: l \notin dom i2 by rewrite -(cohD C2) domPt inE; move/negbT: B. 195 | rewrite /getProtocol/= (find_empty _ _ X). 196 | have Y: l \notin dom (lc \\-> pc) by rewrite domPt inE; move/negbT: B. 197 | by case: dom_find Y=>//->_. 198 | have D2': j2 \In Coh (lq \\-> pq lq Data qnodes serialize, Unit) 199 | by apply: (cohUnKR CD2 _); try apply: hook_complete0. 200 | 201 | rewrite -(locProjL CD2 _ C2') in L2; last by rewrite domPt inE eqxx. 202 | rewrite -(locProjR CD2 _ D2') in P3; last by rewrite domPt inE eqxx. 203 | clear C2 D2. 204 | 205 | (* So what's important is for the precondition ofattachment to be *) 206 | (* independent of the core protocol. *) 207 | rewrite injWQ in R. 208 | rewrite /query_init_state/= in P4. 209 | rewrite (locProjR CD0 _ D1) in P4; last by rewrite domPt inE eqxx. 210 | have Q4: qry_init to j2. 211 | - by apply: (query_init_rely' lq Data qnodes serialize cn to _ _ P4 R). 212 | clear P4. 213 | rewrite /query_init_state/= -(locProjR CD2 _ D2') in Q4; 214 | last by rewrite domPt inE eqxx. 215 | 216 | (* Now ready to use the spec for querying. *) 217 | apply (gh_ex (g:=(rq, rs, (size ds, seq.zip chs ds)))). 218 | apply: call_rule=>//=; last by move=>d m[->->T1 T2->]_; eexists _. 219 | move=>CD2'; split=>//. 220 | case/orP: P2=>[|P]; first by move/eqP=>Z; subst to; rewrite /core_state_to_data eqxx. 221 | rewrite !(locProjL CD2 _ C2') in L2 *; 222 | last by rewrite domPt inE eqxx. 223 | move: (coh_coh lc C2'); rewrite prEq; case=>C3 _. 224 | rewrite /core_state_to_data; case:ifP=>//[|_]; first by move=>/eqP Z; subst to. 225 | by apply: (@cn_agree lc cn pts [::] Hnin _ _ _ to C3 _ Inv). 226 | Qed. 227 | 228 | End QueryPlusTPC. 229 | -------------------------------------------------------------------------------- /theories/Examples/SeqLib.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep. 3 | 4 | (*************************************************************) 5 | (************ Some useful facts about sequences **************) 6 | (*************************************************************) 7 | 8 | Fixpoint remove_elem (xs : seq (nat * nat * seq nat)) e := 9 | match xs with 10 | | x :: xs => if x == e then xs else x :: (remove_elem xs e) 11 | | [::] => [::] 12 | end. 13 | 14 | Lemma remove_elem_all xs p e : 15 | all p xs -> all p (remove_elem xs e). 16 | Proof. 17 | elim:xs=>//x xs Hi/=/andP[H1 H2]. 18 | by case B: (x==e)=>//=; rewrite H1 (Hi H2). 19 | Qed. 20 | 21 | Lemma remove_elem_in xs e : 22 | if e \in xs 23 | then perm_eq (e :: (remove_elem xs e)) xs = true 24 | else (remove_elem xs e) = xs. 25 | Proof. 26 | elim: xs=>//x xs Hi. 27 | rewrite inE; case: ifP=>/=; last first. 28 | - case/negbT/norP=>/negbTE; rewrite eq_sym=>->/negbTE Z. 29 | by rewrite Z in Hi; rewrite Hi. 30 | case/orP. 31 | - by move/eqP=>Z; subst e; rewrite eqxx; apply: perm_refl. 32 | move=>Z; rewrite Z in Hi; case: ifP=>X. 33 | - by move/eqP: X=>?; subst e; apply: perm_refl. 34 | rewrite -cat1s -[x::_]cat1s-[x::xs]cat0s -[x::xs]cat1s. 35 | apply/permPl. 36 | move: (perm_catCA [::e] [::x] (remove_elem xs e))=>/permPl H1. 37 | rewrite !cat1s in H1. 38 | rewrite -(perm_cons x (e :: remove_elem xs e) xs) in Hi. 39 | rewrite !cat1s !cat0s; apply/permPl. 40 | by apply: (perm_trans H1 Hi). 41 | Qed. 42 | 43 | -------------------------------------------------------------------------------- /theories/Examples/TwoPhaseCommit/SimpleTPCApp.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import State Protocols Worlds NetworkSem Rely. 5 | From DiSeL Require Import HoareTriples InferenceRules While. 6 | From DiSeL Require Import TwoPhaseProtocol TwoPhaseCoordinator TwoPhaseParticipant. 7 | From DiSeL Require TwoPhaseInductiveProof. 8 | 9 | Section SimpleTpcApp. 10 | 11 | (* 12 | 13 | A simple application to run on the shim implementation. 14 | 15 | Check for [Run] tags to find the initial state and the code for the 16 | coordinator and the participants. 17 | 18 | *) 19 | 20 | Definition l := 0. 21 | (* Coordinator node *) 22 | Definition cn := 0. 23 | 24 | (* Participant node *) 25 | Definition p1 := 1. 26 | Definition p2 := 2. 27 | Definition p3 := 3. 28 | Definition pts := [::p1; p2; p3]. 29 | Definition others : seq nid := [::]. 30 | 31 | (* Necessary coherence facts *) 32 | Fact Hnin : cn \notin pts. Proof. by []. Qed. 33 | Fact PtsNonEmpty : pts != [::]. Proof. by []. Qed. 34 | Fact Puniq : uniq pts. Proof. by []. Qed. 35 | 36 | (* Coordinator *) 37 | Variable data_stream : seq data. 38 | Definition coordinator := 39 | coordinator_loop_zero l cn pts others Hnin Puniq PtsNonEmpty data_stream. 40 | 41 | (* Participants *) 42 | Program Definition participant p (pf : p \in pts) choices := 43 | participant_with_choices l cn pts others Hnin p pf choices. 44 | 45 | Variables (choices1 choices2 choices3 : seq bool). 46 | 47 | (* Initial distributed state *) 48 | Definition st_ptr := TPCProtocol.States.st. 49 | Definition log_ptr := TPCProtocol.States.log. 50 | 51 | Definition init_heap_c := st_ptr :-> (0, CInit) \+ log_ptr :-> ([::] : seq (bool * data)). 52 | Definition init_heap_p := st_ptr :-> (0, PInit) \+ log_ptr :-> ([::] : seq (bool * data)). 53 | 54 | Definition init_dstate := 55 | cn \\-> init_heap_c \+ 56 | p1 \\-> init_heap_p \+ 57 | p2 \\-> init_heap_p \+ 58 | p3 \\-> init_heap_p. 59 | 60 | Lemma valid_init_dstate : valid init_dstate. 61 | Proof. 62 | case: validUn=>//=; 63 | do?[case: validUn=>//; do?[rewrite ?validPt/=//]|by rewrite validPt/=]. 64 | - by move=>k; rewrite !domPt !inE/==>/eqP<-/eqP. 65 | - by move=>k; rewrite domUn!inE/==>/andP[_]/orP[]; rewrite !domPt!inE/==>/eqP=><-. 66 | move=>k; rewrite domUn!inE/==>/andP[_]/orP[]; last by rewrite !domPt!inE/==>/eqP=><-. 67 | by rewrite domUn!inE/==>/andP[_]/orP[]; rewrite !domPt!inE/==>/eqP=><-. 68 | Qed. 69 | 70 | Notation init_dstatelet := (DStatelet init_dstate Unit). 71 | 72 | (* [Run] Initial state to run *) 73 | Definition init_state : state := l \\-> init_dstatelet. 74 | 75 | Lemma getCnLoc : getLocal cn init_dstatelet = init_heap_c. 76 | Proof. 77 | rewrite /getLocal/init_dstate -!joinA findPtUn//. 78 | by rewrite !joinA valid_init_dstate. 79 | Qed. 80 | 81 | Lemma getPLoc p : p \in pts -> getLocal p init_dstatelet = init_heap_p. 82 | Proof. 83 | rewrite /pts !inE=>/orP[];[|move=>/orP[]]=>/eqP->{p}; 84 | move: valid_init_dstate; rewrite /getLocal/init_dstate. 85 | - by rewrite -!joinA joinCA=>V; rewrite findPtUn//. 86 | - by rewrite -joinA joinCA=>V; rewrite findPtUn//. 87 | by rewrite joinC=>V; rewrite findPtUn//. 88 | Qed. 89 | 90 | 91 | (* Final Safety Facts *) 92 | Notation W := (mkWorld (TwoPhaseCoordinator.tpc l cn pts others Hnin)). 93 | 94 | Lemma hook_complete_unit (c : context) : hook_complete (c, Unit). 95 | Proof. by move=>????; rewrite dom0. Qed. 96 | 97 | Lemma hooks_consistent_unit (c : context) : hooks_consistent c Unit. 98 | Proof. by move=>????; rewrite dom0. Qed. 99 | 100 | Lemma init_coh : init_state \In Coh W. 101 | Proof. 102 | split. 103 | - apply/andP; split; last by rewrite valid_unit. 104 | by rewrite validPt. 105 | - by rewrite/init_state validPt. 106 | - by apply: hook_complete_unit. 107 | - by move=>z; rewrite /init_state !domPt inE/=. 108 | move=>k; case B: (l==k); last first. 109 | - have X: (k \notin dom init_state) /\ (k \notin dom W.1). 110 | by rewrite /init_state/W/=!domPt !inE/=; move/negbT: B. 111 | rewrite /getProtocol /getStatelet/=. 112 | case: dom_find X=>//; last by move=>? _ _[]. 113 | by move=>->[_]; case: dom_find=>//->. 114 | move/eqP:B=>B; subst k; rewrite prEq/getStatelet/init_state findPt/=. 115 | split=>//=; do?[by apply: valid_init_dstate]; first by split=>//m ms; rewrite find0E. 116 | - move=>z; rewrite /init_dstate/TPCProtocol.nodes/=/others. 117 | rewrite !domUn !inE valid_init_dstate/=. 118 | rewrite !domUn !inE (validL valid_init_dstate)/=. 119 | rewrite !domUn !inE (validL (validL valid_init_dstate))/=. 120 | rewrite !domPt!inE/= !(eq_sym z). 121 | by case:(cn==z)(p1==z)(p2==z)(p3==z);case;case;case. 122 | move=>z/=; rewrite !inE=>/orP []. 123 | - move/eqP=>Z; subst z; rewrite getCnLoc; split=>//=. 124 | by exists (0, CInit), [::]. 125 | move=>H; have P : z \in pts by case/orP: H;[|case/orP]=>/eqP->. 126 | rewrite (getPLoc _ P); split=>//; case: ifP; first by move/eqP=>Z; subst z. 127 | by move=>_; rewrite P; exists (0, PInit), [::]. 128 | Qed. 129 | 130 | 131 | (* [Run] Runnable coordinator code *) 132 | Program Definition run_coordinator : 133 | DHT [cn, _] ( 134 | fun i => network_rely W cn init_state i, 135 | fun _ m => exists (chs : seq bool), 136 | let: r := size data_stream in 137 | let: lg := seq.zip chs data_stream in 138 | getLocal cn (getStatelet m l) = 139 | st :-> (r, CInit) \+ log :-> lg /\ 140 | forall pt, pt \in pts -> 141 | getLocal pt (getStatelet m l) = 142 | st :-> (r, PInit) \+ log :-> lg) 143 | := Do (with_inv (TwoPhaseInductiveProof.ii _ _ _) coordinator). 144 | Next Obligation. 145 | move=>i/=R. 146 | apply: with_inv_rule'. 147 | apply:call_rule=>//. 148 | - by rewrite (rely_loc' _ R) /getStatelet findPt/=getCnLoc. 149 | move=>_ m [chs] CS C I _. 150 | exists chs. 151 | split=>//. 152 | move=>pt Hpt. 153 | move /(coh_coh l) in C. 154 | change l with (plab (TwoPhaseInductiveProof.tpc (cn :=cn) (pts := pts) l others Hnin)) in C. 155 | rewrite prEq in C. 156 | exact: (TwoPhaseInductiveInv.cn_log_agreement(l:=l)(others:=others)(Hnin:=Hnin) C CS I Hpt). 157 | Qed. 158 | 159 | 160 | Program Definition run_participant p (pf : p \in pts) choices : 161 | DHT [p, _] ( 162 | fun i => network_rely W p init_state i, 163 | fun _ m => exists (lg : Log) (r : nat), 164 | getLocal p (getStatelet m l) = st :-> (r, PInit) \+ log :-> lg /\ 165 | forall pt' (ps' : PState) lg', pt' \in pts -> 166 | getLocal pt' (getStatelet m l) = st :-> (r, ps') \+ log :-> lg' -> lg = lg') 167 | := Do (with_inv (TwoPhaseInductiveProof.ii _ _ _ ) (participant p pf choices)). 168 | Next Obligation. 169 | move=>i/=R. 170 | apply: with_inv_rule'. 171 | apply:call_rule=>//. 172 | - by rewrite (rely_loc' _ R)/getStatelet findPt/= (getPLoc _ pf). 173 | move=>_ m [bs][ds] PS C I _. 174 | exists (seq.zip bs ds), (size choices). 175 | move /(coh_coh l) in C. 176 | change l with (plab (TwoPhaseInductiveProof.tpc (cn :=cn) (pts := pts) l others Hnin)) in C. 177 | rewrite prEq in C. 178 | split=>//. 179 | move=>pt ps' lg' Hpt PS'. 180 | apply/esym. 181 | exact: (TwoPhaseInductiveInv.pt_log_agreement(l:=l)(others:=others)(Hnin:=Hnin) C pf PS I Hpt PS' erefl). 182 | Qed. 183 | 184 | (* [Run] Runnable participants *) 185 | Program Definition run_participant1 := run_participant p1 _ choices1. 186 | Program Definition run_participant2 := run_participant p2 _ choices2. 187 | Program Definition run_participant3 := run_participant p3 _ choices3. 188 | 189 | End SimpleTpcApp. 190 | 191 | 192 | Definition data_seq := 193 | [:: [::1;2]; 194 | [::3;4]; 195 | [::5;6]; 196 | [::7;8]; 197 | [::9;10] 198 | ]. 199 | 200 | Definition choice_seq1 := [:: true; true; true; true; true]. 201 | Definition choice_seq2 := [:: true; false; true; true; true]. 202 | Definition choice_seq3 := [:: true; false; true; false; true]. 203 | 204 | (* [Run] Final programs to run with actual arguments supplied *) 205 | 206 | Definition c_runner (u : unit) := run_coordinator data_seq. 207 | 208 | Definition p_runner1 (u : unit) := run_participant1 choice_seq1. 209 | Definition p_runner2 (u : unit) := run_participant1 choice_seq2. 210 | Definition p_runner3 (u : unit) := run_participant1 choice_seq3. 211 | -------------------------------------------------------------------------------- /theories/Examples/TwoPhaseCommit/TwoPhaseClient.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 2 | From Coq Require Import Eqdep Relation_Operators. 3 | From pcm Require Import pred prelude ordtype finmap pcm unionmap heap. 4 | From DiSeL Require Import State DepMaps Protocols Worlds NetworkSem Rely. 5 | From DiSeL Require Import HoareTriples InferenceRules While. 6 | From DiSeL Require Import TwoPhaseProtocol TwoPhaseInductiveInv TwoPhaseCoordinator. 7 | From DiSeL Require Import TwoPhaseParticipant. 8 | 9 | Section TwoPhaseClient. 10 | 11 | (* 12 | 13 | This file is a stub that sketches the design of a more interesting 14 | client, where an external node (a member of the "others" crows from 15 | the TPC protocol) communicates with the TPC swarm, retrieving some 16 | information. 17 | 18 | For the sake of a cheap-and-cheerful implementation, I suggest not to 19 | add extract permission-based accounting mechanism to the state and 20 | transitions, but rather repurpose a dedicated unconstrained 21 | communication channel already present in the TPC protocol (currently 22 | represented via eval_req and eval_resp tags). 23 | 24 | Specifically, we can add the following easy-to support transitions 25 | into the TPC: 26 | 27 | - Participant nodes can broadcast the _last_ transaction from the log 28 | (successfully committed or failed, with a clearly indicated number 29 | in the common log) by sending the corresponding messages to the 30 | others. This is the only thing they can do. 31 | 32 | - The coordinator is capable of doing the same. 33 | 34 | ["Proper" client] 35 | 36 | - A potential client can then receive a message from the coordinator, 37 | stating that a specific transaction has been committed or aborted, 38 | can start two loops waiting for the corresponding (i.e., withrespect 39 | to the _same_ round) messages coming from the participants. Remember 40 | that we don't cat about liveness, so these loops migh potentially 41 | never terminate (which is okay). 42 | 43 | - Upon the termination of those two loops, the client should end up 44 | with two messages from two different participants, and be able to 45 | formally prove (out of the inductive invariant, to be formally 46 | defined) that the outcomes and the contents of those two messages 47 | (since they correpond to the same round as the previously received 48 | message from the coordinator) are equal to each other and are the 49 | same as the coordinator's outcome. 50 | 51 | - This client should, therefore, demonstrate the causality and the 52 | coherence between the events in the TPC. Indeed, the coordinator 53 | gets its log commited last in the round, meaning that the 54 | participants should already have their logs updated for the same 55 | round. This is what the inductive invariant should convey. 56 | 57 | - In fact, we can first establish the "ground" II about the coherence 58 | of logs in the system, and then, using another combinator on top of 59 | it, ensure the required property about the supplementary messages, 60 | used to poll the results. 61 | 62 | 63 | [Future Work] 64 | 65 | - Ideally, we should have a client that is also pro-active, i.e., be 66 | able to propose the values to commit and then observe the 67 | outcomes. However, this will require to either 68 | 69 | a. Supplying a mechanism of permissions, or 70 | 71 | b. Ensuring a stronger invariant about messages in the system. 72 | 73 | Both things are implementable, but intrusive for the protocol, hence 74 | I suggest to postpone it until we build a reacher set of protocol 75 | combinators, e.g., to extend the state and add new transitions. 76 | 77 | *) 78 | 79 | End TwoPhaseClient. 80 | -------------------------------------------------------------------------------- /theories/Examples/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name DiSeL.Examples) 3 | (package coq-disel-examples) 4 | (synopsis "Example systems for Disel, a separation-style logic for compositional verification of distributed systems in Coq") 5 | (flags :standard 6 | -w -notation-overridden 7 | -w -local-declaration 8 | -w -redundant-canonical-projection 9 | -w -projection-no-head-constant)) 10 | 11 | (include_subdirs qualified) 12 | --------------------------------------------------------------------------------