├── .github └── workflows │ └── docker-action.yml ├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── _CoqProject ├── build-docs.sh ├── build.v ├── coq-freespec-core.opam ├── coq-freespec-exec.opam ├── coq-freespec-ffi.opam ├── docs ├── index.html └── style.css ├── dune-project ├── examples ├── airlock.v ├── dune ├── heap.v └── smram.v ├── patches └── opam-builds.patch ├── plugins └── exec │ ├── coqbool.ml │ ├── coqbool.mli │ ├── coqbyte.ml │ ├── coqbyte.mli │ ├── coqi63.ml │ ├── coqi63.mli │ ├── coqlist.ml │ ├── coqlist.mli │ ├── coqprod.ml │ ├── coqprod.mli │ ├── coqsum.ml │ ├── coqsum.mli │ ├── coqunit.ml │ ├── coqunit.mli │ ├── dune │ ├── eval.ml │ ├── exec.ml │ ├── extends.ml │ ├── extends.mli │ ├── freespec_exec.mlpack │ ├── g_freespec_exec.mlg │ ├── heap.ml │ ├── heap.mli │ ├── interfaces.ml │ ├── interfaces.mli │ ├── query.ml │ ├── resources.ml │ ├── resources.mli │ ├── store.ml │ ├── store.mli │ └── utils.ml ├── run-tests.sh ├── tests ├── core_tactics.v ├── program_fixpoint.v └── provide_notation.v └── theories ├── Core ├── Component.v ├── ComponentFacts.v ├── Contract.v ├── Core.v ├── CoreFacts.v ├── Extraction.v ├── Hoare.v ├── HoareFacts.v ├── Impure.v ├── ImpureFacts.v ├── Init.v ├── Instrument.v ├── InstrumentFacts.v ├── Interface.v ├── Semantics.v ├── SemanticsFacts.v ├── Tactics.v ├── dune └── gen_type_classes.ml ├── Exec ├── Eval.v ├── Exec.v └── dune └── FFI ├── FFI.v ├── FreeSpecFFI.mlpack ├── ML.v ├── dune ├── refs.ml └── refs.mli /.github/workflows/docker-action.yml: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | name: Docker CI 4 | 5 | on: 6 | push: 7 | branches: 8 | - main 9 | pull_request: 10 | branches: 11 | - '**' 12 | 13 | jobs: 14 | build: 15 | # the OS must be GNU/Linux to be able to use the docker-coq-action 16 | runs-on: ubuntu-latest 17 | strategy: 18 | matrix: 19 | image: 20 | # TODO: fix support for next version of Coq 21 | # - 'coqorg/coq:dev-ocaml-4.11.1-flambda' 22 | - 'coqorg/coq:8.13-ocaml-4.11-flambda' 23 | - 'coqorg/coq:8.12-ocaml-4.11-flambda' 24 | fail-fast: false 25 | steps: 26 | - uses: actions/checkout@v2 27 | - uses: coq-community/docker-coq-action@v1 28 | with: 29 | opam_file: '.' 30 | custom_image: ${{ matrix.image }} 31 | 32 | # See also: 33 | # https://github.com/coq-community/docker-coq-action#readme 34 | # https://github.com/erikmd/docker-coq-github-action-demo 35 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Dune 2 | _build/ 3 | *.install 4 | 5 | # Coq 6 | .*.aux 7 | .*.d 8 | *.glob 9 | *.vo 10 | *.vio 11 | *.vok 12 | *.vos 13 | .lia.cache 14 | 15 | # Ocaml 16 | *.a 17 | *.cmxa 18 | *.cmxs 19 | *.d 20 | *.o 21 | *.cmi 22 | *.cmx 23 | *.cmo 24 | plugins/exec/g_freespec_exec.ml 25 | 26 | Makefile* 27 | .merlin 28 | 29 | # generated docs 30 | html 31 | mlihtml 32 | docs/coq 33 | docs/ml 34 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lthms/FreeSpec/d4e2f3a3fc7e82effddca202a8b0210dbbcf3663/.ocamlformat -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # Unreleased 2 | 3 | ## `coq-freespec-core` 4 | 5 | - Add the `StrictProvide6` and `StrictProvide7` typeclasses 6 | 7 | # FreeSpec v0.3 8 | 9 | The third tagged release of FreeSpec (git tag `freespec.0.3`) is built 10 | upon the key idea of “monads morphisms,” and finally acknowledge the 11 | relation between FreeSpec contracts and the Hoare logic. Besides, it 12 | is also the release which motivates the development of the [`coqffi` 13 | tool](https://github.com/coq-community/coqffi). Finally, it is the 14 | first tagged release to be distributed under the terms of the [MPL 15 | 2.0](https://www.mozilla.org/en-US/MPL/2.0/). 16 | 17 | # FreeSpec v0.2 18 | 19 | The second tagged release of FreeSpec (git tag `freespec-r2`) is 20 | described in depth in [“FreeSpec: Specifying, Certifying and Executing 21 | Impure Computations in Coq”](https://hal.inria.fr/hal-02422273). The 22 | focus of this release is programming and verifying “in the small,” 23 | *i.e.*, it introduces many concepts with allow to reuse programs and 24 | proofs. Besides, it first features the `Exec` vernacular command, to 25 | execute from within Coq effectful programs. 26 | 27 | # FreeSpec v0.1 28 | 29 | The first tagged release of FreeSpec (git tag `freespec-r1`) is 30 | described in depth in [“Modular Verification of Programs with Effects 31 | and Effect Handlers in Coq”](https://hal.inria.fr/hal-01799712). The 32 | focus of this release is programming and verifying “in the large,” 33 | *i.e.*, it establishes the foundation of the formalism. 34 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to FreeSpec 2 | 3 | FreeSpec is a free software distributed under the terms of the 4 | GPLv3. It remains under active development, and we welcome external 5 | contributions. 6 | 7 | ## Getting Involved 8 | 9 | The autoritative repository of FreeSpec is hosted on 10 | [GitHub](https://github.com/lthms/FreeSpec). If you have a 11 | question, if you have found a bug or if there is a feature you would 12 | want to see added to FreeSpec (and even implement it yourself), feel 13 | free to open an issue. It is always recommended to discuss a change 14 | before sending patches that implement it. 15 | 16 | ## Building from Source 17 | 18 | To build FreeSpec, the recommended approach is to create a dedicated 19 | Opam switch. Thus, starting hacking FreeSpec becomes as simple as. 20 | 21 | ``` 22 | opam switch create . ocaml-base-compiler.4.11.1 --repositories "default,coq-released,coq-extra-dev" 23 | ``` 24 | 25 | You need to have told Opam what `coq-released` and `coq-extra-dev` 26 | are. If you have not done it before, you can [read 27 | here](https://github.com/coq/opam-coq-archive) how to setup it 28 | correctly. 29 | 30 | ## Coding Style 31 | 32 | We provide several guidelines in order that contributors are expected 33 | to follow. 34 | 35 | ### Line Width 36 | 37 | The 80th column is a soft limit for line width: we can exceed it to 38 | conclude an incomplete “term”, but we cannot start a new one. The 39 | 100th column is a hard limit: we should never exceed it. 40 | 41 | So, for instance, the following line of code meets our requirement. 42 | 43 | ```coq 44 | (* good | | *) 45 | my_very_long_function_name (another_function x) (yet_another_function_even_longer y) 46 | (* | | *) 47 | ``` 48 | 49 | It exceeds the 80th column, but only to conclude the term 50 | `yet_another_function_even_longer y`. On the contrary, the following 51 | line does not meet our requirements, since we introduce a new term 52 | (here, simply `z`) after the one we were defining while exceeding the 53 | 80th column. 54 | 55 | ```coq 56 | (* good | | *) 57 | my_very_long_function_name (another_function x) (yet_another_function_even_longer y) z 58 | (* | | *) 59 | ``` 60 | 61 | ### Function Definitions and Newlines 62 | 63 | When we can, we shall not introduce newlines to function declarations. 64 | 65 | ```coq 66 | (* bad *) 67 | Definition my_function (x : nat) 68 | (y : Z) 69 | : nat := 70 | (* ... *) 71 | 72 | (* good *) 73 | Definition my_function (x : nat) (y : Z) : nat := 74 | (* ... *) 75 | ``` 76 | 77 | If a function declaration exceeds 100 characters, then a newline is 78 | required and several rules apply: 79 | 80 | 1. As far as possible, arguments of the same line should have 81 | something in common. For instance, one can reserve a line to 82 | introduce a set of arguments, and another to explicit constraints 83 | (living in `Prop`) about these arguments. 84 | 2. A line of function arguments shall start with four spaces. 85 | 3. The return type shall have its own line of the form `: :=` 86 | with two leading spaces. 87 | 88 | ```coq 89 | (* bad *) 90 | Definition my_very_long_function (x y z : complicated_type) (my_pred : a_predicate x y) (another_pred : property z) : nat := 91 | (* ... *) 92 | ``` 93 | 94 | As rule 1. is subjective, there are several acceptable ways to format a 95 | function declaration. 96 | 97 | ```coq 98 | (* good *) 99 | Definition my_very_long_function (x y z : complicated_type) 100 | (my_pred : a_predicate x y) 101 | (another_pred : property z) 102 | : nat := 103 | (* ... *) 104 | ``` 105 | 106 | ### Implicit Arguments 107 | 108 | We omit the types of implicit arguments when possible. 109 | 110 | ```coq 111 | (* bad *) 112 | Definition identity {a : Type} (x : a) : a := x. 113 | 114 | (* good *) 115 | Definition identity {a} (x : a) : a := x. 116 | ``` 117 | 118 | When Coq provides us the means to declare a function argument as 119 | implicit while defining the function itself (*e.g.*, with the 120 | `Definition` keyword for instance), we prefer this approach. 121 | 122 | ```coq 123 | (* bad *) 124 | Definition identity a (x : a) : a := x. 125 | Arguments identity [a] (x). 126 | 127 | (* good *) 128 | Definition identity {a} (x : a) : a := x. 129 | ``` 130 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Mozilla Public License Version 2.0 2 | ================================== 3 | 4 | 1. Definitions 5 | -------------- 6 | 7 | 1.1. "Contributor" 8 | means each individual or legal entity that creates, contributes to 9 | the creation of, or owns Covered Software. 10 | 11 | 1.2. "Contributor Version" 12 | means the combination of the Contributions of others (if any) used 13 | by a Contributor and that particular Contributor's Contribution. 14 | 15 | 1.3. "Contribution" 16 | means Covered Software of a particular Contributor. 17 | 18 | 1.4. "Covered Software" 19 | means Source Code Form to which the initial Contributor has attached 20 | the notice in Exhibit A, the Executable Form of such Source Code 21 | Form, and Modifications of such Source Code Form, in each case 22 | including portions thereof. 23 | 24 | 1.5. "Incompatible With Secondary Licenses" 25 | means 26 | 27 | (a) that the initial Contributor has attached the notice described 28 | in Exhibit B to the Covered Software; or 29 | 30 | (b) that the Covered Software was made available under the terms of 31 | version 1.1 or earlier of the License, but not also under the 32 | terms of a Secondary License. 33 | 34 | 1.6. "Executable Form" 35 | means any form of the work other than Source Code Form. 36 | 37 | 1.7. "Larger Work" 38 | means a work that combines Covered Software with other material, in 39 | a separate file or files, that is not Covered Software. 40 | 41 | 1.8. "License" 42 | means this document. 43 | 44 | 1.9. "Licensable" 45 | means having the right to grant, to the maximum extent possible, 46 | whether at the time of the initial grant or subsequently, any and 47 | all of the rights conveyed by this License. 48 | 49 | 1.10. "Modifications" 50 | means any of the following: 51 | 52 | (a) any file in Source Code Form that results from an addition to, 53 | deletion from, or modification of the contents of Covered 54 | Software; or 55 | 56 | (b) any new file in Source Code Form that contains any Covered 57 | Software. 58 | 59 | 1.11. "Patent Claims" of a Contributor 60 | means any patent claim(s), including without limitation, method, 61 | process, and apparatus claims, in any patent Licensable by such 62 | Contributor that would be infringed, but for the grant of the 63 | License, by the making, using, selling, offering for sale, having 64 | made, import, or transfer of either its Contributions or its 65 | Contributor Version. 66 | 67 | 1.12. "Secondary License" 68 | means either the GNU General Public License, Version 2.0, the GNU 69 | Lesser General Public License, Version 2.1, the GNU Affero General 70 | Public License, Version 3.0, or any later versions of those 71 | licenses. 72 | 73 | 1.13. "Source Code Form" 74 | means the form of the work preferred for making modifications. 75 | 76 | 1.14. "You" (or "Your") 77 | means an individual or a legal entity exercising rights under this 78 | License. For legal entities, "You" includes any entity that 79 | controls, is controlled by, or is under common control with You. For 80 | purposes of this definition, "control" means (a) the power, direct 81 | or indirect, to cause the direction or management of such entity, 82 | whether by contract or otherwise, or (b) ownership of more than 83 | fifty percent (50%) of the outstanding shares or beneficial 84 | ownership of such entity. 85 | 86 | 2. License Grants and Conditions 87 | -------------------------------- 88 | 89 | 2.1. Grants 90 | 91 | Each Contributor hereby grants You a world-wide, royalty-free, 92 | non-exclusive license: 93 | 94 | (a) under intellectual property rights (other than patent or trademark) 95 | Licensable by such Contributor to use, reproduce, make available, 96 | modify, display, perform, distribute, and otherwise exploit its 97 | Contributions, either on an unmodified basis, with Modifications, or 98 | as part of a Larger Work; and 99 | 100 | (b) under Patent Claims of such Contributor to make, use, sell, offer 101 | for sale, have made, import, and otherwise transfer either its 102 | Contributions or its Contributor Version. 103 | 104 | 2.2. Effective Date 105 | 106 | The licenses granted in Section 2.1 with respect to any Contribution 107 | become effective for each Contribution on the date the Contributor first 108 | distributes such Contribution. 109 | 110 | 2.3. Limitations on Grant Scope 111 | 112 | The licenses granted in this Section 2 are the only rights granted under 113 | this License. No additional rights or licenses will be implied from the 114 | distribution or licensing of Covered Software under this License. 115 | Notwithstanding Section 2.1(b) above, no patent license is granted by a 116 | Contributor: 117 | 118 | (a) for any code that a Contributor has removed from Covered Software; 119 | or 120 | 121 | (b) for infringements caused by: (i) Your and any other third party's 122 | modifications of Covered Software, or (ii) the combination of its 123 | Contributions with other software (except as part of its Contributor 124 | Version); or 125 | 126 | (c) under Patent Claims infringed by Covered Software in the absence of 127 | its Contributions. 128 | 129 | This License does not grant any rights in the trademarks, service marks, 130 | or logos of any Contributor (except as may be necessary to comply with 131 | the notice requirements in Section 3.4). 132 | 133 | 2.4. Subsequent Licenses 134 | 135 | No Contributor makes additional grants as a result of Your choice to 136 | distribute the Covered Software under a subsequent version of this 137 | License (see Section 10.2) or under the terms of a Secondary License (if 138 | permitted under the terms of Section 3.3). 139 | 140 | 2.5. Representation 141 | 142 | Each Contributor represents that the Contributor believes its 143 | Contributions are its original creation(s) or it has sufficient rights 144 | to grant the rights to its Contributions conveyed by this License. 145 | 146 | 2.6. Fair Use 147 | 148 | This License is not intended to limit any rights You have under 149 | applicable copyright doctrines of fair use, fair dealing, or other 150 | equivalents. 151 | 152 | 2.7. Conditions 153 | 154 | Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted 155 | in Section 2.1. 156 | 157 | 3. Responsibilities 158 | ------------------- 159 | 160 | 3.1. Distribution of Source Form 161 | 162 | All distribution of Covered Software in Source Code Form, including any 163 | Modifications that You create or to which You contribute, must be under 164 | the terms of this License. You must inform recipients that the Source 165 | Code Form of the Covered Software is governed by the terms of this 166 | License, and how they can obtain a copy of this License. You may not 167 | attempt to alter or restrict the recipients' rights in the Source Code 168 | Form. 169 | 170 | 3.2. Distribution of Executable Form 171 | 172 | If You distribute Covered Software in Executable Form then: 173 | 174 | (a) such Covered Software must also be made available in Source Code 175 | Form, as described in Section 3.1, and You must inform recipients of 176 | the Executable Form how they can obtain a copy of such Source Code 177 | Form by reasonable means in a timely manner, at a charge no more 178 | than the cost of distribution to the recipient; and 179 | 180 | (b) You may distribute such Executable Form under the terms of this 181 | License, or sublicense it under different terms, provided that the 182 | license for the Executable Form does not attempt to limit or alter 183 | the recipients' rights in the Source Code Form under this License. 184 | 185 | 3.3. Distribution of a Larger Work 186 | 187 | You may create and distribute a Larger Work under terms of Your choice, 188 | provided that You also comply with the requirements of this License for 189 | the Covered Software. If the Larger Work is a combination of Covered 190 | Software with a work governed by one or more Secondary Licenses, and the 191 | Covered Software is not Incompatible With Secondary Licenses, this 192 | License permits You to additionally distribute such Covered Software 193 | under the terms of such Secondary License(s), so that the recipient of 194 | the Larger Work may, at their option, further distribute the Covered 195 | Software under the terms of either this License or such Secondary 196 | License(s). 197 | 198 | 3.4. Notices 199 | 200 | You may not remove or alter the substance of any license notices 201 | (including copyright notices, patent notices, disclaimers of warranty, 202 | or limitations of liability) contained within the Source Code Form of 203 | the Covered Software, except that You may alter any license notices to 204 | the extent required to remedy known factual inaccuracies. 205 | 206 | 3.5. Application of Additional Terms 207 | 208 | You may choose to offer, and to charge a fee for, warranty, support, 209 | indemnity or liability obligations to one or more recipients of Covered 210 | Software. However, You may do so only on Your own behalf, and not on 211 | behalf of any Contributor. You must make it absolutely clear that any 212 | such warranty, support, indemnity, or liability obligation is offered by 213 | You alone, and You hereby agree to indemnify every Contributor for any 214 | liability incurred by such Contributor as a result of warranty, support, 215 | indemnity or liability terms You offer. You may include additional 216 | disclaimers of warranty and limitations of liability specific to any 217 | jurisdiction. 218 | 219 | 4. Inability to Comply Due to Statute or Regulation 220 | --------------------------------------------------- 221 | 222 | If it is impossible for You to comply with any of the terms of this 223 | License with respect to some or all of the Covered Software due to 224 | statute, judicial order, or regulation then You must: (a) comply with 225 | the terms of this License to the maximum extent possible; and (b) 226 | describe the limitations and the code they affect. Such description must 227 | be placed in a text file included with all distributions of the Covered 228 | Software under this License. Except to the extent prohibited by statute 229 | or regulation, such description must be sufficiently detailed for a 230 | recipient of ordinary skill to be able to understand it. 231 | 232 | 5. Termination 233 | -------------- 234 | 235 | 5.1. The rights granted under this License will terminate automatically 236 | if You fail to comply with any of its terms. However, if You become 237 | compliant, then the rights granted under this License from a particular 238 | Contributor are reinstated (a) provisionally, unless and until such 239 | Contributor explicitly and finally terminates Your grants, and (b) on an 240 | ongoing basis, if such Contributor fails to notify You of the 241 | non-compliance by some reasonable means prior to 60 days after You have 242 | come back into compliance. Moreover, Your grants from a particular 243 | Contributor are reinstated on an ongoing basis if such Contributor 244 | notifies You of the non-compliance by some reasonable means, this is the 245 | first time You have received notice of non-compliance with this License 246 | from such Contributor, and You become compliant prior to 30 days after 247 | Your receipt of the notice. 248 | 249 | 5.2. If You initiate litigation against any entity by asserting a patent 250 | infringement claim (excluding declaratory judgment actions, 251 | counter-claims, and cross-claims) alleging that a Contributor Version 252 | directly or indirectly infringes any patent, then the rights granted to 253 | You by any and all Contributors for the Covered Software under Section 254 | 2.1 of this License shall terminate. 255 | 256 | 5.3. In the event of termination under Sections 5.1 or 5.2 above, all 257 | end user license agreements (excluding distributors and resellers) which 258 | have been validly granted by You or Your distributors under this License 259 | prior to termination shall survive termination. 260 | 261 | ************************************************************************ 262 | * * 263 | * 6. Disclaimer of Warranty * 264 | * ------------------------- * 265 | * * 266 | * Covered Software is provided under this License on an "as is" * 267 | * basis, without warranty of any kind, either expressed, implied, or * 268 | * statutory, including, without limitation, warranties that the * 269 | * Covered Software is free of defects, merchantable, fit for a * 270 | * particular purpose or non-infringing. The entire risk as to the * 271 | * quality and performance of the Covered Software is with You. * 272 | * Should any Covered Software prove defective in any respect, You * 273 | * (not any Contributor) assume the cost of any necessary servicing, * 274 | * repair, or correction. This disclaimer of warranty constitutes an * 275 | * essential part of this License. No use of any Covered Software is * 276 | * authorized under this License except under this disclaimer. * 277 | * * 278 | ************************************************************************ 279 | 280 | ************************************************************************ 281 | * * 282 | * 7. Limitation of Liability * 283 | * -------------------------- * 284 | * * 285 | * Under no circumstances and under no legal theory, whether tort * 286 | * (including negligence), contract, or otherwise, shall any * 287 | * Contributor, or anyone who distributes Covered Software as * 288 | * permitted above, be liable to You for any direct, indirect, * 289 | * special, incidental, or consequential damages of any character * 290 | * including, without limitation, damages for lost profits, loss of * 291 | * goodwill, work stoppage, computer failure or malfunction, or any * 292 | * and all other commercial damages or losses, even if such party * 293 | * shall have been informed of the possibility of such damages. This * 294 | * limitation of liability shall not apply to liability for death or * 295 | * personal injury resulting from such party's negligence to the * 296 | * extent applicable law prohibits such limitation. Some * 297 | * jurisdictions do not allow the exclusion or limitation of * 298 | * incidental or consequential damages, so this exclusion and * 299 | * limitation may not apply to You. * 300 | * * 301 | ************************************************************************ 302 | 303 | 8. Litigation 304 | ------------- 305 | 306 | Any litigation relating to this License may be brought only in the 307 | courts of a jurisdiction where the defendant maintains its principal 308 | place of business and such litigation shall be governed by laws of that 309 | jurisdiction, without reference to its conflict-of-law provisions. 310 | Nothing in this Section shall prevent a party's ability to bring 311 | cross-claims or counter-claims. 312 | 313 | 9. Miscellaneous 314 | ---------------- 315 | 316 | This License represents the complete agreement concerning the subject 317 | matter hereof. If any provision of this License is held to be 318 | unenforceable, such provision shall be reformed only to the extent 319 | necessary to make it enforceable. Any law or regulation which provides 320 | that the language of a contract shall be construed against the drafter 321 | shall not be used to construe this License against a Contributor. 322 | 323 | 10. Versions of the License 324 | --------------------------- 325 | 326 | 10.1. New Versions 327 | 328 | Mozilla Foundation is the license steward. Except as provided in Section 329 | 10.3, no one other than the license steward has the right to modify or 330 | publish new versions of this License. Each version will be given a 331 | distinguishing version number. 332 | 333 | 10.2. Effect of New Versions 334 | 335 | You may distribute the Covered Software under the terms of the version 336 | of the License under which You originally received the Covered Software, 337 | or under the terms of any subsequent version published by the license 338 | steward. 339 | 340 | 10.3. Modified Versions 341 | 342 | If you create software not governed by this License, and you want to 343 | create a new license for such software, you may create and use a 344 | modified version of this License if you rename the license and remove 345 | any references to the name of the license steward (except to note that 346 | such modified license differs from this License). 347 | 348 | 10.4. Distributing Source Code Form that is Incompatible With Secondary 349 | Licenses 350 | 351 | If You choose to distribute Source Code Form that is Incompatible With 352 | Secondary Licenses under the terms of this version of the License, the 353 | notice described in Exhibit B of this License must be attached. 354 | 355 | Exhibit A - Source Code Form License Notice 356 | ------------------------------------------- 357 | 358 | This Source Code Form is subject to the terms of the Mozilla Public 359 | License, v. 2.0. If a copy of the MPL was not distributed with this 360 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 361 | 362 | If it is not possible or desirable to put the notice in a particular 363 | file, then You may include the notice in a location (such as a LICENSE 364 | file in a relevant directory) where a recipient would be likely to look 365 | for such a notice. 366 | 367 | You may add additional accurate notices of copyright ownership. 368 | 369 | Exhibit B - "Incompatible With Secondary Licenses" Notice 370 | --------------------------------------------------------- 371 | 372 | This Source Code Form is "Incompatible With Secondary Licenses", as 373 | defined by the Mozilla Public License, v. 2.0. 374 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # FreeSpec 2 | 3 | FreeSpec is a framework for implementing, certifying, and executing 4 | impure computations in Coq. 5 | 6 | ## Overview 7 | 8 | This repository contains three Coq packages: 9 | 10 | - `coq-freespec-core` provides the foundation of the FreeSpec formalism. 11 | - `coq-freespec-exec` provides the means to execute impure 12 | computations implemented with the help of `coq-freespec-core`. 13 | - `coq-freespec-ffi` provides the means to use FreeSpec with `coqffi`. 14 | 15 | The codebase is organized as follows: 16 | 17 | - The Coq definitions of the three theories live in the `theories/` 18 | directory. 19 | - The OCaml source of the Coq plugins live in the `plugins/` directory. 20 | - There are examples for the three plugins in the `examples/` directory. 21 | 22 | ## Getting Started 23 | 24 | `coq-freespec-core` depends on 25 | [coq-ext-lib](https://github.com/coq-community/coq-ext-lib). Besides, 26 | `coq-freespec-ffi` depends on 27 | [`coqffi`](https://github.com/coq-community/coqffi). 28 | 29 | ```bash 30 | dune build 31 | dune install 32 | ``` 33 | 34 | Besides, we provide two helper scripts: 35 | 36 | - `run-tests.sh` executes each Coq file living in `tests/` and reports 37 | any error 38 | - `build-docs.sh` builds the OCaml and Coq source documentation 39 | 40 | Said documentations are published 41 | [here](https://lthms.github.io/FreeSpec). 42 | 43 | In addition, FreeSpec has been the subject of two academic 44 | publications. 45 | 46 | - [**FreeSpec: Specifying, Certifying and Executing Impure Computations 47 | in Coq**](https://hal.inria.fr/hal-02422273) (CPP'20) 48 | - [**Modular Verification of Programs with Effects and Effect Handlers in 49 | Coq**](https://hal.inria.fr/hal-01799712) (FM'18) 50 | 51 | ## Credit 52 | 53 | FreeSpec is a Free Software, distributed under the terms of the MPLv2. 54 | It was initially developed within the the [French Cybersecurity Agency 55 | (ANSSI)](https://ssi.gouv.fr/en). 56 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -I _build/default/plugins/exec 2 | -I _build/default/theories/FFI/ 3 | -Q _build/default/theories/Core FreeSpec.Core 4 | -Q _build/default/theories/Exec FreeSpec.Exec 5 | -Q _build/default/theories/FFI FreeSpec.FFI 6 | -arg -init-file 7 | -arg build.v 8 | 9 | _build/default/theories/FFI/refs.ml 10 | _build/default/theories/FFI/refs.mli 11 | 12 | _build/default/plugins/exec/coqbool.ml 13 | _build/default/plugins/exec/coqbool.mli 14 | _build/default/plugins/exec/coqbyte.ml 15 | _build/default/plugins/exec/coqbyte.mli 16 | _build/default/plugins/exec/coqi63.ml 17 | _build/default/plugins/exec/coqi63.mli 18 | _build/default/plugins/exec/coqlist.ml 19 | _build/default/plugins/exec/coqlist.mli 20 | _build/default/plugins/exec/coqprod.ml 21 | _build/default/plugins/exec/coqprod.mli 22 | _build/default/plugins/exec/coqsum.mli 23 | _build/default/plugins/exec/coqunit.ml 24 | _build/default/plugins/exec/coqunit.mli 25 | _build/default/plugins/exec/eval.ml 26 | _build/default/plugins/exec/exec.ml 27 | _build/default/plugins/exec/interfaces.ml 28 | _build/default/plugins/exec/interfaces.mli 29 | _build/default/plugins/exec/extends.ml 30 | _build/default/plugins/exec/extends.mli 31 | _build/default/plugins/exec/heap.ml 32 | _build/default/plugins/exec/heap.mli 33 | _build/default/plugins/exec/query.ml 34 | _build/default/plugins/exec/resources.ml 35 | _build/default/plugins/exec/resources.mli 36 | _build/default/plugins/exec/store.ml 37 | _build/default/plugins/exec/store.mli 38 | _build/default/plugins/exec/utils.ml 39 | _build/default/plugins/exec/g_freespec_exec.mlg 40 | 41 | _build/default/theories/Core/Init.v 42 | 43 | _build/default/theories/Core/Interface.v 44 | _build/default/theories/Core/Typeclasses.v 45 | _build/default/theories/Core/Impure.v 46 | _build/default/theories/Core/Semantics.v 47 | _build/default/theories/Core/Component.v 48 | 49 | _build/default/theories/Core/Contract.v 50 | _build/default/theories/Core/ImpureFacts.v 51 | _build/default/theories/Core/SemanticsFacts.v 52 | _build/default/theories/Core/Hoare.v 53 | _build/default/theories/Core/HoareFacts.v 54 | _build/default/theories/Core/Instrument.v 55 | _build/default/theories/Core/InstrumentFacts.v 56 | _build/default/theories/Core/ComponentFacts.v 57 | _build/default/theories/Core/Tactics.v 58 | 59 | _build/default/theories/Core/Core.v 60 | _build/default/theories/Core/CoreFacts.v 61 | _build/default/theories/Core/Extraction.v 62 | 63 | _build/default/theories/FFI/Refs.v 64 | _build/default/theories/FFI/FFI.v 65 | _build/default/theories/FFI/ML.v 66 | 67 | _build/default/theories/Exec/Eval.v 68 | _build/default/theories/Exec/Exec.v 69 | 70 | _build/default/examples/airlock.v 71 | _build/default/examples/smram.v 72 | _build/default/examples/heap.v -------------------------------------------------------------------------------- /build-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # This Source Code Form is subject to the terms of the Mozilla Public 4 | # License, v. 2.0. If a copy of the MPL was not distributed with this 5 | # file, You can obtain one at https://mozilla.org/MPL/2.0/. 6 | 7 | set -e 8 | 9 | dune build 10 | chmod -R +w _build/ 11 | coq_makefile -f _CoqProject -o Makefile 12 | make html mlihtml 13 | mkdir -p docs/ 14 | rm -rf docs/coq docs/ml 15 | mv html docs/coq 16 | mv mlihtml docs/ml 17 | dune clean 18 | -------------------------------------------------------------------------------- /build.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | (* Coq Set-up *) 8 | 9 | Generalizable All Variables. 10 | 11 | (** * Coq Stdlib Notations *) 12 | 13 | From Coq Require Export List RelationClasses Setoid Morphisms. 14 | Import ListNotations. 15 | 16 | Open Scope signature_scope. 17 | Close Scope nat_scope. 18 | Open Scope bool_scope. 19 | 20 | From ExtLib Require Import Functor Applicative Monad. 21 | Import FunctorNotation. 22 | Import ApplicativeNotation. 23 | Import MonadLetNotation. 24 | 25 | Open Scope monad_scope. 26 | 27 | From ExtLib Require Import Extras. 28 | Import FunNotation. 29 | -------------------------------------------------------------------------------- /coq-freespec-core.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Thomas Letan " 3 | version: "dev" 4 | 5 | homepage: "https://github.com/lthms/FreeSpec" 6 | dev-repo: "git+https://github.com/lthms/FreeSpec.git" 7 | bug-reports: "https://github.com/lthms/FreeSpec.git/issues" 8 | doc: "https://lthms.github.io/FreeSpec" 9 | license: "MPL-2.0" 10 | 11 | synopsis: "A framework for implementing and certifying impure computations in Coq" 12 | description: """ 13 | FreeSpec is a framework for the Coq proof assistant which allows to 14 | implement and specify impure computations. This is the core of the 15 | framework: it provides the foundation of the formalism, based on the 16 | freer monad, the reasoning theory and tactics to automate the 17 | reasoning. 18 | """ 19 | 20 | build: [ 21 | ["patch" "-p1" "-i" "patches/opam-builds.patch"] 22 | ["dune" "build" "-p" name "-j" jobs] 23 | ] 24 | 25 | depends: [ 26 | "ocaml" 27 | "dune" {>= "2.5"} 28 | "coq" {>= "8.12" & < "8.14~" | = "dev"} 29 | "coq-ext-lib" {>= "0.11.2" | = "dev"} 30 | ] 31 | 32 | tags: [ 33 | "keyword:effect" 34 | "keyword:freer" 35 | "keyword:program logic" 36 | "category:Mathematics/Category Theory" 37 | "logpath:FreeSpec.Core" 38 | ] 39 | 40 | authors: [ 41 | "Thomas Letan" 42 | "Yann Régis-Gianas" 43 | ] 44 | 45 | url { 46 | src: "git+https://github.com/lthms/FreeSpec.git#master" 47 | } 48 | -------------------------------------------------------------------------------- /coq-freespec-exec.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Thomas Letan " 3 | version: "dev" 4 | 5 | homepage: "https://github.com/lthms/FreeSpec" 6 | dev-repo: "git+https://github.com/lthms/FreeSpec.git" 7 | bug-reports: "https://github.com/lthms/FreeSpec.git/issues" 8 | doc: "https://lthms.github.io/FreeSpec" 9 | license: "MPL-2.0" 10 | 11 | synopsis: "A framework for implementing and certifying impure computations in Coq" 12 | description: """ 13 | FreeSpec is a framework for the Coq proof assistant which allows to 14 | implement and specify impure computations. This is the “exec” plugin, 15 | which allows from executing impure computations from with Coq thanks 16 | to a dedicated vernacular command. 17 | """ 18 | 19 | build: [ 20 | ["patch" "-p1" "-i" "patches/opam-builds.patch"] 21 | ["dune" "build" "-p" name "-j" jobs] 22 | ] 23 | 24 | depends: [ 25 | "ocaml" 26 | "dune" {>= "2.5"} 27 | "coq" {>= "8.12" & < "8.14~" | = "dev"} 28 | "coq-freespec-core" {= "dev"} 29 | "coq-freespec-ffi" {= "dev"} 30 | ] 31 | 32 | tags: [ 33 | "keyword:plugin" 34 | "category:Miscellaneous/Coq Extensions" 35 | "logpath:FreeSpec.Exec" 36 | ] 37 | 38 | authors: [ 39 | "Thomas Letan" 40 | "Yann Régis-Gianas" 41 | ] 42 | 43 | url { 44 | src: "git+https://github.com/lthms/FreeSpec.git#master" 45 | } 46 | -------------------------------------------------------------------------------- /coq-freespec-ffi.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Thomas Letan " 3 | version: "dev" 4 | 5 | homepage: "https://github.com/lthms/FreeSpec" 6 | dev-repo: "git+https://github.com/lthms/FreeSpec.git" 7 | bug-reports: "https://github.com/lthms/FreeSpec.git/issues" 8 | doc: "https://lthms.github.io/FreeSpec" 9 | license: "MPL-2.0" 10 | 11 | synopsis: "A framework for implementing and certifying impure computations in Coq" 12 | description: """ 13 | FreeSpec is a framework for the Coq proof assistant which allows to 14 | implement and specify impure computations. It can be used with coqffi 15 | to write certified software. 16 | """ 17 | 18 | build: [ 19 | ["patch" "-p1" "-i" "patches/opam-builds.patch"] 20 | ["dune" "build" "-p" name "-j" jobs] 21 | ] 22 | 23 | depends: [ 24 | "ocaml" 25 | "dune" {>= "2.5"} 26 | "coq" {>= "8.12" & < "8.14~" | = "dev"} 27 | "coq-freespec-core" {= "dev"} 28 | "coq-coqffi" {= "dev" | >= "1.0~"} 29 | "coq-simple-io" {>= "1.0" & < "2.0" | = "dev"} 30 | ] 31 | 32 | tags: [ 33 | "keyword:foreign function interface" 34 | "category:Miscellaneous/Coq Extensions" 35 | "logpath:FreeSpec.FFI" 36 | ] 37 | 38 | authors: [ 39 | "Thomas Letan" 40 | "Yann Régis-Gianas" 41 | ] 42 | 43 | url { 44 | src: "git+https://github.com/lthms/FreeSpec.git#master" 45 | } 46 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | FreeSpec 6 | 7 | 8 | 9 |

10 | FreeSpec 11 |

12 | 13 |

14 | FreeSpec is a compositional reasoning framework for the Coq proof assistant. 15 | 16 | It aims at providing facilities to modularly implement, specify and verify 17 | complex systems built with a collection of interconnected components. 18 |

19 | 20 |

21 | Although FreeSpec remains a work-in-progress, efforts have been made to 22 | ensure interested users can already use it. 23 |

24 | 25 |

26 | Documentation 27 |

28 | 29 |
    30 |
  • 31 | In accordance with Coq community best practice, the codebase has been 32 | heavily commented, and pretty-printed thanks to coqdoc. 33 | 34 | [Read more] 35 |
    • 36 |
  • 37 | FreeSpec provides a plugin called FreeSpec.Exec, whose main 38 | feature is to be extensible. 39 | 40 | [Read more] 41 |
    • 42 |
43 | 44 | 45 | -------------------------------------------------------------------------------- /docs/style.css: -------------------------------------------------------------------------------- 1 | html { 2 | width: 100%; 3 | height: 100%; 4 | font-size: 100%; 5 | } 6 | 7 | body { 8 | max-width: 600px; 9 | padding: .5em; 10 | color: #444; 11 | } 12 | 13 | h1, h2, h3 { 14 | padding: 0 0 .3em 0; 15 | margin: 0; 16 | font-family: sans-serif; 17 | color: black; 18 | } 19 | 20 | a { 21 | color: black; 22 | } 23 | 24 | blockquote { 25 | font-style: italic; 26 | border-left: 3px solid #ddd; 27 | padding: 0 .5em 0 .5em; 28 | } 29 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.5) 2 | (using coq 0.2) -------------------------------------------------------------------------------- /examples/airlock.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From Coq Require Import Arith. 8 | From FreeSpec.Core Require Import Core CoreFacts. 9 | 10 | #[local] Open Scope nat_scope. 11 | 12 | Create HintDb airlock. 13 | 14 | (** * Specifying *) 15 | 16 | (** ** Doors *) 17 | 18 | Inductive door : Type := left | right. 19 | 20 | Definition door_eq_dec (d d' : door) : { d = d' } + { ~ d = d' } := 21 | ltac:(decide equality). 22 | 23 | Inductive DOORS : interface := 24 | | IsOpen : door -> DOORS bool 25 | | Toggle : door -> DOORS unit. 26 | 27 | Generalizable All Variables. 28 | 29 | Definition is_open `{Provide ix DOORS} (d : door) : impure ix bool := 30 | request (IsOpen d). 31 | 32 | Definition toggle `{Provide ix DOORS} (d : door) : impure ix unit := 33 | request (Toggle d). 34 | 35 | Definition open_door `{Provide ix DOORS} (d : door) : impure ix unit := 36 | let* open := is_open d in 37 | when (negb open) (toggle d). 38 | 39 | Definition close_door `{Provide ix DOORS} (d : door) : impure ix unit := 40 | let* open := is_open d in 41 | when open (toggle d). 42 | 43 | (** ** Controller *) 44 | 45 | Inductive CONTROLLER : interface := 46 | | Tick : CONTROLLER unit 47 | | RequestOpen (d : door) : CONTROLLER unit. 48 | 49 | Definition tick `{Provide ix CONTROLLER} : impure ix unit := 50 | request Tick. 51 | 52 | Definition request_open `{Provide ix CONTROLLER} (d : door) : impure ix unit := 53 | request (RequestOpen d). 54 | 55 | Definition co (d : door) : door := 56 | match d with 57 | | left => right 58 | | right => left 59 | end. 60 | 61 | Definition controller `{Provide ix DOORS, Provide ix (STORE nat)} 62 | : component CONTROLLER ix := 63 | fun _ op => 64 | match op with 65 | | Tick => 66 | let* cpt := get in 67 | when (15 73 | close_door (co d);; 74 | open_door d;; 75 | put 0 76 | end. 77 | 78 | (** * Verifying the Airlock Controller *) 79 | 80 | (** ** Doors Specification *) 81 | 82 | (** *** Witness States *) 83 | 84 | Definition Ω : Type := bool * bool. 85 | 86 | Definition sel (d : door) : Ω -> bool := 87 | match d with 88 | | left => fst 89 | | right => snd 90 | end. 91 | 92 | Definition tog (d : door) (ω : Ω) : Ω := 93 | match d with 94 | | left => (negb (fst ω), snd ω) 95 | | right => (fst ω, negb (snd ω)) 96 | end. 97 | 98 | Lemma tog_equ_1 (d : door) (ω : Ω) 99 | : sel d (tog d ω) = negb (sel d ω). 100 | 101 | Proof. 102 | destruct d; reflexivity. 103 | Qed. 104 | 105 | Lemma tog_equ_2 (d : door) (ω : Ω) 106 | : sel (co d) (tog d ω) = sel (co d) ω. 107 | 108 | Proof. 109 | destruct d; reflexivity. 110 | Qed. 111 | 112 | (** From now on, we will reason about [tog] using [tog_equ_1] and [tog_equ_2]. 113 | FreeSpec tactics rely heavily on [cbn] to simplify certain terms, so we use 114 | the <> options of the [Arguments] vernacular command to prevent 115 | [cbn] from unfolding [tog]. 116 | 117 | This pattern is common in FreeSpec. Later in this example, we will use this 118 | trick to prevent [cbn] to unfold impure computations covered by intermediary 119 | theorems. *) 120 | 121 | #[local] Opaque tog. 122 | 123 | Definition step (ω : Ω) (a : Type) (e : DOORS a) (x : a) := 124 | match e with 125 | | Toggle d => tog d ω 126 | | _ => ω 127 | end. 128 | 129 | (** *** Requirements *) 130 | 131 | Inductive doors_o_caller : Ω -> forall (a : Type), DOORS a -> Prop := 132 | 133 | (** - Given the door [d] of o system [ω], it is always possible to ask for the 134 | state of [d]. *) 135 | 136 | | req_is_open (d : door) (ω : Ω) 137 | : doors_o_caller ω bool (IsOpen d) 138 | 139 | (** - Given the door [d] of o system [ω], if [d] is closed, then the second door 140 | [co d] has to be closed too for a request to toggle [d] to be valid. *) 141 | 142 | | req_toggle (d : door) (ω : Ω) (H : sel d ω = false -> sel (co d) ω = false) 143 | : doors_o_caller ω unit (Toggle d). 144 | 145 | #[global] Hint Constructors doors_o_caller : airlock. 146 | 147 | (** *** Promises *) 148 | 149 | Inductive doors_o_callee : Ω -> forall (a : Type), DOORS a -> a -> Prop := 150 | 151 | (** - When a system in a state [ω] reports the state of the door [d], it shall 152 | reflect the true state of [d]. *) 153 | 154 | | doors_o_callee_is_open (d : door) (ω : Ω) (x : bool) (equ : sel d ω = x) 155 | : doors_o_callee ω bool (IsOpen d) x 156 | 157 | (** - There is no particular doors_o_calleeises on the result [x] of a request for [ω] to 158 | close the door [d]. *) 159 | 160 | | doors_o_callee_toggle (d : door) (ω : Ω) (x : unit) 161 | : doors_o_callee ω unit (Toggle d) x. 162 | 163 | #[global] Hint Constructors doors_o_callee : airlock. 164 | 165 | Definition doors_contract : contract DOORS Ω := 166 | make_contract step doors_o_caller doors_o_callee. 167 | 168 | (** ** Intermediary Lemmas *) 169 | 170 | (** Closing a door [d] in any system [ω] is always a respectful operation. *) 171 | 172 | Lemma close_door_respectful `{Provide ix DOORS} (ω : Ω) (d : door) 173 | : pre (to_hoare doors_contract (close_door d)) ω. 174 | 175 | Proof. 176 | (* We use the [prove_program] tactics to erase the program monad *) 177 | 178 | prove impure with airlock; subst; constructor. 179 | 180 | (* This leaves us with one goal to prove: 181 | 182 | [sel d ω = false -> sel (co d) ω = false] 183 | 184 | Yet, thanks to our call to [IsOpen d], we can predict that 185 | 186 | [sel d ω = true] *) 187 | 188 | inversion o_caller0; ssubst. 189 | now rewrite H3. 190 | Qed. 191 | 192 | #[global] Hint Resolve close_door_respectful : airlock. 193 | 194 | Lemma open_door_respectful `{Provide ix DOORS} (ω : Ω) 195 | (d : door) (safe : sel (co d) ω = false) 196 | : pre (to_hoare doors_contract (open_door (ix := ix) d)) ω. 197 | 198 | Proof. 199 | prove impure; repeat constructor; subst. 200 | inversion o_caller0; ssubst. 201 | now rewrite safe. 202 | Qed. 203 | 204 | #[global] Hint Resolve open_door_respectful : airlock. 205 | 206 | Lemma close_door_run `{Provide ix DOORS} (ω : Ω) (d : door) (ω' : Ω) (x : unit) 207 | (run : post (to_hoare doors_contract (close_door d)) ω x ω') 208 | : sel d ω' = false. 209 | 210 | Proof. 211 | unroll_post run. 212 | + rewrite tog_equ_1. 213 | inversion H1; ssubst. 214 | now rewrite H5. 215 | + now inversion H1; ssubst. 216 | Qed. 217 | 218 | #[global] Hint Resolve close_door_run : airlock. 219 | 220 | #[local] Opaque close_door. 221 | #[local] Opaque open_door. 222 | #[local] Opaque Nat.ltb. 223 | 224 | Remark one_door_safe_all_doors_safe (ω : Ω) (d : door) 225 | (safe : sel d ω = false \/ sel (co d) ω = false) 226 | : forall (d' : door), sel d' ω = false \/ sel (co d') ω = false. 227 | 228 | Proof. 229 | intros d'. 230 | destruct d; destruct d'; auto. 231 | + cbn -[sel]. 232 | now rewrite or_comm. 233 | + cbn -[sel]. 234 | fold (co right). 235 | now rewrite or_comm. 236 | Qed. 237 | 238 | (** The objective of this lemma is to prove that, if either the right door or 239 | the left door is closed, then after any respectful run of a computation 240 | [p] that interacts with doors, this fact remains true. *) 241 | 242 | #[local] Opaque sel. 243 | 244 | Lemma respectful_run_inv `{Provide ix DOORS} {a} (p : impure ix a) 245 | (ω : Ω) (safe : sel left ω = false \/ sel right ω = false) 246 | (x : a) (ω' : Ω) (hpre : pre (to_hoare doors_contract p) ω) 247 | (hpost : post (to_hoare doors_contract p) ω x ω') 248 | : sel left ω' = false \/ sel right ω' = false. 249 | 250 | (** We reason by induction on the impure computation [p]: 251 | 252 | - Either [p] is a local, pure computation; in such a case, the doors state 253 | does not change, hence the proof is trivial. 254 | 255 | - Or [p] consists in a request to the doors interface, and a continuation 256 | whose domain satisfies the theorem, i.e. it preserves the invariant that 257 | either the left or the right door is closed. Due to this hypothesis, we 258 | only have to prove that the first request made by [p] does not break the 259 | invariant. We consider two cases. 260 | 261 | - Either the computation asks for the state of a given door ([IsOpen]), 262 | then again the doors state does not change and the proof is trivial. 263 | - Or the computation wants to toggle a door [d]. We know by hypothesis 264 | that either [d] is closed or [d] is open (thanks to the 265 | [one_door_safe_all_doors_safe] result and the [safe] hypothesis). 266 | Again, we consider both cases. 267 | 268 | - If [d] is closed —and therefore will be opened—, then because we 269 | consider a respectful run, [co d] is necessarily closed too (it is a 270 | requirements of [door_contract]). Once [d] is opened, [co d] is still 271 | closed. 272 | - Otherwise, [co d] is closed, which means once [d] is toggled (no 273 | matter its initial state), then [co d] is still closed. 274 | 275 | That is, we prove that, when [p] toggles [d], [co d] is necessarily 276 | closed after the request has been handled. Because there is at least 277 | one door closed ([co d]), we can conclude that either the right or the 278 | left door is closed thanks to [one_door_safe_all_doors_safe]. *) 279 | 280 | Proof. 281 | fold (co left) in *. 282 | revert ω hpre hpost safe. 283 | induction p; intros ω hpre run safe. 284 | + now unroll_post run. 285 | + unroll_post run. 286 | assert (hpost : post (interface_to_hoare doors_contract β e) ω x0 ω0). { 287 | split; [apply H2|now rewrite H3]. 288 | } 289 | apply H1 with (ω:=ω0) (β:=x0); auto; [now apply hpre|]. 290 | cbn in *. 291 | unfold gen_caller_obligation, gen_callee_obligation, gen_witness_update in *. 292 | destruct (proj_p e) as [e'|]. 293 | ++ destruct hpost as [o_callee equω]. 294 | destruct e' as [d|d]. 295 | +++ rewrite H3. 296 | apply safe. 297 | +++ apply one_door_safe_all_doors_safe with (d := d); 298 | apply one_door_safe_all_doors_safe with (d' := d) in safe; 299 | subst. 300 | destruct hpre as [hbefore hafter]. 301 | inversion hbefore; ssubst. 302 | cbn. 303 | destruct safe as [safe|safe]. 304 | all: right; rewrite tog_equ_2; auto. 305 | ++ destruct hpost as [_ equω]. 306 | subst. 307 | exact safe. 308 | Qed. 309 | 310 | (** ** Main Theorem *) 311 | 312 | Lemma controller_correct `{StrictProvide2 ix DOORS (STORE nat)} 313 | : correct_component controller 314 | (no_contract CONTROLLER) 315 | doors_contract 316 | (fun _ ω => sel left ω = false \/ sel right ω = false). 317 | 318 | Proof. 319 | intros ωc ωd pred a e req. 320 | assert (hpre : pre (to_hoare doors_contract (controller a e)) ωd) 321 | by (destruct e; prove impure with airlock). 322 | split; auto. 323 | intros x ωj' run. 324 | cbn. 325 | split. 326 | + auto with freespec. 327 | + apply respectful_run_inv in run; auto. 328 | Qed. 329 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name FreeSpec.Example) 3 | (theories FreeSpec.Core FreeSpec.FFI FreeSpec.Exec) 4 | (flags -init-file build.v)) -------------------------------------------------------------------------------- /examples/heap.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From FreeSpec.Core Require Import Core Extraction. 8 | From FreeSpec.FFI Require Import FFI Refs. 9 | From FreeSpec.Exec Require Import Exec. 10 | 11 | From Coq Require Import String. 12 | 13 | Open Scope nat_scope. 14 | 15 | Definition with_heap `{Monad m, MonadRefs m} : m string := 16 | let* ptr := make_ref 2 in 17 | assign ptr 3;; 18 | let* x := deref ptr in 19 | if Nat.eqb x 2 20 | then pure "yes!" 21 | else pure "no!". 22 | 23 | (* Coq projects the [with_heap] polymorphic definition directly into [impure], 24 | thanks to its typeclass inference algorithm. *) 25 | Definition with_heap_impure `{Provide ix REFS} : impure ix string := 26 | with_heap. 27 | 28 | Exec with_heap_impure. 29 | -------------------------------------------------------------------------------- /examples/smram.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From Coq Require Import ZArith. 8 | From FreeSpec Require Import Core CoreFacts. 9 | 10 | (** This library introduces the starting point of the FreeSpec framework, that 11 | is the original example that has motivated everything else. *) 12 | 13 | (** * The Verification Problem *) 14 | 15 | (** We model a small subset of a x86 architecture, where a Memory Controller 16 | (now integrated inside the CPU) received memory accesses from cores, and 17 | dispatches these accesses to different controllers. In our case, we only 18 | consider the DRAM and VGA controllers. 19 | 20 | From a FreeSpec perspective, we therefore consider three components and as 21 | many interfaces, with the memory controller exposing its own interfaces and 22 | relying on the interfaces of the two other controllers. 23 | 24 | The DRAM contains a special-purpose memory region called the SMRAM, 25 | dedicated to the x86 System Management Mode (SMM). It is expected that only 26 | a CPU in SMM can access the SMRAM. The CPU set a dedicated pin (SMIACT) when 27 | it is in SMM, for the Memory Controller to know. *) 28 | 29 | (** * Specifying the Subsystem *) 30 | 31 | (** The overview of the system we want to model is the following: 32 | 33 | << 34 | | 35 | | 36 | v 37 | ----------------- 38 | +-----------------+ 39 | |Memory Controller| 40 | +-----------------+ 41 | | | 42 | | | 43 | v v 44 | ---------- ---------- 45 | +----------+ +----------+ 46 | | DRAM | | VGA | 47 | |Controller| |Controller| 48 | +----------+ +----------+ 49 | >> 50 | We will focus on the Memory Controller, and only model the interfaces of the 51 | DRAM and VGA controllers. *) 52 | 53 | (** ** Addressing Memories *) 54 | 55 | (** We leave how the memory is actually addressed (in terms of memory cell 56 | addresses and contents) as a parameter of the model. *) 57 | 58 | Parameters (address cell : Type) 59 | (address_eq : address -> address -> Prop) 60 | (address_eq_refl : forall (addr addr' : address), 61 | address_eq addr addr' -> address_eq addr' addr) 62 | (address_eq_dec : forall (addr addr' : address), 63 | { address_eq addr addr' } + { ~ address_eq addr addr' }) 64 | (in_smram : address -> bool) 65 | (in_smram_morphism : forall (addr addr' : address), 66 | address_eq addr addr' -> in_smram addr = in_smram addr'). 67 | 68 | (** ** VGA and DRAM Controllers *) 69 | 70 | (** We consider that the DRAM and VGA controllers expose the same interface 71 | which allows for reading from and writing to memory cells. *) 72 | 73 | Inductive MEMORY : interface := 74 | | ReadFrom (addr : address) : MEMORY cell 75 | | WriteTo (addr : address) (value : cell) : MEMORY unit. 76 | 77 | Inductive DRAM : interface := 78 | | MakeDRAM {a : Type} (e : MEMORY a) : DRAM a. 79 | 80 | Definition dram_read_from `{Provide ix DRAM} (addr : address) 81 | : impure ix cell := 82 | request (MakeDRAM (ReadFrom addr)). 83 | 84 | Definition dram_write_to `{Provide ix DRAM} (addr : address) (val : cell) 85 | : impure ix unit := 86 | request (MakeDRAM (WriteTo addr val)). 87 | 88 | Inductive VGA : interface := 89 | | MakeVGA {a : Type} (e : MEMORY a) : VGA a. 90 | 91 | Definition vga_read_from `{Provide ix VGA} (addr : address) : impure ix cell := 92 | request (MakeVGA (ReadFrom addr)). 93 | 94 | Definition vga_write_to `{Provide ix VGA} (addr : address) (val : cell) 95 | : impure ix unit := 96 | request (MakeVGA (WriteTo addr val)). 97 | 98 | (** ** Memory Controller *) 99 | 100 | Inductive smiact := smiact_set | smiact_unset. 101 | 102 | Inductive MEMORY_CONTROLLER : interface := 103 | | Read (pin : smiact) (addr : address) : MEMORY_CONTROLLER cell 104 | | Write (pin : smiact) (addr : address) (value : cell) : MEMORY_CONTROLLER unit. 105 | 106 | Definition unwrap_sumbool {A B} (x : { A } + { B }) : bool := 107 | if x then true else false. 108 | 109 | Coercion unwrap_sumbool : sumbool >-> bool. 110 | 111 | Definition dispatch {a} `{Provide3 ix (STORE bool) DRAM VGA} 112 | (addr : address) (unpriv : address -> impure ix a) (priv : address -> impure ix a) 113 | : impure ix a := 114 | let* reg := get in 115 | if (andb reg (in_smram addr)) 116 | then unpriv addr 117 | else priv addr. 118 | 119 | Definition memory_controller `{Provide3 ix (STORE bool) DRAM VGA} 120 | : component MEMORY_CONTROLLER ix := 121 | fun _ op => 122 | match op with 123 | 124 | (** When SMIACT is set, the CPU is in SMM. According to its specification, the 125 | Memory Controller can simply forward the memory access to the DRAM. *) 126 | 127 | | Read smiact_set addr => dram_read_from addr 128 | | Write smiact_set addr val => dram_write_to addr val 129 | 130 | (** On the contrary, when the SMIACT is not set, the CPU is not in SMM. As a 131 | consequence, the memory controller implements a dedicated access control 132 | mechanism. If the requested address belongs to the SMRAM and if the SMRAM 133 | lock has been set, then the memory access is forwarded to the VGA. 134 | Otherwise, it is forwarded to the DRAM by default. This is specified in the 135 | [dispatch] function. *) 136 | 137 | | Read smiact_unset addr => dispatch addr vga_read_from dram_read_from 138 | | Write smiact_unset addr val => 139 | dispatch addr (fun x => vga_write_to x val) (fun x => dram_write_to x val) 140 | end. 141 | 142 | (** * Verifying our Subsystem *) 143 | 144 | (** ** Memory View *) 145 | 146 | Definition memory_view : Type := address -> cell. 147 | 148 | Definition update_memory_view_address (ω : memory_view) (addr : address) (content : cell) 149 | : memory_view := 150 | fun (addr' : address) => if address_eq_dec addr addr' then content else ω addr'. 151 | 152 | (** ** Specification *) 153 | 154 | (** *** DRAM Controller Specification *) 155 | 156 | Definition update_dram_view (ω : memory_view) (a : Type) (p : DRAM a) (_ : a) : memory_view := 157 | match p with 158 | | MakeDRAM (WriteTo a v) => update_memory_view_address ω a v 159 | | _ => ω 160 | end. 161 | 162 | Inductive dram_o_callee (ω : memory_view) : forall (a : Type), DRAM a -> a -> Prop := 163 | 164 | | read_in_smram 165 | (a : address) (v : cell) (prom : in_smram a = true -> v = ω a) 166 | : dram_o_callee ω cell (MakeDRAM (ReadFrom a)) (ω a) 167 | 168 | | write (a : address) (v : cell) (r : unit) 169 | : dram_o_callee ω unit (MakeDRAM (WriteTo a v)) r. 170 | 171 | Definition dram_specs : contract DRAM memory_view := 172 | {| witness_update := update_dram_view 173 | ; caller_obligation := no_caller_obligation 174 | ; callee_obligation := dram_o_callee 175 | |}. 176 | 177 | (** *** Memory Controller Specification *) 178 | 179 | Definition update_memory_controller_view (ω : memory_view) 180 | (a : Type) (p : MEMORY_CONTROLLER a) (_ : a) 181 | : memory_view := 182 | match p with 183 | | Write smiact_set a v => update_memory_view_address ω a v 184 | | _ => ω 185 | end. 186 | 187 | Inductive memory_controller_o_callee (ω : memory_view) 188 | : forall (a : Type) (p : MEMORY_CONTROLLER a) (x : a), Prop := 189 | 190 | | memory_controller_read_o_callee (pin : smiact) (addr : address) (content : cell) 191 | (prom : pin = smiact_set -> in_smram addr = true -> ω addr = content) 192 | : memory_controller_o_callee ω cell (Read pin addr) content 193 | 194 | | memory_controller_write_o_callee (pin : smiact) (addr : address) (content : cell) (b : unit) 195 | : memory_controller_o_callee ω unit (Write pin addr content) b. 196 | 197 | Definition mc_specs : contract MEMORY_CONTROLLER memory_view := 198 | {| witness_update := update_memory_controller_view 199 | ; caller_obligation := no_caller_obligation 200 | ; callee_obligation := memory_controller_o_callee 201 | |}. 202 | 203 | (** ** Main Theorem *) 204 | 205 | Definition smram_pred (ωmc : memory_view) (ωmem : memory_view * bool) : Prop := 206 | snd ωmem = true /\ forall (a : address), in_smram a = true -> ωmc a = (fst ωmem) a. 207 | 208 | Lemma memory_controller_respectful `{StrictProvide3 ix (STORE bool) VGA DRAM} 209 | (a : Type) (op : MEMORY_CONTROLLER a) (ω : memory_view) 210 | : pre (to_hoare (dram_specs * store_specs bool) (memory_controller a op)) (ω, true). 211 | 212 | Proof. 213 | destruct op; destruct pin; 214 | prove impure. 215 | Qed. 216 | 217 | #[local] 218 | Open Scope semantics_scope. 219 | 220 | #[local] 221 | Open Scope contract_scope. 222 | 223 | Ltac simpl_tuple := 224 | match goal with 225 | | H: (_, _) = (_, _) |- _ => inversion H; subst; clear H 226 | end. 227 | 228 | Theorem memory_controller_correct `{StrictProvide3 ix VGA (STORE bool) DRAM} 229 | (ω : memory_view) 230 | (sem : semantics ix) (comp : compliant_semantics (dram_specs * store_specs bool) (ω, true) sem) 231 | : compliant_semantics mc_specs ω (derive_semantics memory_controller sem). 232 | 233 | Proof. 234 | apply correct_component_derives_compliant_semantics with (pred := smram_pred) 235 | (cj := dram_specs * store_specs bool) 236 | (ωj := (ω, true)). 237 | + intros ωmc [ωdram b] [b_true pred] a e _. 238 | cbn in b_true. 239 | rewrite b_true in *; clear b_true. 240 | split. 241 | ++ apply memory_controller_respectful. 242 | ++ intros x [ωdram' st'] respectful. 243 | split. 244 | +++ destruct e; 245 | unroll_post respectful; 246 | repeat simpl_tuple; 247 | constructor. 248 | all: intros ?equ hin. 249 | all: lazymatch goal with 250 | | H: dram_o_callee _ _ (MakeDRAM (ReadFrom _)) _ |- _ => 251 | apply pred in hin; 252 | rewrite hin; 253 | inversion H; now ssubst 254 | | _ => 255 | discriminate 256 | end. 257 | +++ destruct e; 258 | unroll_post respectful; 259 | repeat simpl_tuple; 260 | split. 261 | all: try reflexivity. 262 | all: intros addr' hin; 263 | (now apply pred) || cbn. 264 | all: unfold update_memory_view_address; 265 | destruct address_eq_dec. 266 | all: try reflexivity. 267 | all: try now apply pred. 268 | rewrite <- (in_smram_morphism addr _ a) in hin. 269 | inversion H8; ssubst. 270 | cbn in equ. 271 | rewrite equ in hin. 272 | discriminate. 273 | + now constructor. 274 | + exact comp. 275 | Qed. 276 | -------------------------------------------------------------------------------- /patches/opam-builds.patch: -------------------------------------------------------------------------------- 1 | diff --git a/theories/Exec/dune b/theories/Exec/dune 2 | index 0cae7df..8d8c568 100644 3 | --- a/theories/Exec/dune 4 | +++ b/theories/Exec/dune 5 | @@ -1,6 +1,5 @@ 6 | (coq.theory 7 | (name FreeSpec.Exec) 8 | (package coq-freespec-exec) 9 | - (theories FreeSpec.Core FreeSpec.FFI) 10 | (libraries coq-freespec-exec.plugin) 11 | (flags -init-file ../../build.v)) 12 | \ No newline at end of file 13 | diff --git a/theories/FFI/dune b/theories/FFI/dune 14 | index 8688f86..68dfc48 100644 15 | --- a/theories/FFI/dune 16 | +++ b/theories/FFI/dune 17 | @@ -9,6 +9,5 @@ 18 | (coq.theory 19 | (name FreeSpec.FFI) 20 | (package coq-freespec-ffi) 21 | - (theories FreeSpec.Core) 22 | (libraries coq-freespec-ffi.lib) 23 | (flags -init-file ../../build.v)) 24 | \ No newline at end of file 25 | -------------------------------------------------------------------------------- /plugins/exec/coqbool.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | open Query 8 | open Utils 9 | 10 | let bool_of_coqbool cbool = 11 | match Ind.Bool.constructor_of cbool with 12 | | Some b -> b 13 | | _ -> raise (UnsupportedTerm "not a [bool] constructor") 14 | 15 | let bool_to_coqbool = function 16 | | true -> Ind.Bool.mkConstructor "true" 17 | | false -> Ind.Bool.mkConstructor "false" 18 | -------------------------------------------------------------------------------- /plugins/exec/coqbool.mli: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | val bool_of_coqbool: Constr.constr -> bool 8 | val bool_to_coqbool: bool -> Constr.constr 9 | -------------------------------------------------------------------------------- /plugins/exec/coqbyte.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | open Constr 8 | open Query 9 | open Utils 10 | 11 | let char_of_coqbyte trm = 12 | match kind trm with 13 | | Construct ((_, x), _) -> Char.chr (x - 1) (* constructor indexes start at 1 *) 14 | | _ -> raise (UnsupportedTerm "not a Byte") 15 | 16 | let char_to_coqbyte c = 17 | match kind Ind.Byte.mkInductive with 18 | | Ind (i, _) -> Constr.mkConstruct (i, 1 + Char.code c) 19 | | _ -> assert false 20 | 21 | let coqbyte_t = Ind.Byte.mkInductive 22 | -------------------------------------------------------------------------------- /plugins/exec/coqbyte.mli: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | val char_of_coqbyte : Constr.constr -> char 8 | val char_to_coqbyte : char -> Constr.constr 9 | 10 | val coqbyte_t : Constr.constr 11 | -------------------------------------------------------------------------------- /plugins/exec/coqi63.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | open Query 8 | open Utils 9 | 10 | let int_of_coqint coqint = 11 | match Constr.kind coqint with 12 | | Constr.Int i -> snd (Uint63.to_int2 i) 13 | | _ -> raise (UnsupportedTerm "Not a native integer") 14 | 15 | let int_to_coqint v = Constr.(of_kind (Int (Uint63.of_int v))) 16 | 17 | let int_of_coqi63 trm = 18 | let (c, args) = app_full trm in 19 | match (Ind.I63.constructor_of c, args) with 20 | | (Some Mk_i63, [trm]) -> int_of_coqint trm 21 | | _ -> raise (UnsupportedTerm "int_of_coqi63") 22 | 23 | let int_to_coqi63 n = 24 | let trm = int_to_coqint n in 25 | Constr.mkApp (Ind.I63.mkConstructor "mk_i63", Array.of_list [trm]) 26 | 27 | let coqi63_t = Ind.I63.mkInductive 28 | -------------------------------------------------------------------------------- /plugins/exec/coqi63.mli: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | val int_of_coqint : Constr.constr -> int 8 | val int_to_coqint : int -> Constr.constr 9 | 10 | val int_of_coqi63 : Constr.constr -> int 11 | val int_to_coqi63 : int -> Constr.constr 12 | 13 | val coqi63_t : Constr.constr 14 | -------------------------------------------------------------------------------- /plugins/exec/coqlist.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | open Array 8 | open Constr 9 | open Query 10 | open Utils 11 | 12 | let coqlist_nil typ = mkApp (Ind.List.mkConstructor "nil", of_list [typ]) 13 | 14 | let coqlist_cons typ trm rstrm = mkApp (Ind.List.mkConstructor "cons", of_list [typ; trm; rstrm]) 15 | 16 | let list_of_coqlist of_coq = 17 | let rec aux cont trm = 18 | let (c, args) = app_full trm in 19 | match (Ind.List.constructor_of c, args) with 20 | | (Some Nil_list, [_t]) -> cont [] 21 | | (Some Cons_list, [_t; coqx; coqrst]) -> 22 | let x = of_coq coqx in 23 | aux (fun next -> cont (x :: next)) coqrst 24 | | _ -> raise (UnsupportedTerm "of_coqlist: not a Coq list") 25 | in aux (fun x -> x) 26 | 27 | (* TODO: tailrec version *) 28 | let list_to_coqlist typ to_coq = 29 | let rec aux cont = function 30 | | [] -> cont (coqlist_nil typ) 31 | | x :: rst -> 32 | aux (fun next -> cont (coqlist_cons typ (to_coq x) next)) rst 33 | in aux (fun x -> x) 34 | 35 | let coqlist_t typ = 36 | mkApp (Ind.List.mkInductive, of_list [typ]) 37 | 38 | let rec coqlist_fold_left f trm acc = 39 | let (c, args) = app_full trm in 40 | match (Ind.List.constructor_of c, args) with 41 | | (Some Nil_list, [_t]) -> acc 42 | | (Some Cons_list, [_t; coqx; coqrst]) -> 43 | coqlist_fold_left f coqrst (f acc coqx) 44 | | _ -> raise (UnsupportedTerm "coqlist_fold_left: not a Coq list") 45 | 46 | let coqlist_iteri f = 47 | let rec aux idx trm = 48 | let (c, args) = app_full trm in 49 | match (Ind.List.constructor_of c, args) with 50 | | (Some Nil_list, [_t]) -> () 51 | | (Some Cons_list, [_t; coqx; coqrst]) -> 52 | f idx coqx; 53 | aux (idx + 1) coqrst 54 | | _ -> raise (UnsupportedTerm "coqlist_iteri: not a Coq list") 55 | in aux 0 56 | -------------------------------------------------------------------------------- /plugins/exec/coqlist.mli: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | val list_of_coqlist : (Constr.constr -> 'a) -> Constr.constr -> 'a list 8 | val list_to_coqlist : 9 | Constr.constr -> ('a -> Constr.constr) -> 'a list -> Constr.constr 10 | 11 | val coqlist_iteri : (int -> Constr.constr -> unit) -> Constr.constr -> unit 12 | val coqlist_fold_left : ('a -> Constr.constr -> 'a) -> Constr.constr -> 'a -> 'a 13 | 14 | val coqlist_nil : Constr.constr -> Constr.constr 15 | val coqlist_cons : Constr.constr -> Constr.constr -> Constr.constr -> Constr.constr 16 | 17 | val coqlist_t : Constr.constr -> Constr.constr 18 | -------------------------------------------------------------------------------- /plugins/exec/coqprod.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | open Array 8 | open Constr 9 | open Query 10 | open Utils 11 | 12 | let prod_of_coqprod of_coq1 of_coq2 prod = 13 | let (c, args) = app_full prod in 14 | match (Ind.Prod.constructor_of c, args) with 15 | | (Some Pair_prod, [_t1; _t2; trm1; trm2]) 16 | -> (of_coq1 trm1, of_coq2 trm2) 17 | | _ 18 | -> raise (UnsupportedTerm "not a Coq product") 19 | 20 | let prod_to_coqprod t1 to_coq1 t2 to_coq2 prod = 21 | let cPair = Ind.Prod.mkConstructor "pair" in 22 | match prod with 23 | | (x, y) -> 24 | mkApp (cPair, of_list [t1; t2; to_coq1 x; to_coq2 y]) 25 | 26 | let coqprod_t typ1 typ2 = 27 | mkApp (Ind.Prod.mkInductive, (of_list [typ1; typ2])) 28 | -------------------------------------------------------------------------------- /plugins/exec/coqprod.mli: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | val prod_of_coqprod : (Constr.constr -> 'a) -> (Constr.constr -> 'b) -> Constr.constr -> ('a * 'b) 8 | val prod_to_coqprod : 9 | Constr.constr -> ('a -> Constr.constr) -> Constr.constr -> ('b -> Constr.constr) -> ('a * 'b) -> Constr.constr 10 | 11 | val coqprod_t : Constr.constr -> Constr.constr -> Constr.constr 12 | -------------------------------------------------------------------------------- /plugins/exec/coqsum.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | open Array 8 | open Constr 9 | open Query 10 | open Utils 11 | 12 | type ('a, 'b) sum = Left of 'a | Right of 'b 13 | 14 | let sum_of_coqsum of_coq1 of_coq2 sum = 15 | let (c, args) = app_full sum in 16 | match (Ind.Sum.constructor_of c, args) with 17 | | (Some InL_sum, [_t1; _t2; trm]) 18 | -> Left (of_coq1 trm) 19 | | (Some InR_sum, [_t1; _t2; trm]) 20 | -> Right (of_coq2 trm) 21 | | _ 22 | -> raise (UnsupportedTerm "not a Coq sumuct") 23 | 24 | let sum_to_coqsum t1 to_coq1 t2 to_coq2 sum = 25 | let cInR = Ind.Sum.mkConstructor "inr" in 26 | let cInL = Ind.Sum.mkConstructor "inl" in 27 | match sum with 28 | | Left x -> 29 | mkApp (cInL, of_list [t1; t2; to_coq1 x]) 30 | | Right x -> 31 | mkApp (cInR, of_list [t1; t2; to_coq2 x]) 32 | -------------------------------------------------------------------------------- /plugins/exec/coqsum.mli: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | type ('a, 'b) sum = Left of 'a | Right of 'b 8 | 9 | val sum_of_coqsum : (Constr.constr -> 'a) -> (Constr.constr -> 'b) -> Constr.constr -> ('a, 'b) sum 10 | val sum_to_coqsum : Constr.constr -> ('a -> Constr.constr) -> Constr.constr -> ('b -> Constr.constr) -> ('a, 'b) sum -> Constr.constr 11 | -------------------------------------------------------------------------------- /plugins/exec/coqunit.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | open Query 8 | 9 | let coqtt = Ind.Unit.mkConstructor "tt" 10 | -------------------------------------------------------------------------------- /plugins/exec/coqunit.mli: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | val coqtt: Constr.constr 8 | -------------------------------------------------------------------------------- /plugins/exec/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name freespec_exec) 3 | (public_name coq-freespec-exec.plugin) 4 | (synopsis "Turn coqc into an interpreter for impure computations") 5 | (flags :standard -rectypes) 6 | (libraries coq.stm)) 7 | 8 | (coq.pp (modules g_freespec_exec)) -------------------------------------------------------------------------------- /plugins/exec/eval.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | open Extends 8 | 9 | let path = "freespec.exec.eval" 10 | 11 | let install_interface = 12 | register_interface path [ 13 | ("Eval", function | [_typ; trm] -> trm 14 | | _ -> assert false) 15 | ] 16 | -------------------------------------------------------------------------------- /plugins/exec/exec.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | open Constr 8 | open Query 9 | open Utils 10 | open Interfaces 11 | open Attributes 12 | open Attributes.Notations 13 | 14 | let reduce_head env evm trm = 15 | EConstr.to_constr evm (Reductionops.whd_all env evm (EConstr.of_constr trm)) 16 | 17 | let reduce_all env evm trm = 18 | EConstr.to_constr evm (Reductionops.nf_all env evm (EConstr.of_constr trm)) 19 | 20 | let reduce_strategy = 21 | let name = "Reduce Strategy" in 22 | qualify_attribute "reduce" @@ 23 | attribute_of_list [ 24 | "nf", single_key_parser ~name ~key:"nf" reduce_all 25 | ; "whd", single_key_parser ~name ~key:"nf" reduce_head 26 | ] >>= function 27 | | None -> return reduce_head 28 | | Some x -> return x 29 | 30 | let exec_request env evm instr_trm func_trm = 31 | let rec find_primitive instr_trm = 32 | let (instr_trm, args) = app_full instr_trm in 33 | match (kind instr_trm, args) with 34 | | (Construct (c, _), args) 35 | -> (match (Ind.IPlus.constructor_of instr_trm, args) with 36 | | (Some _, [_; _; _; trm]) 37 | -> find_primitive trm 38 | | _ 39 | -> (c, args)) 40 | | (Case _, [_; trm]) | (LetIn _, [_; trm]) 41 | -> find_primitive trm 42 | | _ 43 | -> raise (UnsupportedTerm 44 | ("Unsupported primitive shape `" 45 | ^ (Pp.string_of_ppcmds @@ Printer.pr_lconstr_env env evm instr_trm) 46 | ^ "'")) 47 | in 48 | let (c, args) = find_primitive instr_trm in 49 | (* [primitive_semantic] may raise [UnsupportedInterface] if [c] is not a 50 | registered request constructors. *) 51 | try 52 | let res = primitive_semantic c args in 53 | mkApp (func_trm, Array.of_list [res]) 54 | with UnsupportedInterface -> 55 | raise (UnsupportedTerm 56 | ("No semantics has been installed for primitive `" 57 | ^ (Pp.string_of_ppcmds @@ Printer.pr_lconstr_env env evm instr_trm) 58 | ^ "'")) 59 | 60 | let rec exec head_red env evm def = 61 | let def = head_red env evm def in 62 | let (def, args) = app_full def in 63 | match Ind.Program.constructor_of def with 64 | | Some RequestThen_impure -> 65 | begin match args with 66 | | [_instr_t; _ret_t; _instr_ret_t; instr_trm; func_trm] -> 67 | let instr_trm = reduce_all env evm instr_trm in 68 | exec head_red env evm (exec_request env evm instr_trm func_trm) 69 | | _ -> assert false 70 | end 71 | | Some Local_impure 72 | -> None 73 | | _ 74 | -> raise (UnsupportedTerm 75 | ("FreeSpec.Exec cannot handle the term `" 76 | ^ (Pp.string_of_ppcmds @@ Printer.pr_lconstr_env env evm def) 77 | ^ "'")) 78 | -------------------------------------------------------------------------------- /plugins/exec/extends.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | open Interfaces 8 | 9 | let register_interface path semantics = 10 | let reg _ = function 11 | | (name, sem) -> new_primitive path name sem 12 | in 13 | add_register_handler @@ fun _ -> List.fold_left reg () semantics 14 | -------------------------------------------------------------------------------- /plugins/exec/extends.mli: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | (** Extend FreeSpec.Exec by associating primitives constructor names to 8 | effectful semantics. *) 9 | 10 | val register_interface: string -> (string * Interfaces.effectful_semantic) list -> unit 11 | (** After [register_interface modpath [(cname1, sem1); ...; (cnamen, semn)]] has 12 | been executed, primitives constructed with constructors [cname1] to [cnamen] 13 | (which lives in the module defined by [modpath]) will be supported by the 14 | [Exec] command, which will use [sem1] to [semn] to realize them. 15 | 16 | To illustrate how [register_interface] is used, we can take the example of 17 | the [Console.i] interface. [Console.i] constructor live in the 18 | [FreeSpec.Stdlib.Console.Console] module, which translate in OCaml into 19 | [["FreeSpec"; "Stdlib"; "Console"; "Console"]]. 20 | 21 | Therefore, extending FreeSpec.Exec to support [Console.i] primitives becomes 22 | as simple as: 23 | 24 | {[ 25 | let _ = 26 | register_interface 27 | ["FreeSpec"; "Stdlib"; "Console"; "Console"] 28 | [("Scan", scan); ("Echo", echo)] 29 | ]} *) 30 | -------------------------------------------------------------------------------- /plugins/exec/freespec_exec.mlpack: -------------------------------------------------------------------------------- 1 | Utils 2 | Query 3 | Coqbool 4 | Coqbyte 5 | Coqlist 6 | Coqi63 7 | Coqprod 8 | Coqsum 9 | Coqunit 10 | Interfaces 11 | Extends 12 | Exec 13 | Eval 14 | Store 15 | Heap 16 | Resources 17 | G_freespec_exec -------------------------------------------------------------------------------- /plugins/exec/g_freespec_exec.mlg: -------------------------------------------------------------------------------- 1 | (* FreeSpec 2 | * Copyright (C) 2018–2019 ANSSI 3 | * 4 | * Contributors: 5 | * 2019 Thomas Letan 6 | * 7 | * This program is free software: you can redistribute it and/or modify 8 | * it under the terms of the GNU General Public License as published by 9 | * the Free Software Foundation, either version 3 of the License, or 10 | * (at your option) any later version. 11 | * 12 | * This program is distributed in the hope that it will be useful, 13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | * GNU General Public License for more details. 16 | * 17 | * You should have received a copy of the GNU General Public License 18 | * along with this program. If not, see . 19 | *) 20 | 21 | DECLARE PLUGIN "freespec_exec" 22 | 23 | { open Stdarg } 24 | 25 | VERNAC COMMAND EXTEND Exec CLASSIFIED AS SIDEFF 26 | | #[ strat = Exec.reduce_strategy ] [ "Exec" constr(def) ] -> 27 | { let _ = Interfaces.force_interface_initializers () in 28 | let (evm, env) = let env = Global.env () in Evd.(from_env env, env) in 29 | let (def, _) = Constrintern.interp_constr env evm def in 30 | let def = EConstr.to_constr evm def in 31 | let _ = Exec.exec strat env evm def in 32 | () 33 | } 34 | END 35 | -------------------------------------------------------------------------------- /plugins/exec/heap.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | open Extends 8 | open Coqunit 9 | open Coqi63 10 | 11 | let count = ref 0 12 | 13 | let heap : (int, Constr.t) Hashtbl.t = 14 | Hashtbl.create ~random:false 100 15 | 16 | let make_ref trm = begin 17 | let k = !count in 18 | count := !count + 1; 19 | Hashtbl.add heap k trm; 20 | int_to_coqint k 21 | end 22 | 23 | let destruct k = begin 24 | Hashtbl.remove heap (int_of_coqint k); 25 | end 26 | 27 | let assign k = Hashtbl.replace heap (int_of_coqint k) 28 | 29 | let deref k = Hashtbl.find heap (int_of_coqint k) 30 | 31 | (* private *) 32 | 33 | let path = "freespec.ffi.REFS" 34 | 35 | let _ = 36 | let new_ref_primitive = function 37 | | [_term_type; trm] 38 | -> make_ref trm 39 | | _ -> assert false in 40 | let assign_primitive = function 41 | | [_term_type; ptr; trm] 42 | -> begin 43 | assign ptr trm; 44 | coqtt 45 | end 46 | | _ -> assert false in 47 | let deref_primitive = function 48 | | [_term_type; ptr] 49 | -> deref ptr 50 | | _ -> assert false in 51 | register_interface path [ 52 | ("Make_ref", new_ref_primitive); 53 | ("Assign", assign_primitive); 54 | ("Deref", deref_primitive); 55 | ] 56 | -------------------------------------------------------------------------------- /plugins/exec/heap.mli: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | (** This module provides the means to encode a form of “pointers” in Coq. See 8 | the [HEAP] interface for more information about how to use it in a Coq 9 | program. *) 10 | 11 | val make_ref : Constr.t -> Constr.t 12 | (** Store a Coq term inside the so-called heap, and return a reference to 13 | manipulate it. *) 14 | 15 | val destruct : Constr.t -> unit 16 | (** Remove the Coq term identified by the reference passed as an argument from 17 | the so-called heap. This means [deref] and [assign] will not work with this 18 | reference afterards. *) 19 | 20 | val deref : Constr.t -> Constr.t 21 | (** Return the Coq term identified by the reference passed as an argument. *) 22 | 23 | val assign : Constr.t -> Constr.t -> unit 24 | (** Change the Coq term identified by the reference passed as an argument. This 25 | means that after the evaluation of [assign r v], [deref r] returns [v]. *) 26 | -------------------------------------------------------------------------------- /plugins/exec/interfaces.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | open Utils 8 | 9 | (** 10 | 11 | The OCaml interpretation of an effectful primitive is an 12 | effectful OCaml function from Coq terms to Coq term. 13 | 14 | *) 15 | type effectful_semantic = Constr.constr list -> Constr.constr 16 | 17 | let primitive_semantics : effectful_semantic Names.Constrmap.t ref = 18 | ref Names.Constrmap.empty 19 | 20 | let new_primitive m c p = 21 | match Coqlib.lib_ref (m ^ "." ^ c) with 22 | | Names.GlobRef.ConstructRef c -> 23 | primitive_semantics := Names.Constrmap.add c p !primitive_semantics 24 | | _ -> 25 | invalid_arg "Only constructor can identify primitives." 26 | 27 | let primitive_semantic : Names.constructor -> effectful_semantic = 28 | fun c -> try 29 | Names.Constrmap.find c !primitive_semantics 30 | with Not_found -> raise UnsupportedInterface 31 | 32 | (** 33 | 34 | An initializer binds the constructor identifier of the interface 35 | request to an OCaml function that implements its semantics. 36 | 37 | To register a new interface, a plugin must install an initializer 38 | that will be triggered at [Exec] time. The initializer cannot be 39 | run at [Declare Module] time because the identifiers of the 40 | constructors might not be properly bound in Coq environment at this 41 | moment. 42 | 43 | *) 44 | 45 | (** A queue for initializers to be triggered at [Exec] time. *) 46 | let initializers = Queue.create () 47 | 48 | (** [add_register_handler i]. *) 49 | let add_register_handler interface_initializer = 50 | Queue.add interface_initializer initializers 51 | 52 | (** [force_interface_initializers ()] initialize the interfaces that 53 | have been registered by [register_interfaces]. *) 54 | let force_interface_initializers () = 55 | Queue.( 56 | while not (is_empty initializers) do 57 | pop initializers () 58 | done 59 | ) 60 | -------------------------------------------------------------------------------- /plugins/exec/interfaces.mli: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | type effectful_semantic = Constr.constr list -> Constr.constr 8 | 9 | val new_primitive: string -> string -> effectful_semantic -> unit 10 | val primitive_semantic : Names.constructor -> effectful_semantic 11 | 12 | val force_interface_initializers: unit -> unit 13 | val add_register_handler: (unit -> unit) -> unit 14 | -------------------------------------------------------------------------------- /plugins/exec/query.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | let contrib = "exec" 8 | 9 | module type InductiveSpec = sig 10 | type constructor 11 | val type_name : string 12 | val names : (string * constructor) list 13 | val namespace : string 14 | end 15 | 16 | module Inductive = struct 17 | module Make (I: InductiveSpec) = struct 18 | let constructor_of c = 19 | let constructor_is = fun cstr -> 20 | match Constr.kind c with 21 | | Constr.Construct (c, _) 22 | -> Names.GlobRef.equal 23 | (Names.GlobRef.ConstructRef c) 24 | (Coqlib.lib_ref (I.namespace ^ "." ^ cstr)) 25 | | _ -> false 26 | in 27 | let rec aux = function 28 | | (str, descr) :: rst 29 | -> if constructor_is str 30 | then Some descr 31 | else aux rst 32 | | _ -> None 33 | in aux I.names 34 | 35 | let mkInductive = 36 | let ref = Coqlib.lib_ref (I.namespace ^ ".type") in 37 | match ref with 38 | | Names.GlobRef.IndRef i -> Constr.mkInd i 39 | | _ -> raise (Utils.Anomaly "Could not construct inductive type") 40 | 41 | let mkConstructor cstr = 42 | let ref = Coqlib.lib_ref (I.namespace ^ "." ^ cstr) in 43 | match ref with 44 | | Names.GlobRef.ConstructRef c -> Constr.mkConstruct c 45 | | _ -> raise (Utils.Anomaly "Could not construct the term") 46 | 47 | let ref_is i = 48 | match Constr.kind i with 49 | | Constr.Ind (i, _) 50 | -> Names.GlobRef.equal 51 | (Names.GlobRef.IndRef i) 52 | (Coqlib.lib_ref (I.namespace ^ ".type")) 53 | | _ -> false 54 | 55 | end 56 | end 57 | 58 | type impure_constructor = Local_impure | RequestThen_impure 59 | type iplus_constructor = InL_intcompose | InR_intcompose 60 | type prod_constructor = Pair_prod 61 | type sum_constructor = InL_sum | InR_sum 62 | type list_constructor = Cons_list | Nil_list 63 | type i63_constructor = Mk_i63 | Nil_list 64 | 65 | module Ind = struct 66 | module Program = 67 | Inductive.Make(struct 68 | type constructor = impure_constructor 69 | let type_name = "impure" 70 | let namespace = "freespec.core.impure" 71 | let names = [("local", Local_impure); ("request_then", RequestThen_impure)] 72 | end) 73 | 74 | module IPlus = 75 | Inductive.Make(struct 76 | type constructor = iplus_constructor 77 | let type_name = "iplus" 78 | let namespace = "freespec.core.iplus" 79 | let names = [("in_left", InL_intcompose); ("in_right", InR_intcompose)] 80 | end) 81 | 82 | module Bool = 83 | Inductive.Make(struct 84 | type constructor = bool 85 | let type_name = "bool" 86 | let namespace = "core.bool" 87 | let names = [("true", true); ("false", false)] 88 | end) 89 | 90 | module Unit = 91 | Inductive.Make(struct 92 | type constructor = unit 93 | let type_name = "unit" 94 | let namespace = "core.unit" 95 | let names = [("tt", ())] 96 | end) 97 | 98 | module Prod = 99 | Inductive.Make(struct 100 | type constructor = prod_constructor 101 | let type_name = "prod" 102 | let namespace = "core.prod" 103 | let names = [("pair", Pair_prod)] 104 | end) 105 | 106 | module Sum = 107 | Inductive.Make(struct 108 | type constructor = sum_constructor 109 | let type_name = "sum" 110 | let namespace = "core.sum" 111 | let names = [("inl", InL_sum); ("inr", InR_sum)] 112 | end) 113 | 114 | module List = 115 | Inductive.Make(struct 116 | type constructor = list_constructor 117 | let type_name = "list" 118 | let namespace = "core.list" 119 | let names = [("cons", Cons_list); ("nil", Nil_list)] 120 | end) 121 | 122 | module Byte = 123 | Inductive.Make(struct 124 | type constructor = unit 125 | let type_name = "byte" 126 | let namespace = "coq.byte" 127 | let names = [] 128 | end) 129 | 130 | module I63 = 131 | Inductive.Make(struct 132 | type constructor = i63_constructor 133 | let type_name = "i63" 134 | let namespace = "coqffi.data.i63" 135 | let names = [("mk_i63", Mk_i63)] 136 | end) 137 | end 138 | -------------------------------------------------------------------------------- /plugins/exec/resources.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | let vault : Obj.t Store.t = Store.create () 8 | 9 | let insert v = Store.add vault (Obj.repr v) 10 | let remove = Store.remove vault 11 | let replace k v = Store.replace vault k (Obj.repr v) 12 | let find k = Obj.obj (Store.find vault k) 13 | -------------------------------------------------------------------------------- /plugins/exec/resources.mli: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | val insert : 'a -> Constr.t 8 | val replace : Constr.t -> 'a -> unit 9 | val find : Constr.t -> 'a 10 | val remove : Constr.t -> unit 11 | -------------------------------------------------------------------------------- /plugins/exec/store.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | type 'a t = { next_key : Uint63.t ref; table : (Uint63.t, 'a) Hashtbl.t } 8 | 9 | let unwrap : Constr.t -> Uint63.t = fun x -> 10 | match Constr.kind x with 11 | | Constr.Int x -> x 12 | | _ -> assert false 13 | 14 | let create _ = 15 | { next_key = ref Uint63.zero; table = Hashtbl.create ~random:false 100 } 16 | 17 | let add t trm = begin 18 | let r = t.next_key in 19 | let k = !r in 20 | r := Uint63.add k Uint63.one; 21 | Hashtbl.add t.table k trm; 22 | Constr.of_kind(Int k) 23 | end 24 | 25 | let remove t k = Hashtbl.remove t.table (unwrap k) 26 | let find t k = Hashtbl.find t.table (unwrap k) 27 | let replace t k = Hashtbl.replace t.table (unwrap k) 28 | -------------------------------------------------------------------------------- /plugins/exec/store.mli: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | type 'a t 8 | 9 | val create : unit -> 'a t 10 | val add : 'a t -> 'a -> Constr.t 11 | val remove : 'a t -> Constr.t -> unit 12 | val find : 'a t -> Constr.t -> 'a 13 | val replace : 'a t -> Constr.t -> 'a -> unit 14 | -------------------------------------------------------------------------------- /plugins/exec/utils.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | exception Anomaly of string 8 | exception UnsupportedTerm of string 9 | exception UnsupportedInterface 10 | exception NotImplementedYet 11 | 12 | let notice str = 13 | Feedback.msg_notice (Pp.strbrk str) 14 | 15 | let app_full trm = 16 | let rec aux trm acc = 17 | match Constr.kind trm with 18 | | Constr.App (f, xs) 19 | -> aux f (Array.to_list xs @ acc) 20 | | _ 21 | -> (trm, acc) 22 | in aux trm [] 23 | -------------------------------------------------------------------------------- /run-tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # This Source Code Form is subject to the terms of the Mozilla Public 4 | # License, v. 2.0. If a copy of the MPL was not distributed with this 5 | # file, You can obtain one at https://mozilla.org/MPL/2.0/. 6 | 7 | bold=$(tput bold) 8 | normal=$(tput sgr0) 9 | 10 | exit_code=0 11 | 12 | function fancy_diff () { 13 | local f1="${1}" 14 | local f2="${2}" 15 | 16 | diff --color=always -u "${f1}" "${f2}" 17 | } 18 | 19 | function run_test () { 20 | local has_failed=0 21 | local test="$1" 22 | local input="${test%.v}.input" 23 | local golden_output="${test%.v}.output" 24 | 25 | local output="$(mktemp)" 26 | 27 | echo -ne " ${test}..." 28 | 29 | if [ -f "${input}" ]; then 30 | cat ${input} | coqc -init-file build.v ${test} 2>&1 > ${output} 31 | else 32 | coqc -init-file build.v ${test} 2>&1 > ${output} 33 | fi 34 | 35 | # we first check whether or not `coqc' was happy with our test 36 | if [ $? -ne 0 ]; then 37 | has_failed=1 38 | exit_code=1 39 | fi 40 | 41 | # then, we check the output produced by the command if necessary 42 | if [ -f "${golden_output}" ]; then 43 | local diff=$(fancy_diff "${golden_output}" "${output}") 44 | 45 | if [[ ! -z ${diff} ]]; then 46 | echo -e "\r " 47 | echo "${bold}Output differed from expected:${normal}" 48 | echo "${diff}" 49 | echo "" 50 | 51 | has_failed=1 52 | exit_code=1 53 | fi 54 | 55 | fi 56 | 57 | # turns out everything went fine 58 | if [[ ${has_failed} -eq 0 ]]; then 59 | echo -e "\r ${test}... \e[32mpass\e[39m" 60 | else 61 | echo -e "\r ${test}... \e[31mfail\e[39m" 62 | echo "" 63 | echo "${bold}Output was:${normal}" 64 | cat "${output}" 65 | echo "" 66 | 67 | fi 68 | 69 | rm ${output} 70 | } 71 | 72 | for test in tests/*.v; do 73 | run_test ${test} 74 | done 75 | 76 | exit ${exit_code=} 77 | -------------------------------------------------------------------------------- /tests/core_tactics.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From FreeSpec.Core Require Import CoreFacts. 8 | From Coq Require Import Lia. 9 | 10 | #[local] Open Scope nat_scope. 11 | 12 | Create HintDb counter. 13 | 14 | Generalizable All Variables. 15 | 16 | (** The goal of this file is to provide a simple test case for [prove_impure] 17 | and [unroll_respectful_run]. *) 18 | 19 | Inductive COUNTER : interface := 20 | | Get : COUNTER nat 21 | | Inc : COUNTER unit 22 | | Dec : COUNTER unit. 23 | 24 | Definition counter_get `{Provide ix COUNTER} : impure ix nat := 25 | request Get. 26 | 27 | Definition counter_inc `{Provide ix COUNTER} : impure ix unit := 28 | request Inc. 29 | 30 | Definition counter_dec `{Provide ix COUNTER} : impure ix unit := 31 | request Dec. 32 | 33 | Fixpoint repeat {m : Type -> Type} `{Monad m} {a} (n : nat) (c : m a) : m unit := 34 | match n with 35 | | O => pure tt 36 | | S n => (c >>= fun _ => repeat n c) 37 | end. 38 | 39 | Definition update_counter (x : nat) : forall (a : Type), COUNTER a -> a -> nat := 40 | fun (a : Type) (p : COUNTER a) (_ : a) => 41 | match p with 42 | | Inc => S x 43 | | Dec => Nat.pred x 44 | | _ => x 45 | end. 46 | 47 | Definition counter_o_caller (x : nat) : forall (a : Type), COUNTER a -> Prop := 48 | fun (a : Type) (p : COUNTER a) => 49 | match p with 50 | | Dec => 0 < x 51 | | _ => True 52 | end. 53 | 54 | Definition counter_o_callee (x : nat) : forall (a : Type), COUNTER a -> a -> Prop := 55 | fun (a : Type) (p : COUNTER a) (r : a) => 56 | match p, r with 57 | | Get, r => r = x 58 | | _, _ => True 59 | end. 60 | 61 | Definition counter_specs : contract COUNTER nat := 62 | {| witness_update := update_counter 63 | ; caller_obligation := counter_o_caller 64 | ; callee_obligation := counter_o_callee 65 | |}. 66 | 67 | Definition dec_then_inc `{Provide ix COUNTER} (x y : nat) : impure ix nat := 68 | repeat x counter_dec;; 69 | repeat y counter_inc;; 70 | counter_get. 71 | 72 | Theorem dec_then_inc_respectful `{Provide ix COUNTER} (cpt x y : nat) 73 | (init_cpt : x < cpt) 74 | : pre (to_hoare counter_specs $ dec_then_inc x y) cpt. 75 | 76 | Proof. 77 | prove impure. 78 | + revert x cpt init_cpt. 79 | induction x; intros cpt init_cpt; prove impure. 80 | ++ cbn. 81 | transitivity (S x); auto. 82 | apply PeanoNat.Nat.lt_0_succ. 83 | ++ apply IHx. 84 | now apply Lt.lt_pred. 85 | + clear init_cpt hpost cpt. 86 | revert ω; induction y; intros cpt; prove impure. 87 | Qed. 88 | 89 | Lemma repeat_dec_cpt_output 90 | `(run : post (to_hoare counter_specs $ repeat x counter_dec) cpt r cpt') 91 | (init_cpt : x < cpt) 92 | : cpt' = cpt - x. 93 | 94 | Proof. 95 | revert init_cpt run; revert cpt; induction x; intros cpt init_cpt run. 96 | + unroll_post run. 97 | now rewrite PeanoNat.Nat.sub_0_r. 98 | + unroll_post run. 99 | apply IHx in run; [| lia]. 100 | subst. 101 | lia. 102 | Qed. 103 | 104 | #[local] Hint Resolve repeat_dec_cpt_output : counter. 105 | 106 | Lemma repeat_inc_cpt_output 107 | `(run : post (to_hoare counter_specs $ repeat x counter_inc) cpt r cpt') 108 | : cpt' = cpt + x. 109 | 110 | Proof. 111 | revert run; revert cpt; induction x; intros cpt run. 112 | + unroll_post run. 113 | now rewrite PeanoNat.Nat.add_0_r. 114 | + unroll_post run. 115 | apply IHx in run. 116 | lia. 117 | Qed. 118 | 119 | #[local] Hint Resolve repeat_inc_cpt_output : counter. 120 | 121 | Lemma get_cpt_output (cpt x cpt' : nat) 122 | (run : post (to_hoare counter_specs $ counter_get) cpt x cpt') 123 | : cpt' = cpt. 124 | 125 | Proof. 126 | now unroll_post run. 127 | Qed. 128 | 129 | #[local] Hint Resolve get_cpt_output : counter. 130 | 131 | #[local] 132 | Opaque counter_get. 133 | 134 | Theorem dec_then_inc_cpt_output (cpt x y cpt' r : nat) 135 | (init_cpt : x < cpt) 136 | (run : post (to_hoare counter_specs $ dec_then_inc x y) cpt r cpt') 137 | : cpt' = cpt - x + y. 138 | 139 | Proof. 140 | unroll_post run. 141 | apply repeat_dec_cpt_output in run0; [| exact init_cpt ]. 142 | apply repeat_inc_cpt_output in run. 143 | apply get_cpt_output in run2. 144 | lia. 145 | Qed. 146 | 147 | #[local] 148 | Transparent counter_get. 149 | 150 | Theorem dec_then_inc_output (cpt x y cpt' r : nat) 151 | (init_cpt : x < cpt) 152 | (run : post (to_hoare counter_specs $ dec_then_inc x y) cpt r cpt') 153 | : cpt' = r. 154 | 155 | Proof. 156 | now unroll_post run. 157 | Qed. 158 | -------------------------------------------------------------------------------- /tests/program_fixpoint.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From FreeSpec.Exec Require Import Exec Eval. 8 | 9 | From Coq.Program Require Import Wf. 10 | From Coq Require Import List. 11 | Import ListNotations. 12 | 13 | (** [Exec] and the Coq’s Program framework do not always play nicely 14 | together. The computation of proofs induced by the framework, for instance 15 | to assert well-founded recursion, can make [Exec] very slow by default. *) 16 | 17 | #[program] 18 | Fixpoint enum {a b ix} (p : a -> impure ix b) (l : list a) {measure (length l)} : impure ix unit := 19 | match l with 20 | | nil => pure tt 21 | | cons x rst => p x;; 22 | enum p rst 23 | end. 24 | 25 | Fail Timeout 1 Exec (enum eval [true; true; false]). 26 | 27 | (** We have provided an attribute for [Exec] which slightly changes the behavior 28 | of the command (see the documentation of [FreeSpec.Exec.Exec]). Note that 29 | this is not a silver bullet, as some computations may behave just fine with 30 | the default behavior, but on the contrary take forever to compute with this 31 | option enabled. *) 32 | 33 | #[reduce(nf)] 34 | Exec (enum eval [true; true; false]). 35 | -------------------------------------------------------------------------------- /tests/provide_notation.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From FreeSpec.Core Require Import Core. 8 | 9 | Axioms (i1 i2 i3 i4 : interface). 10 | 11 | Axiom p1 : forall `{Provide ix}, impure ix nat. 12 | Axiom p2 : forall `{Provide2 ix i3 i1}, impure ix nat. 13 | 14 | Definition p `{Provide4 ix i1 i4 i3 i2} : impure ix nat := 15 | p1;; 16 | p2. 17 | 18 | Definition provide_notation_test_1 {a} `{StrictProvide3 ix i1 i2 i3} (p : i2 a) : ix a := 19 | inj_p p. 20 | 21 | Lemma provide_notation_test_2 `{StrictProvide3 ix i1 i2 i3} : StrictProvide2 ix i2 i3. 22 | 23 | Proof. 24 | typeclasses eauto. 25 | Qed. 26 | 27 | Definition provide_notation_test_3 {a} (i1 i2 i3 : interface) (p : i2 a) : (iplus (iplus i1 i2) i3) a := 28 | inj_p p. 29 | 30 | Lemma provide_notation_test_4 (i1 i2 i3 : interface) : Provide (i1 + (i2 + i3)) i2. 31 | 32 | Proof. 33 | typeclasses eauto. 34 | Qed. 35 | 36 | Lemma provide_notation_test_5 (i1 i2 i3 : interface) : StrictProvide2 (i1 + i2 + i3) i2 i1. 37 | 38 | Proof. 39 | typeclasses eauto. 40 | Qed. 41 | -------------------------------------------------------------------------------- /theories/Core/Component.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From ExtLib Require Import StateMonad. 8 | From FreeSpec.Core Require Export Interface Semantics Impure. 9 | 10 | (** * Definition *) 11 | 12 | (** In FreeSpec, a _component_ is an entity which exposes an interface [i], 13 | and uses primitives of an interface [j] to compute the results of primitives 14 | of [i]. Besides, a component is likely to carry its own internal state (of 15 | type [s]). 16 | 17 | << 18 | i +-------------------+ j 19 | | | | | 20 | +------>| | c : component i j |----->| 21 | | | | | 22 | +-------------------+ 23 | >> 24 | 25 | Thus, a component [c : component i j] is a polymorphic function which 26 | maps primitives of [i] to impure computations using [j]. *) 27 | 28 | Definition component (i j : interface) : Type := 29 | forall (α : Type), i α -> impure j α. 30 | 31 | (** The similarity between FreeSpec components and operational semantics may be 32 | confusing at first. The main difference between the two concepts is simple: 33 | operational semantics are self-contained terms which can, alone, be used to 34 | interpret impure computations of a given interface. Components, on the 35 | other hand, are not self-contained. Without an operational semantics for 36 | [j], we cannot use a component [c : component i j] to interpret an impure 37 | computation using [i]. 38 | 39 | Given an initial semantics for [j], we can however derive an operational 40 | semantics for [i] from a component [c]. *) 41 | 42 | (** * Semantics Derivation *) 43 | 44 | CoFixpoint derive_semantics {i j} (c : component i j) (sem : semantics j) 45 | : semantics i := 46 | mk_semantics (fun a p => 47 | let (res, next) := runState (to_state $ c a p) sem in 48 | (res, derive_semantics c next)). 49 | 50 | (** So, [semprod] on the one hand allows for composing operational semantics 51 | horizontally, and [derive_semantics] allows for composing components 52 | vertically. Using these two operators, we can model a complete system in a 53 | hierarchical and modular manner, by defining each of its components 54 | independently, then composing them together with [semprod] and 55 | [derive_semantics]. *) 56 | 57 | Definition bootstrap {i} (c : component i iempty) : semantics i := 58 | derive_semantics c iempty_semantics. 59 | 60 | (** * In-place Primitives Handling *) 61 | 62 | (** The function [with_component] allows for locally providing an additional 63 | interface [j] within an impure computation of type [impure ix a]. The 64 | primitives of [j] will be handled by impure computations, i.e., a component. 65 | of type [c : compoment j ix s]. *) 66 | 67 | #[local] 68 | Fixpoint with_component_aux {ix j α} (c : component j ix) (p : impure (ix + j) α) 69 | : impure ix α := 70 | match p with 71 | | local x => local x 72 | | request_then (in_right e) f => 73 | c _ e >>= fun res => with_component_aux c (f res) 74 | | request_then (in_left e) f => 75 | request_then e (fun x => with_component_aux c (f x)) 76 | end. 77 | 78 | Definition with_component {ix j α} 79 | (initializer : impure ix unit) 80 | (c : component j ix) 81 | (finalizer : impure ix unit) 82 | (p : impure (ix + j) α) 83 | : impure ix α := 84 | initializer;; 85 | let* res := with_component_aux c p in 86 | finalizer;; 87 | pure res. 88 | -------------------------------------------------------------------------------- /theories/Core/ComponentFacts.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From ExtLib Require Import StateMonad. 8 | From FreeSpec.Core Require Import Contract HoareFacts SemanticsFacts InstrumentFacts. 9 | From FreeSpec Require Export Component. 10 | 11 | (** We use an alternative definition of [derive_semantics], which has 12 | the virtue of being easier to reason with. More precisely, it 13 | behaves better with evaluation tactics such as [cbn] (according to 14 | our experience, [derive_semantics] requires explicit [destruct] 15 | call to deal with the [let ... in ...] construction). 16 | 17 | This is a detail of implementation of our proof, henceforth the 18 | definition is local and should not be used anywhere else. *) 19 | 20 | #[local] 21 | CoFixpoint derive_semantics' {i j} (c : component i j) (sem : semantics j) 22 | : semantics i := 23 | mk_semantics (fun a p => 24 | (evalState (to_state $ c a p) sem, 25 | derive_semantics' c (execState (to_state $ c a p) sem))). 26 | 27 | (** We prove these two definitions ([derive_semantics] and 28 | [derive_semantics']) are equivalent wrt. [semantics_eq]. *) 29 | 30 | #[local] 31 | Remark derive_semantics_equ `(c : component i j) (sem : semantics j) 32 | : (derive_semantics c sem === derive_semantics' c sem)%semantics. 33 | 34 | Proof. 35 | revert sem. 36 | cofix aux; intros sem. 37 | constructor; intros a e; 38 | cbn; 39 | unfold derive_semantics; 40 | unfold eval_effect; 41 | unfold exec_effect; 42 | unfold run_effect; 43 | unfold evalState; 44 | unfold execState; 45 | destruct runState. 46 | + reflexivity. 47 | + apply aux. 48 | Qed. 49 | 50 | (** ** Component Correctness *) 51 | 52 | (** We consider a component [c : component i j s], meaning [c] exposes an 53 | interface [i], uses an interface [j], and carries an internal state of type 54 | [s]. 55 | 56 | << 57 | c : component i j s 58 | i +---------------------+ j 59 | | | | | 60 | +------>| | st : s |----->| 61 | | | | | 62 | +---------------------+ 63 | >> 64 | 65 | We say [c] is correct wrt. [ci] (a contract for [i]) and [cj] (a contract 66 | for [i]) iff given primitives which satisfies the caller obligation of [ci], 67 | [c] will 68 | 69 | - use respectful impure computations wrt. [cj] 70 | - compute results which satisfy [ci] callee obligations, assuming it can 71 | rely on a semantics of [j] which complies with [cj] 72 | 73 | The two witness states [ωi : Ωi] (for [speci]) and [ωj : Ωj] (for [specj]), 74 | and [st : s] the internal state of [c] remained implicit in the previous 75 | sentence. In practice, we associate them together by means of a dedicated 76 | predicate [pred]. It is expected that [pred] is an invariant throughout 77 | [c]'s life, meaning that as long as [c] computes result for legitimate 78 | effects (wrt. [speci] effects, the updated values of [ωi], [ωj] and [st] 79 | continue to satisfy [pred]. *) 80 | 81 | Definition correct_component `{MayProvide jx j} 82 | `(c : component i jx) `(ci : contract i Ωi) `(cj : contract j Ωj) 83 | (pred : Ωi -> Ωj -> Prop) 84 | : Prop := 85 | forall (ωi : Ωi) (ωj : Ωj) (init : pred ωi ωj) 86 | `(e : i α) (o_caller : caller_obligation ci ωi e), 87 | pre (to_hoare cj $ c α e) ωj /\ 88 | forall (x : α) (ωj' : Ωj) (run : post (to_hoare cj $ c α e) ωj x ωj'), 89 | callee_obligation ci ωi e x /\ pred (witness_update ci ωi e x) ωj'. 90 | 91 | (** Once we have proven [c] is correct wrt. to [speci] and [specj] with [pred] 92 | acting as an invariant throughout [c] life, we show we can derive a 93 | semantics from [c] with an initial state [st] which complies to [speci] in 94 | accordance to [ωi] if we use a semantics of [j] which complies to [specj] in 95 | accordance to [ωj], where [pred ωi st ωj] is satisfied. *) 96 | 97 | Lemma correct_component_derives_compliant_semantics `{MayProvide jx j} 98 | `(c : component i jx) `(ci : contract i Ωi) `(cj : contract j Ωj) 99 | (pred : Ωi -> Ωj -> Prop) 100 | (correct : correct_component c ci cj pred) 101 | (ωi : Ωi) (ωj : Ωj) (inv : pred ωi ωj) 102 | (sem : semantics jx) (comp : compliant_semantics cj ωj sem) 103 | : compliant_semantics ci ωi (derive_semantics c sem). 104 | 105 | Proof. 106 | rewrite derive_semantics_equ. 107 | revert ωi ωj inv sem comp. 108 | cofix correct_component_derives_compliant_semantics. 109 | intros ωi ωj inv sem comp. 110 | unfold correct_component in correct. 111 | specialize (correct ωi ωj inv). 112 | constructor; intros a e req; specialize (correct a e req); 113 | destruct correct as [trust run]. 114 | + eapply run. 115 | cbn. 116 | ++ rewrite instrument_to_state_eval_morphism with (c0 := cj) (ω := ωj). 117 | now apply instrument_satisfies_hoare. 118 | + eapply correct_component_derives_compliant_semantics. 119 | ++ apply run. 120 | cbn. 121 | erewrite instrument_to_state_eval_morphism. 122 | apply instrument_satisfies_hoare. 123 | +++ exact comp. 124 | +++ exact trust. 125 | ++ erewrite instrument_to_state_exec_morphism. 126 | apply instrument_preserves_compliance. 127 | +++ exact comp. 128 | +++ apply trust. 129 | Qed. 130 | -------------------------------------------------------------------------------- /theories/Core/Contract.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | (** In this library, we provide the necessary material to reason about FreeSpec 8 | components both in isolation, and in composition. To do that, we focus our 9 | reasoning principles on interfaces, by defining how their primitives shall 10 | be used, and what to expect the result computed by “correct” operational 11 | semantics (according to a certain definition of “correct”). *) 12 | 13 | From Coq Require Import Setoid Morphisms. 14 | From ExtLib Require Import StateMonad MonadState MonadTrans. 15 | From FreeSpec.Core Require Import Interface Impure Semantics Component. 16 | 17 | #[local] 18 | Open Scope signature_scope. 19 | 20 | (** * Definition *) 21 | 22 | (** A contract dedicated to [i : interface] primarily provides two 23 | predicates. 24 | 25 | - [caller_obligation] distinguishes between primitives that can be used (by 26 | an impure computation), and primitives that cannot be used. 27 | - [callee_obligation] specifies which guarantees can be expected from 28 | primitives results, as computed by a “good” operational semantics. 29 | 30 | Both [caller_obligation] and [callee_obligation] model properties that may 31 | vary in time, e.g., a primitive may be forbidden at a given time, but 32 | authorized later. To take this possibility into account, contracts are 33 | parameterized by what we have called a “witness.” A witness is a term which 34 | describes the necessary information of the past, and allows for taking 35 | decision for the present. It can be seen as an abstraction of the concrete 36 | state of the interface implementor. 37 | 38 | To keep this state up-to-date after each primitive interpretation, 39 | contracts also define a dedicated function [witness_update]. *) 40 | 41 | Record contract (i : interface) (Ω : Type) : Type := make_contract 42 | { witness_update (ω : Ω) : forall (α : Type), i α -> α -> Ω 43 | ; caller_obligation (ω : Ω) : forall (α : Type), i α -> Prop 44 | ; callee_obligation (ω : Ω) : forall (α : Type), i α -> α -> Prop 45 | }. 46 | 47 | Declare Scope contract_scope. 48 | Bind Scope contract_scope with contract. 49 | 50 | Arguments make_contract [i Ω] (_ _ _). 51 | Arguments witness_update [i Ω] (c ω) [α] (_ _). 52 | Arguments caller_obligation [i Ω] (c ω) [α] (_). 53 | Arguments callee_obligation [i Ω] (c ω) [α] (_ _). 54 | 55 | (** The most simple contract we can define is the one that requires 56 | anything both for the impure computations which uses the primitives of a 57 | given interface, and for the operational semantics which compute results for 58 | these primitives. *) 59 | 60 | Definition const_witness {i} := 61 | fun (u : unit) (α : Type) (e : i α) (x : α) => u. 62 | 63 | Inductive no_caller_obligation {i Ω} (ω : Ω) (α : Type) (e : i α) : Prop := 64 | | mk_no_caller_obligation : no_caller_obligation ω α e. 65 | 66 | #[global] Hint Constructors no_caller_obligation : freespec. 67 | 68 | Inductive no_callee_obligation {i Ω} (ω : Ω) (α : Type) (e : i α) (x : α) : Prop := 69 | | mk_no_callee_obligation : no_callee_obligation ω α e x. 70 | 71 | #[global] Hint Constructors no_callee_obligation : freespec. 72 | 73 | Definition no_contract (i : interface) : contract i unit := 74 | {| witness_update := const_witness 75 | ; caller_obligation := no_caller_obligation 76 | ; callee_obligation := no_callee_obligation 77 | |}. 78 | 79 | (** A similar —and as simple— contract is the one that forbids the use of a 80 | given interface. *) 81 | 82 | Definition do_no_use {i Ω} (ω : Ω) (α : Type) (e : i α) : Prop := False. 83 | 84 | Definition forbid_specs (i : interface) : contract i unit := 85 | {| witness_update := const_witness 86 | ; caller_obligation := do_no_use 87 | ; callee_obligation := no_callee_obligation 88 | |}. 89 | 90 | (** * Contract Equivalence *) 91 | 92 | Definition contract_caller_equ `(c1 : contract i Ω1) `(c2 : contract i Ω2) 93 | (f : Ω1 -> Ω2) 94 | : Prop := 95 | forall ω1 a (p : i a), 96 | caller_obligation c1 ω1 p <-> caller_obligation c2 (f ω1) p. 97 | 98 | Definition contract_callee_equ `(c1 : contract i Ω1) `(c2 : contract i Ω2) 99 | (f : Ω1 -> Ω2) 100 | : Prop := 101 | forall ω1 a (p : i a) x, 102 | callee_obligation c1 ω1 p x <-> callee_obligation c2 (f ω1) p x. 103 | 104 | Definition contract_witness_equ `(c1 : contract i Ω1) `(c2 : contract i Ω2) 105 | (f : Ω1 -> Ω2) 106 | : Prop := 107 | forall ω1 a (p : i a) x, 108 | f (witness_update c1 ω1 p x) = witness_update c2 (f ω1) p x. 109 | 110 | Inductive contract_equ `(c1 : contract i Ω1) `(c2 : contract i Ω2) 111 | : Type := 112 | | mk_contract_equ (f : Ω1 -> Ω2) (g : Ω2 -> Ω1) 113 | (iso1 : forall x, f (g x) = x) (iso2 : forall x, g (f x) = x) 114 | (caller_equ : contract_caller_equ c1 c2 f) 115 | (callee_equ : contract_callee_equ c1 c2 f) 116 | (witness_equ : contract_witness_equ c1 c2 f) 117 | : contract_equ c1 c2. 118 | 119 | Definition contract_iso_lr `(c1 : contract i Ω1) `(c2 : contract i Ω2) 120 | (equ : contract_equ c1 c2) (ω1 : Ω1) 121 | : Ω2 := 122 | match equ with 123 | | @mk_contract_equ _ _ _ _ _ f _ _ _ _ _ _ => f ω1 124 | end. 125 | 126 | Definition contract_iso_rl `(c1 : contract i Ω1) `(c2 : contract i Ω2) 127 | (equ : contract_equ c1 c2) (ω2 : Ω2) 128 | : Ω1 := 129 | match equ with 130 | | @mk_contract_equ _ _ _ _ _ _ g _ _ _ _ _ => g ω2 131 | end. 132 | 133 | Arguments contract_iso_lr {i Ω1 c1 Ω2 c2} (equ ω1). 134 | Arguments contract_iso_rl {i Ω1 c1 Ω2 c2} (equ ω2). 135 | 136 | Lemma contract_equ_refl `(c : contract i Ω) 137 | : contract_equ c c. 138 | 139 | Proof. 140 | apply mk_contract_equ with (f:=fun x => x) (g:=fun x => x); auto. 141 | + now intros ω α p. 142 | + now intros ω α p x. 143 | + now intros ω α p x. 144 | Defined. 145 | 146 | Lemma contract_equ_sym `(c1 : contract i Ω1) `(c2 : contract i Ω2) 147 | (equ : contract_equ c1 c2) 148 | : contract_equ c2 c1. 149 | 150 | Proof. 151 | induction equ. 152 | apply mk_contract_equ with (f0:=g) (g0:=f). 153 | + apply iso2. 154 | + apply iso1. 155 | + intros ω α p. 156 | transitivity (caller_obligation c2 (f (g ω)) p). 157 | ++ now rewrite iso1. 158 | ++ now symmetry. 159 | + intros ω α p x. 160 | transitivity (callee_obligation c2 (f (g ω)) p x). 161 | ++ now rewrite iso1. 162 | ++ now symmetry. 163 | + intros ω α p x. 164 | rewrite <- (iso2 (witness_update c1 (g ω) p x)). 165 | assert (equ : witness_update c2 ω p x = f (witness_update c1 (g ω) p x)). { 166 | transitivity (witness_update c2 (f (g ω)) p x). 167 | + now rewrite iso1. 168 | + now rewrite witness_equ. 169 | } 170 | now rewrite equ. 171 | Defined. 172 | 173 | Lemma contract_equ_trans `(c1 : contract i Ω1) `(c2 : contract i Ω2) 174 | `(c3 : contract i Ω3) 175 | `(is_equ12 : contract_equ c1 c2) 176 | `(is_equ23 : contract_equ c2 c3) 177 | : contract_equ c1 c3. 178 | 179 | Proof. 180 | destruct is_equ12 as [f12 g21 isofg12 isogf12 caller_equ12 callee_equ12 witness_equ12]. 181 | destruct is_equ23 as [f23 g32 isofg23 isogf23 caller_equ23 callee_equ23 witness_equ23]. 182 | apply mk_contract_equ 183 | with (f:=fun x => f23 (f12 x)) (g:=fun x => g21 (g32 x)). 184 | + setoid_rewrite isofg12. 185 | now setoid_rewrite isofg23. 186 | + setoid_rewrite isogf23. 187 | now setoid_rewrite isogf12. 188 | + intros ω1 α p. 189 | transitivity (caller_obligation c2 (f12 ω1) p); 190 | [ now apply caller_equ12 191 | | now apply caller_equ23 ]. 192 | + intros ω1 α p x. 193 | transitivity (callee_obligation c2 (f12 ω1) p x); [ now apply callee_equ12 194 | | now apply callee_equ23 ]. 195 | + intros ω1 α p x. 196 | rewrite <- witness_equ23. 197 | assert (equ : f12 (witness_update c1 ω1 p x) = witness_update c2 (f12 ω1) p x) 198 | by now rewrite <- witness_equ12. 199 | now rewrite equ. 200 | Defined. 201 | 202 | (** * Composing Contracts *) 203 | 204 | (** As we compose interfaces and operational semantics, we can easily compose 205 | contracts together, by means of the [contractprod] operator. Given [i] and [j] 206 | two interfaces, if we can reason about [i] and [j] independently (e.g., the 207 | caller obligations of [j] do not vary when we use [i]), then we can compose 208 | [ci : contract i Ωi] and [cj : contract j Ωj], such that [contractprod ci cj] in a 209 | contract for [i + j]. *) 210 | 211 | Definition gen_witness_update `{MayProvide ix i} {Ω α} (c : contract i Ω) 212 | (ω : Ω) (e : ix α) (x : α) 213 | : Ω := 214 | match proj_p e with 215 | | Some e => witness_update c ω e x 216 | | None => ω 217 | end. 218 | 219 | Definition gen_caller_obligation `{MayProvide ix i} {Ω α} (c : contract i Ω) 220 | (ω : Ω) (e : ix α) 221 | : Prop := 222 | match proj_p e with 223 | | Some e => caller_obligation c ω e 224 | | None => True 225 | end. 226 | 227 | Definition gen_callee_obligation `{MayProvide ix i} {Ω α} (c : contract i Ω) 228 | (ω : Ω) (e : ix α) (x : α) 229 | : Prop := 230 | match proj_p e with 231 | | Some e => callee_obligation c ω e x 232 | | None => True 233 | end. 234 | 235 | Definition contractprod `{Provide ix i, Provide ix j} {Ωi Ωj} 236 | (ci : contract i Ωi) (cj : contract j Ωj) 237 | : contract ix (Ωi * Ωj) := 238 | {| witness_update := fun (ω : Ωi * Ωj) (α : Type) (e : ix α) (x : α) => 239 | (gen_witness_update ci (fst ω) e x, gen_witness_update cj (snd ω) e x) 240 | ; caller_obligation := fun (ω : Ωi * Ωj) (α : Type) (e : ix α) => 241 | gen_caller_obligation ci (fst ω) e /\ gen_caller_obligation cj (snd ω) e 242 | ; callee_obligation := fun (ω : Ωi * Ωj) (α : Type) (e : ix α) (x : α) => 243 | gen_callee_obligation ci (fst ω) e x /\ gen_callee_obligation cj (snd ω) e x 244 | |}. 245 | 246 | Infix "*" := contractprod : contract_scope. 247 | 248 | (** We also introduce a second composition operator which shares the 249 | witness state among its two operands. *) 250 | 251 | (* FIXME: Should be [StrictProvide2 ix i j] *) 252 | 253 | Definition sharedcontractprod `{Provide ix i, Provide ix j} 254 | `(ci : contract i Ω) (cj : contract j Ω) 255 | : contract ix Ω := 256 | {| 257 | witness_update := 258 | fun (ω : Ω) (α : Type) (e : ix α) (x : α) => 259 | (* we need to check [i] before [j] because [sharedcontractprod] 260 | will be right associative *) 261 | match proj_p (i:=i) e with 262 | | Some e => witness_update ci ω e x 263 | | _ => match proj_p (i:=j) e with 264 | | Some e => witness_update cj ω e x 265 | | _ => ω 266 | end 267 | end; 268 | caller_obligation := 269 | fun (ω : Ω) (α : Type) (e : ix α) => 270 | gen_caller_obligation ci ω e /\ gen_caller_obligation cj ω e; 271 | callee_obligation := 272 | fun (ω : Ω) (α : Type) (e : ix α) (x : α) => 273 | gen_callee_obligation ci ω e x /\ gen_callee_obligation cj ω e x 274 | |}. 275 | 276 | Infix "^" := sharedcontractprod : contract_scope. 277 | 278 | (** * Contract By Example *) 279 | 280 | (** Finally, and as an example, we define a contract for the interface 281 | [STORE s] we discuss in [FreeSpec.Core.Impure]. As a reminder, the 282 | interface is defined as follows: 283 | 284 | << 285 | Inductive STORE (s : Type) : interface := 286 | | Get : STORE s s 287 | | Put (x : s) : STORE s unit. 288 | >> 289 | 290 | For [STORE s], the best witness is the actual value of the mutable 291 | variable. Therefore, the contract for [STORE s] may be [specs (STORE 292 | s) s], and the witness will be updated after each [Put] call. *) 293 | 294 | Definition store_update (s : Type) := 295 | fun (x : s) (α : Type) (e : STORE s α) (_ : α) => 296 | match e with 297 | | Get => x 298 | | Put x' => x' 299 | end. 300 | 301 | (** Assuming the mutable variable is being initialized prior to any impure 302 | computation interpretation, we do not have any obligations over the use of 303 | [STORE s] primitives. We will get back to this assertion once we have 304 | defined our contract, but in the meantime, we define its callee obligation. 305 | 306 | The logic of these callee obligations is as follows: [Get] is expected to 307 | produce a result strictly equivalent to the witness, and we do not have any 308 | obligations about the result of [Put] (which belongs to [unit] anyway, so 309 | there is not much to tell). *) 310 | 311 | Inductive o_callee_store (s : Type) (x : s) : forall (α : Type), STORE s α -> α -> Prop := 312 | | get_o_callee (x' : s) (equ : x = x') : o_callee_store s x s Get x' 313 | | put_o_callee (x' : s) (u : unit) : o_callee_store s x unit (Put x') u. 314 | 315 | (** The actual contract can therefore be defined as follows: *) 316 | 317 | Definition store_specs (s : Type) : contract (STORE s) s := 318 | {| witness_update := store_update s 319 | ; caller_obligation := no_caller_obligation 320 | ; callee_obligation := o_callee_store s 321 | |}. 322 | 323 | (** Now, as we briefly mentionned, this contract allows for reasoning about an 324 | impure computation which uses the [STORE s] interface, assuming the mutable, 325 | global variable has been initialized. We can define another contract that 326 | does not rely on such assumption, and on the contrary, requires an impure 327 | computation to initialize the variable prior to using it. 328 | 329 | In this context, the witness can solely be a boolean which tells if the 330 | variable has been initialized, and the [callee_obligation] will require the 331 | witness to be [true] to authorize a call of [Get]. 332 | 333 | This is one of the key benefits of the FreeSpec approach: because the 334 | contracts are defined independently from impure computations and 335 | interfaces, we can actually define several contracts to consider 336 | different set of hypotheses. *) 337 | -------------------------------------------------------------------------------- /theories/Core/Core.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From FreeSpec.Core Require Export 8 | Interface 9 | Typeclasses 10 | Impure 11 | Semantics 12 | Component. 13 | 14 | #[global] 15 | Open Scope freespec_scope. 16 | -------------------------------------------------------------------------------- /theories/Core/CoreFacts.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From FreeSpec.Core Require Export 8 | Core 9 | Contract 10 | ImpureFacts 11 | SemanticsFacts 12 | Instrument 13 | InstrumentFacts 14 | Hoare 15 | HoareFacts 16 | ComponentFacts 17 | Tactics. 18 | 19 | #[global] 20 | Open Scope freespec_scope. 21 | -------------------------------------------------------------------------------- /theories/Core/Extraction.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From FreeSpec Require Import Core. 8 | 9 | (** FreeSpec has been designed from the start to be compatible with 10 | the extraction mechanism of Coq. That being said, this approach is 11 | no longer the preferred one, and we now advice to write your 12 | impure programs in a polymorphic monad, which is specialized in a 13 | [IO]-like monad (such as the one introduced by the 14 | <> package) for extraction, and [impure] for formal 15 | verification. *) 16 | 17 | (** * How to *) 18 | 19 | (** To get an executable program from an impure program [p] 20 | implemented in the [impure] monad parameterized by an interface 21 | [i], the approach is to define a function (said, [main]) whose 22 | body is of the form [run_impure ocaml_sem p], where [ocaml_sem] is 23 | a semantics for [i]. 24 | 25 | More precisely, for each constructor of [i], there should be an 26 | ocaml functions that can be called to handle it. These functions 27 | can be made available to Coq modules by (1) introducing an axiom, 28 | and (2) configuring the extraction mechanism accordingly. 29 | 30 | Once this is done, one can call [Recursive Extraction main]. *) 31 | 32 | (** * Extraction Configuration *) 33 | 34 | (** The extraction mechanism of Coq suffers, sadly, long standing 35 | bugs. These bugs prevents the extracted OCaml code to compile. 36 | Fortunately, these bugs can be avoided by inlining certain key 37 | definitions. Note that, at the time of writing this documentation, 38 | this approach does sadly not work with the [Recursive Extraction 39 | Library] command. *) 40 | 41 | Extraction Inline impure_Applicative. 42 | -------------------------------------------------------------------------------- /theories/Core/Hoare.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From ExtLib Require Import Functor Applicative Monad. 8 | From FreeSpec.Core Require Import Interface Impure Contract. 9 | 10 | (** To reason about impure computations, we introduce the “Hoare 11 | monad,” also called the “specification monad.” An instance of the 12 | specification monad is a couple of [pre] and [post] conditions, 13 | such that [pre p σ] means the program specified by [p] can be 14 | executed safely from a state [σ], and [post p σ x σ'] means the 15 | execution of [p] from [σ] may compute a result [x] and bring the 16 | system to a state [σ']. 17 | 18 | We equip this couple of predicate with a [bind] function to 19 | sequentially compose specifications. *) 20 | 21 | (** * Definition *) 22 | 23 | Record hoare (Σ : Type) (α : Type) : Type := 24 | mk_hoare { pre : Σ -> Prop 25 | ; post : Σ -> α -> Σ -> Prop 26 | }. 27 | 28 | Arguments mk_hoare {Σ α} (pre post). 29 | Arguments pre {Σ α} (_ _). 30 | Arguments post {Σ α} (_ _ _). 31 | 32 | Definition hoare_pure {Σ α} (x : α) : hoare Σ α := 33 | mk_hoare (fun _ => True) (fun s y s' => x = y /\ s = s'). 34 | 35 | Definition hoare_bind {Σ α β} (h : hoare Σ α) (k : α -> hoare Σ β) : hoare Σ β := 36 | mk_hoare (fun s => pre h s /\ (forall x s', post h s x s' -> pre (k x) s')) 37 | (fun s x s'' => exists y s', post h s y s' /\ post (k y) s' x s''). 38 | 39 | (** * Instances *) 40 | 41 | (** ** Functor *) 42 | 43 | Definition hoare_map {Σ α β} (f : α -> β) (h : hoare Σ α) : hoare Σ β := 44 | hoare_bind h (fun x => hoare_pure (f x)). 45 | 46 | Instance hoare_Functor Σ : Functor (hoare Σ) := 47 | { fmap := fun _ _ => hoare_map }. 48 | 49 | (** ** Applicative *) 50 | 51 | Definition hoare_apply {Σ α β} (hf : hoare Σ (α -> β)) (h : hoare Σ α) 52 | : hoare Σ β := 53 | hoare_bind hf (fun f => hoare_map f h). 54 | 55 | Instance hoare_Applicative Σ : Applicative (hoare Σ) := 56 | { ap := fun _ _ => hoare_apply 57 | ; pure := fun _ => hoare_pure 58 | }. 59 | 60 | (** ** Monad *) 61 | 62 | Instance hoare_Monad Σ : Monad (hoare Σ) := 63 | { ret := @hoare_pure Σ; bind := @hoare_bind Σ }. 64 | 65 | (** * Reasoning about Programs *) 66 | 67 | Definition interface_to_hoare `{MayProvide ix i} `(c : contract i Ω) : ix ~> hoare Ω := 68 | fun a e => 69 | {| pre := fun ω => gen_caller_obligation c ω e 70 | ; post := fun ω x ω' => gen_callee_obligation c ω e x 71 | /\ ω' = gen_witness_update c ω e x 72 | |}. 73 | 74 | Definition to_hoare `{MayProvide ix i} `(c : contract i Ω) 75 | : impure ix ~> hoare Ω := 76 | impure_lift (interface_to_hoare c). 77 | 78 | Arguments to_hoare {ix i _ Ω} c {α} _. 79 | -------------------------------------------------------------------------------- /theories/Core/HoareFacts.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From FreeSpec.Core Require Import Interface ImpureFacts Contract. 8 | From FreeSpec.Core Require Export Hoare. 9 | 10 | (** * Equivalence Relation *) 11 | 12 | Inductive hoare_eq {Σ α} (h1 h2 : hoare Σ α) : Prop := 13 | | mk_hoare_eq 14 | (pre_eq : forall s, pre h1 s <-> pre h2 s) 15 | (post_eq : forall s x s', post h1 s x s' <-> post h2 s x s') 16 | : hoare_eq h1 h2. 17 | 18 | #[program] 19 | Instance hoare_Equivalence Σ α : @Equivalence (hoare Σ α) hoare_eq. 20 | 21 | Next Obligation. 22 | easy. 23 | Qed. 24 | 25 | Next Obligation. 26 | intros h1 h2 equ. 27 | constructor; 28 | symmetry; 29 | apply equ. 30 | Qed. 31 | 32 | Next Obligation. 33 | intros h1 h2 h3 equ_1_2 equ_2_3. 34 | constructor. 35 | + intros s. 36 | transitivity (pre h2 s); [ apply equ_1_2 | apply equ_2_3 ]. 37 | + intros s x s'. 38 | transitivity (post h2 s x s'); [ apply equ_1_2 | apply equ_2_3 ]. 39 | Qed. 40 | 41 | (** * Proper Instances *) 42 | 43 | #[program] 44 | Instance pre_Proper Σ α : Proper (hoare_eq ==> eq ==> iff) (@pre Σ α). 45 | 46 | Next Obligation. 47 | add_morphism_tactic. 48 | intros h1 h2 equ s. 49 | apply equ. 50 | Qed. 51 | 52 | #[program] 53 | Instance post_Proper Σ α : Proper (hoare_eq ==> eq ==> eq ==> eq ==> iff) (@post Σ α). 54 | 55 | Next Obligation. 56 | add_morphism_tactic. 57 | intros h1 h2 equ s x s'. 58 | apply equ. 59 | Qed. 60 | 61 | #[program] 62 | Instance to_hoare_Proper ix i Ω c α MP 63 | : Proper (impure_eq ==> hoare_eq) (@to_hoare ix i MP Ω c α). 64 | 65 | Next Obligation. 66 | add_morphism_tactic. 67 | intros p q equ. 68 | induction equ. 69 | + reflexivity. 70 | + constructor. 71 | ++ intros ω. 72 | cbn in *. 73 | setoid_rewrite H. 74 | reflexivity. 75 | ++ intros ω x ω'. 76 | cbn in *. 77 | setoid_rewrite H. 78 | reflexivity. 79 | Qed. 80 | 81 | (** * General Lemmas *) 82 | 83 | Lemma to_hoare_step `{MayProvide ix i} `(c : contract i Ω) 84 | `(e : ix a) `(f : a -> impure ix a) 85 | `(hpre : pre (to_hoare c (request_then e f)) ω) 86 | (x : a) (step : gen_callee_obligation c ω e x) 87 | : pre (to_hoare c (f x)) (gen_witness_update c ω e x). 88 | 89 | Proof. 90 | destruct hpre as [hbefore hafter]. 91 | apply hafter. 92 | cbn. 93 | unfold gen_callee_obligation, gen_witness_update in *. 94 | now destruct proj_p. 95 | Qed. 96 | 97 | #[global] Hint Resolve to_hoare_step : freespec. 98 | 99 | Lemma to_hoare_pre_bind_assoc `{MayProvide ix i} `(c : contract i Ω) 100 | `(p : impure ix a) `(Hp : pre (to_hoare c p) ω) 101 | `(f : a -> impure ix b) 102 | (run : forall (x : a) (ω' : Ω), 103 | post (to_hoare c p) ω x ω' -> pre (to_hoare c (f x)) ω') 104 | : pre (to_hoare c (p >>= f)) ω. 105 | 106 | Proof. 107 | revert ω Hp run. 108 | induction p; intros ω Hp run. 109 | + now apply run. 110 | + cbn in Hp. 111 | destruct Hp as [He Hn]. 112 | change (request_then e f0 >>= f) 113 | with (request_then e (fun x => f0 x >>= f)). 114 | split. 115 | ++ exact He. 116 | ++ intros x ω' Hpost. 117 | specialize Hn with x ω'. 118 | destruct Hpost. 119 | rewrite H2 in *. 120 | assert (Hpre : pre (to_hoare c (f0 x)) (gen_witness_update c ω e x)) 121 | by now apply Hn. 122 | apply H0; [ apply Hpre |]. 123 | intros y ω'' Hpost. 124 | apply run. 125 | cbn. 126 | exists x. 127 | exists ω'. 128 | split; [split |]. 129 | +++ exact H1. 130 | +++ exact H2. 131 | +++ rewrite H2. 132 | exact Hpost. 133 | Qed. 134 | 135 | #[global] Hint Resolve to_hoare_pre_bind_assoc : freespec. 136 | 137 | Lemma to_hoare_post_bind_assoc `{MayProvide ix i} `(c : contract i Ω) 138 | `(p : impure ix a) `(f : a -> impure ix b) 139 | `(Hp : post (to_hoare c (impure_bind p f)) ω x ω') 140 | : exists y ω'', 141 | post (to_hoare c p) ω y ω'' /\ post (to_hoare c $ f y) ω'' x ω'. 142 | 143 | Proof. 144 | revert ω Hp. 145 | induction p; intros ω Hp. 146 | + now exists x0, ω. 147 | + destruct Hp as [y [ω'' [Hp1 Hp2]]]. 148 | apply H0 in Hp2. 149 | destruct Hp2 as [z [ω''' [Hp2 Hp3]]]. 150 | exists z, ω'''. 151 | split; [| apply Hp3]. 152 | exists y, ω''. 153 | now split. 154 | Qed. 155 | 156 | #[global] Hint Resolve to_hoare_post_bind_assoc : freespec. 157 | 158 | Lemma to_hoare_contractprod `{Provide ix i, Provide ix j} 159 | `(ci : contract i Ωi) `(cj : contract j Ωj) 160 | `(p : impure ix a) 161 | `(prei : pre (to_hoare ci p) ωi) `(prej : pre (to_hoare cj p) ωj) 162 | : pre (to_hoare (ci * cj) p) (ωi, ωj). 163 | 164 | Proof. 165 | revert ωi prei ωj prej. 166 | induction p; intros ωi prei ωj prej. 167 | + auto. 168 | + destruct prei as [calleri Hcalleei]. 169 | destruct prej as [callerj Hcalleej]. 170 | split. 171 | ++ now split. 172 | ++ intros x [ωi' ωj'] [[calleei calleej] equωs]. 173 | cbn in equωs. 174 | inversion equωs; subst. 175 | apply H3. 176 | +++ apply Hcalleei. 177 | now split. 178 | +++ apply Hcalleej. 179 | now split. 180 | Qed. 181 | 182 | #[global] Hint Resolve to_hoare_contractprod : freespec. 183 | 184 | Lemma contract_equ_pre `(c1 : contract i Ω1) `(c2 : contract i Ω2) 185 | `(equ : contract_equ c1 c2) (ω1 : Ω1) 186 | `(p : impure i a) 187 | : pre (to_hoare c1 p) ω1 <-> pre (to_hoare c2 p) (contract_iso_lr equ ω1). 188 | 189 | Proof. 190 | induction equ. 191 | revert ω1. 192 | induction p; intros ω1. 193 | + now split. 194 | + cbn. 195 | rewrite (caller_equ ω1 β e). 196 | setoid_rewrite (callee_equ ω1 β e). 197 | split. 198 | ++ intros [ocaller onext]. 199 | split; auto. 200 | intros x ω1' [ocallee owitness]. 201 | rewrite owitness. 202 | rewrite <- witness_equ. 203 | rewrite <- H; eauto. 204 | ++ intros [ocaller onext]. 205 | split; auto. 206 | intros x ω1' [ocallee owitness]. 207 | rewrite H; eauto. 208 | rewrite owitness. 209 | cbn. 210 | rewrite witness_equ. 211 | eauto. 212 | Qed. 213 | 214 | #[global] Hint Resolve contract_equ_pre : freespec. 215 | 216 | Lemma contract_equ_post `(c1 : contract i Ω1) `(c2 : contract i Ω2) 217 | `(equ : contract_equ c1 c2) (ω1 ω1' : Ω1) 218 | `(p : impure i a) (x : a) 219 | (post1 : post (to_hoare c1 p) ω1 x ω1') 220 | : post (to_hoare c2 p) (contract_iso_lr equ ω1) x (contract_iso_lr equ ω1'). 221 | 222 | Proof. 223 | induction equ. 224 | cbn in *. 225 | revert x ω1 ω1' post1. 226 | induction p; intros y ω1 ω1' post1. 227 | + destruct post1 as [xequ ω1equ]. 228 | cbn. 229 | now subst. 230 | + cbn in post1. 231 | destruct post1 as [x [ω1'' [[ocallee owitness] post1]]]. 232 | eapply H in post1. 233 | exists x. 234 | exists (f ω1''). 235 | split; auto. 236 | cbn. 237 | repeat split. 238 | ++ eapply callee_equ; eauto. 239 | ++ rewrite owitness. 240 | apply witness_equ. 241 | Qed. 242 | 243 | #[global] Hint Resolve contract_equ_post : freespec. 244 | -------------------------------------------------------------------------------- /theories/Core/Impure.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | (** In [FreeSpec.Core.Interface], we have introduced the [interface] type, to 8 | model the set of primitives an impure computation can use. We also introduce 9 | [MayProvide], [Provide] and [Distinguish]. They are three type classes which 10 | allow for manipulating _polymorphic interface composite_. 11 | 12 | 13 | In this library, we provide the [impure] monad, defined after the 14 | <> monad introduced by the <> package (see 15 | <>). *) 16 | 17 | From Coq Require Import Program Setoid Morphisms. 18 | From ExtLib Require Export MonadState. 19 | From FreeSpec.Core Require Export Interface. 20 | 21 | (** We introduce the [impure] monad to describe impure computations, that is 22 | computations which uses primitives from certain interfaces. *) 23 | 24 | (** * Definition *) 25 | 26 | (** The [impure] monad is an inductive datatype with two parameters: the 27 | interface [i] to be used, and the type [α] of the result of the computation. 28 | The fact that [impure] is inductive rather than co-inductive means it is not 29 | possible to describe infinite computations. This also means it is possible 30 | to interpret impure computations within Coq, providing an operational 31 | semantics for [i]. *) 32 | 33 | Inductive impure (i : interface) (α : Type) : Type := 34 | | local (x : α) : impure i α 35 | | request_then {β} (e : i β) (f : β -> impure i α) : impure i α. 36 | 37 | Arguments local [i α] (x). 38 | Arguments request_then [i α β] (e f). 39 | 40 | Register impure as freespec.core.impure.type. 41 | Register local as freespec.core.impure.local. 42 | Register request_then as freespec.core.impure.request_then. 43 | 44 | Declare Scope impure_scope. 45 | Bind Scope impure_scope with impure. 46 | Delimit Scope impure_scope with impure. 47 | 48 | (** * Monad Instances *) 49 | 50 | (** We then provide the necessary instances of the <> Monad 51 | typeclasses hierarchy. *) 52 | 53 | Fixpoint impure_bind {i α β} (p : impure i α) (f : α -> impure i β) : impure i β := 54 | match p with 55 | | local x => f x 56 | | request_then e g => request_then e (fun x => impure_bind (g x) f) 57 | end. 58 | 59 | Definition impure_map {i α β} (f : α -> β) (p : impure i α) : impure i β := 60 | impure_bind p (fun x => local (f x)). 61 | 62 | Instance impure_Functor i : Functor (impure i) := 63 | { fmap := @impure_map i 64 | }. 65 | 66 | Definition impure_pure {i α} (x : α) : impure i α := local x. 67 | 68 | Definition impure_apply {i α β} (p : impure i (α -> β)) (q : impure i α) : impure i β := 69 | impure_bind p (fun f => fmap f q). 70 | 71 | Instance impure_Applicative i : Applicative (impure i) := 72 | { pure := @impure_pure i 73 | ; ap := @impure_apply i 74 | }. 75 | 76 | Instance impure_Monad (i : interface) : Monad (impure i) := 77 | { ret := @impure_pure i 78 | ; bind := @impure_bind i 79 | }. 80 | 81 | (** * Defining Impure Computations *) 82 | 83 | (** FreeSpec users shall not use the [impure] monad constructors directly. The 84 | [pure] function from the [Applicative] typeclass allows for defining pure 85 | computations which do not depend on any impure primitive. The [bind] 86 | function from the [Monad] typeclass allows for seamlessly combine impure 87 | computations together. 88 | 89 | To complete these two monadic operations, we introduce the [request] 90 | function, whose purpose is to define an impure computation that uses a given 91 | primitive [e] from an interface [i], and returns its result. [request] does 92 | not parameterize the [impure] monad with [i] directly, but rather with a 93 | generic interface [ix]. [ix] is constrained with the [Provide] notation, so 94 | that it has to provide at least [i]'s primitives. *) 95 | 96 | Definition request `{Provide ix i} {α} (e : i α) : impure ix α := 97 | request_then (inj_p e) (fun x => pure x). 98 | 99 | (** Note: there have been attempts to turn [request] into a typeclass 100 | function (to seamlessly use [request] with a [MonadTrans] instance such as 101 | [state_t]). The reason why it has not been kept into the codebase is that 102 | the flexibility it gives for writing code has a real impact on the 103 | verification process. It is simpler to reason about “pure” impure 104 | computations (that is, not within a monad stack), then wrapping these 105 | computations thanks to [lift]. 106 | 107 | The <> provides notations (inspired by the do notation of 108 | Haskell) to write monadic functions more easily. These notations live 109 | inside the [monad_scope]. *) 110 | 111 | Instance store_monad_state (s : Type) (ix : interface) `{Provide ix (STORE s)} 112 | : MonadState s (impure ix) := 113 | { put := fun (x : s) => request (Put x) 114 | ; get := request Get 115 | }. 116 | 117 | (** * Lift *) 118 | 119 | Definition impure_lift `{Monad m} `(l : i ~> m) : impure i ~> m := 120 | fix aux a (p : impure i a) := 121 | match p with 122 | | local x => ret x 123 | | request_then e f => let* x := l _ e in aux a (f x) 124 | end. 125 | -------------------------------------------------------------------------------- /theories/Core/ImpureFacts.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From FreeSpec.Core Require Export Impure. 8 | 9 | (** * Equivalence *) 10 | 11 | (** Due to the definition of [impure] and [impure_bind], we could decide to rely 12 | on Coq built-in [eq] to reason about impure computations equivalence, but we 13 | would have to use the functional extensionality axiom to handle the 14 | continuation of the [request_then] constructor. In order to keep FreeSpec 15 | axiom-free, we rather provide a custom equivalence for [impure] terms. *) 16 | 17 | (** ** Definition *) 18 | 19 | (** The definition of [impure_equiv] is two-fold. *) 20 | 21 | Inductive impure_eq {i α} : impure i α -> impure i α -> Prop := 22 | 23 | (** - Two impure computations are equivalent if and only if they compute the 24 | exact same term (wrt. Coq [eq] function). *) 25 | 26 | | local_eq (x : α) : impure_eq (local x) (local x) 27 | 28 | (** - Two computations which consist in requesting the interpretation of an 29 | primitive and passing the result to a monadic continuation are equivalent 30 | if and only if they use the exact same primitive in the first place, and 31 | given any result the interpretation of this primitive may produce, their 32 | continuation returns equivalent impure computations. *) 33 | 34 | | request_eq {β} (e : i β) (f g : β -> impure i α) 35 | (equ : function_eq impure_eq f g) 36 | : impure_eq (request_then e f) (request_then e g). 37 | 38 | Infix "===" := impure_eq : impure_scope. 39 | 40 | (** The definition of [impure_equiv] is very similar to [eq], with the exception 41 | of the treatment of the continuation. There is no much effort to put into 42 | proving this is indeed a proper equivalence. *) 43 | 44 | #[program] 45 | Instance impure_Equivalence i α : @Equivalence (impure i α) impure_eq := {}. 46 | 47 | Next Obligation. 48 | intros p. 49 | induction p; constructor. 50 | intros x. 51 | apply H. 52 | Qed. 53 | 54 | Next Obligation. 55 | intros p q equ. 56 | induction equ; constructor. 57 | intros x. 58 | apply H. 59 | Qed. 60 | 61 | Next Obligation. 62 | intros p q r pq qr. 63 | revert p r pq qr. 64 | induction q; intros p r pq qr. 65 | + inversion pq; ssubst; inversion qr; ssubst. 66 | constructor. 67 | + inversion pq; ssubst; inversion qr; ssubst. 68 | constructor. 69 | intros x. 70 | cbv in H. 71 | now apply H with (β := x). 72 | Qed. 73 | 74 | (** ** Proper Instances *) 75 | 76 | #[local] 77 | Ltac change_request_then := 78 | match goal with 79 | | |- (request_then ?e ?f === request_then ?e ?g)%impure => 80 | let R := fresh "R" in 81 | assert (R: function_eq impure_eq f g); [ intros ?x | rewrite R; clear R ] 82 | end. 83 | 84 | #[local] 85 | Ltac change_impure_bind := 86 | match goal with 87 | | |- (impure_bind ?e ?f === impure_bind ?e ?g)%impure => 88 | let R := fresh "R" in 89 | assert (R: function_eq impure_eq f g); [ intros ?x | now rewrite R ] 90 | end. 91 | 92 | #[program] 93 | Instance request_then_Proper i α β 94 | : Proper (eq ==> function_eq impure_eq ==> impure_eq) (@request_then i α β). 95 | 96 | Next Obligation. 97 | add_morphism_tactic. 98 | intros e f g equ. 99 | constructor. 100 | intros y. 101 | specialize (equ y). 102 | now rewrite equ. 103 | Qed. 104 | 105 | #[program] 106 | Instance impure_bind_Proper i α β 107 | : Proper (impure_eq ==> function_eq impure_eq ==> impure_eq) (@impure_bind i α β). 108 | 109 | Next Obligation. 110 | add_morphism_tactic. 111 | intros x y equ1 f g equ2. 112 | induction equ1. 113 | + cbn. 114 | now rewrite (equ2 x). 115 | + cbn. 116 | constructor. 117 | intros x. 118 | apply H. 119 | Qed. 120 | 121 | Instance impure_map_Proper i α β 122 | : Proper (function_eq eq ==> impure_eq ==> impure_eq) (@impure_map i α β). 123 | 124 | Proof. 125 | add_morphism_tactic. 126 | intros f g equf p q equp. 127 | unfold impure_map. 128 | rewrite equp. 129 | change_impure_bind. 130 | now rewrite equf. 131 | Qed. 132 | 133 | #[program] 134 | Instance impure_apply_Proper i α β 135 | : Proper (impure_eq ==> impure_eq ==> impure_eq) (@impure_apply i α β). 136 | 137 | Next Obligation. 138 | add_morphism_tactic. 139 | intros p q equ1 r s equ2. 140 | unfold impure_apply. 141 | rewrite equ1. 142 | change_impure_bind. 143 | cbn. 144 | now rewrite equ2. 145 | Qed. 146 | 147 | (** * Equations *) 148 | 149 | (** Monadic laws as defined in [ExtLib.Structures.MonadLaws] an related are 150 | expressed against [eq], which is too strong in the general case, and in 151 | [impure]’s case in particular. We could prove them using the functional 152 | extensionality axiom, but we’d rather provide an alternative implementaiton 153 | of these laws defined against [impure_eq] instead. *) 154 | 155 | Lemma impure_bind_local {i α} (p : impure i α) 156 | : (impure_bind p (fun x => local x) === p)%impure. 157 | 158 | Proof. 159 | induction p. 160 | + reflexivity. 161 | + cbn. 162 | change_request_then; [| reflexivity]. 163 | now rewrite H. 164 | Qed. 165 | 166 | Lemma impure_bind_assoc {i α β δ} 167 | (p : impure i α) (f : α -> impure i β) (g : β -> impure i δ) 168 | : (impure_bind (impure_bind p f) g 169 | === impure_bind p (fun x => impure_bind (f x) g))%impure. 170 | 171 | Proof. 172 | induction p; [reflexivity |]. 173 | cbn. 174 | change_request_then; auto. 175 | reflexivity. 176 | Qed. 177 | 178 | Lemma bind_request_then_assoc `(e : i a) `(f : a -> impure i b) `(g : b -> impure i c) 179 | : request_then e f >>= g = request_then e (fun x => f x >>= g). 180 | 181 | Proof. 182 | reflexivity. 183 | Qed. 184 | -------------------------------------------------------------------------------- /theories/Core/Init.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | (** * Utils Functions *) 8 | 9 | Definition when {m : Type -> Type} `{Monad m} (cond : bool) `(p : m a) : m unit := 10 | if cond then (p;; pure tt) else pure tt. 11 | 12 | (** * Tactics *) 13 | 14 | From Coq Require Export Eqdep. 15 | 16 | Ltac ssubst := 17 | lazymatch goal with 18 | | [ H : existT _ _ _ = existT _ _ _ |- _ ] 19 | => apply Eqdep.EqdepTheory.inj_pair2 in H; ssubst 20 | | [ |- _] => subst 21 | end. 22 | 23 | (** * Notations *) 24 | 25 | Declare Scope freespec_scope. 26 | Delimit Scope freespec_scope with freespec. 27 | 28 | Reserved Infix "===" (at level 70, no associativity). 29 | 30 | Notation "m '~>' n" := 31 | (forall (α : Type), m α -> n α) 32 | (at level 80, no associativity) 33 | : type_scope. 34 | 35 | (** * Generalizable Functions Equality *) 36 | 37 | Definition function_eq {a b} (r : b -> b -> Prop) (f g : a -> b) : Prop := 38 | forall (x : a), r (f x) (g x). 39 | 40 | #[program] 41 | Instance function_eq_Equivalence a `(Equivalence b r) 42 | : @Equivalence (a -> b) (function_eq r). 43 | 44 | Next Obligation. 45 | now intros f x. 46 | Qed. 47 | 48 | Next Obligation. 49 | intros f g equ x. 50 | symmetry. 51 | apply equ. 52 | Qed. 53 | 54 | Next Obligation. 55 | intros f g h equ1 equ2 x. 56 | transitivity (g x); [ apply equ1 | apply equ2 ]. 57 | Qed. 58 | 59 | (** * Hint Databases *) 60 | 61 | #[global] Create HintDb freespec. 62 | -------------------------------------------------------------------------------- /theories/Core/Instrument.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From ExtLib Require Import StateMonad MonadTrans. 8 | #[local] Existing Instance Monad_stateT. 9 | From FreeSpec.Core Require Import Interface Semantics Contract. 10 | 11 | Notation instrument Ω i := (stateT Ω (state (semantics i))). 12 | 13 | Definition interface_to_instrument `{MayProvide ix i} `(c : contract i Ω) 14 | : ix ~> instrument Ω ix := 15 | fun a e => 16 | let* x := lift $ interface_to_state _ e in 17 | modify (fun ω => gen_witness_update c ω e x);; 18 | ret x. 19 | 20 | Definition to_instrument `{MayProvide ix i} `(c : contract i Ω) 21 | : impure ix ~> instrument Ω ix := 22 | impure_lift $ interface_to_instrument c. 23 | 24 | Arguments to_instrument {ix i _ Ω} (c) {α}. 25 | 26 | Definition instrument_to_state {i} `(ω : Ω) : instrument Ω i ~> state (semantics i) := 27 | fun a instr => fst <$> runStateT instr ω. 28 | 29 | Arguments instrument_to_state {i Ω} (ω) {α}. 30 | -------------------------------------------------------------------------------- /theories/Core/InstrumentFacts.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From ExtLib Require Import StateMonad. 8 | From FreeSpec.Core Require Import Contract HoareFacts SemanticsFacts. 9 | From FreeSpec.Core Require Export Instrument. 10 | 11 | Lemma instrument_to_state_eval_morphism `{MayProvide ix i} 12 | `(c : contract i Ω) `(p : impure ix a) (ω : Ω) 13 | : forall (sem : semantics ix), 14 | evalState (to_state p) sem 15 | = fst (evalState (runStateT (to_instrument c p) ω) sem). 16 | 17 | Proof. 18 | unfold evalState. 19 | revert ω. 20 | induction p. 21 | + reflexivity. 22 | + intros ω sem. 23 | cbn -[gen_witness_update]. 24 | destruct run_effect; cbn. 25 | now rewrite H0 with (ω := gen_witness_update c ω e β0). 26 | Qed. 27 | 28 | Lemma instrument_to_state_exec_morphism `{MayProvide ix i} 29 | `(c : contract i Ω) `(p : impure ix a) (ω : Ω) 30 | : forall (sem : semantics ix), 31 | execState (to_state p) sem 32 | = execState (runStateT (to_instrument c p) ω) sem. 33 | 34 | Proof. 35 | unfold execState. 36 | revert ω. 37 | induction p. 38 | + reflexivity. 39 | + intros ω sem. 40 | cbn -[gen_witness_update]. 41 | destruct run_effect; cbn. 42 | now rewrite H0 with (ω := gen_witness_update c ω e β0). 43 | Qed. 44 | 45 | Lemma instrument_satisfies_hoare `{MayProvide ix i} 46 | `(c : contract i Ω) `(p : impure ix a) 47 | `(comp : compliant_semantics c ω sem) 48 | : pre (to_hoare c p) ω 49 | -> post 50 | (to_hoare c p) 51 | ω 52 | (fst $ evalState (runStateT (to_instrument c p) ω) sem) 53 | (snd $ evalState (runStateT (to_instrument c p) ω) sem). 54 | 55 | Proof. 56 | revert comp. revert ω. revert sem. 57 | induction p; intros sem ω comp. 58 | + cbn. 59 | intros _. 60 | split; reflexivity. 61 | + intros pre. 62 | cbn -[interface_to_hoare] in pre. 63 | destruct pre as [He Hf]. 64 | cbn in He. 65 | inversion comp; subst. 66 | pose proof He as He'. 67 | apply o_callee in He. 68 | cbn. 69 | exists (eval_effect sem e). 70 | exists (gen_witness_update c ω e (eval_effect sem e)). 71 | split; [split |]. 72 | ++ apply He. 73 | ++ reflexivity. 74 | ++ unfold evalState. cbn. 75 | repeat rewrite run_effect_equation. 76 | apply H0. 77 | +++ apply next. 78 | apply He'. 79 | +++ apply Hf. 80 | cbn. 81 | now split. 82 | Qed. 83 | 84 | Lemma instrument_preserves_compliance `{MayProvide ix i} 85 | `(c : contract i Ω) `(p : impure ix a) 86 | `(comp : compliant_semantics c ω sem) 87 | : pre (to_hoare c p) ω 88 | -> compliant_semantics 89 | c 90 | (snd $ evalState (runStateT (to_instrument c p) ω) sem) 91 | (execState (runStateT (to_instrument c p) ω) sem). 92 | 93 | Proof. 94 | revert comp. revert ω. revert sem. 95 | induction p; intros sem ω comp pre. 96 | + auto. 97 | + cbn in pre. 98 | destruct pre as [He Hn]. 99 | specialize Hn with (eval_effect sem e) 100 | (gen_witness_update (H := H) c ω e (eval_effect sem e)). 101 | inversion comp; subst. 102 | assert (Hn' : pre (to_hoare c (f (eval_effect sem e))) (gen_witness_update c ω e (eval_effect sem e))). { 103 | apply Hn. 104 | split; [| reflexivity]. 105 | now apply o_callee. 106 | } 107 | eapply H0 in Hn'; [| now apply next ]. 108 | replace (snd (evalState (runStateT (to_instrument c (request_then e f)) ω) sem)) 109 | with (snd 110 | (evalState 111 | (runStateT (to_instrument c (f (eval_effect sem e))) 112 | (gen_witness_update c ω e (eval_effect sem e))) (exec_effect sem e))). 113 | replace (execState (runStateT (to_instrument c (request_then e f)) ω) sem) 114 | with (execState 115 | (runStateT (to_instrument c (f (eval_effect sem e))) 116 | (gen_witness_update c ω e (eval_effect sem e))) (exec_effect sem e)). 117 | ++ apply Hn'. 118 | ++ cbn. 119 | unfold execState at 2. cbn. 120 | now rewrite run_effect_equation. 121 | ++ cbn. 122 | unfold evalState at 2. cbn. 123 | now rewrite run_effect_equation. 124 | Qed. 125 | -------------------------------------------------------------------------------- /theories/Core/Interface.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From FreeSpec.Core Require Export Init. 8 | From Coq Require Import Program. 9 | 10 | (** * Definition *) 11 | 12 | (** Following the definition of the <> package, interfaces in 13 | FreeSpec are parameterized inductive types whose terms purposely describe 14 | the primitives the interface provides. *) 15 | 16 | Definition interface := Type -> Type. 17 | 18 | Declare Scope interface_scope. 19 | Bind Scope interface_scope with interface. 20 | 21 | (** Given [i : interface], a term of type [i α] identifies a primitive of [i] 22 | expected to produce a result of type [α]. 23 | 24 | The simpler interface is the empty interface, which provides no primitives 25 | whatsoever. *) 26 | 27 | Inductive iempty : interface := . 28 | 29 | (** Another example of general-purpose interface we can define is the [STORE s] 30 | interface, where [s] is a type for a state, and [STORE s] allows for 31 | manipulating a global, mutable variable of type [s] within an impure 32 | computation. *) 33 | 34 | Inductive STORE (s : Type) : interface := 35 | | Get : STORE s s 36 | | Put (x : s) : STORE s unit. 37 | 38 | Arguments Get {s}. 39 | Arguments Put [s] (x). 40 | 41 | (** According to the definition of [STORE s], an impure computation can use two 42 | primitives. The term [Get : STORE s s] describes a primitive expected to 43 | produce a result of type [s], that is the current value of the mutable 44 | variable. Terms of the form [Put x : STORE s unit] describe a primitive 45 | which does not produce any meaningful result, but is expected to update the 46 | current value of the mutable variable. 47 | 48 | The use of the word “expected” to describe the primitive of [STORE s] is 49 | voluntary. The definition of an interface does not attach any particular 50 | semantics to the primitives it describes. This will come later, and in 51 | fact, one interface may have many legitimate semantics. 52 | 53 | Impure computations are likely to use more than one interface, but the 54 | [impure] monad takes only one argument. We introduce [iplus] (denoted by 55 | [<+>] or [⊕]) to compose interfaces together. An impure computation 56 | parameterized by [i ⊕ j] can therefore leverage the primitives of both [i] 57 | and [j]. *) 58 | 59 | (** * Polymorphic Interface Composites *) 60 | 61 | (** When defining general-purpose impure computations that we expect to reuse in 62 | different context, we want to leave the interface as a parameter, and rather 63 | express the constraints in terms of interface availability. We tackle this 64 | challenge by means of _interface composites_. 65 | 66 | - We say an interface composite [ix] _provides_ a concrete interface [i] 67 | when there exists a function [inj_p : forall α, i α -> ix α]. 68 | - Conversely, we can determine if a primitive of an interface composite [ix] 69 | is forwarded to a concrete interface [i] when there exists a function 70 | [proj_p : forall α, ix α -> option (i a)]. 71 | 72 | We encode this mechanics using two type classes: [MayProvide], and 73 | [Provide]. *) 74 | 75 | Class MayProvide (ix i : interface) : Type := 76 | { proj_p {α} (e : ix α) : option (i α) 77 | }. 78 | 79 | Class Provide (ix i : interface) `{MayProvide ix i} : Type := 80 | { inj_p {α} (e : i α) : ix α 81 | ; proj_inj_p_equ {α} (e : i α) : proj_p (inj_p e) = Some e 82 | }. 83 | 84 | (** We provide a default instance for [MayProvide] in the form of a function 85 | [proj_p] which always return [None]. We give to this default instance a 86 | ridiculously high priority number to ensure it is selected only if no other 87 | instances are found. *) 88 | 89 | Instance default_MayProvide (i j : interface) : MayProvide i j|1000 := 90 | { proj_p := fun _ _ => None 91 | }. 92 | 93 | (** It is expected that, for an interface composite [ix] which provides [i] and 94 | may provide [j], [inj_p] and [proj_p] do not mix up [i] and [j] 95 | primitives. That is, injecting a primitive [e] of [i] inside [ix], then 96 | projecting the resulting primitive into [j] returns [None] as long as [i] 97 | and [j] are two different interfaces. *) 98 | 99 | Class Distinguish (ix i j : interface) `{Provide ix i, MayProvide ix j} : Prop := 100 | { distinguish : forall {α} (e : i α), proj_p (i := j) (inj_p (ix := ix) e) = None 101 | }. 102 | 103 | (** * Composing Interfaces *) 104 | 105 | (** We provide the [iplus] operator to compose interface together. That is, 106 | [iplus] can be used to build _concrete_ (as opposed to polymorphic) 107 | interface composite. *) 108 | 109 | Inductive iplus (i j : interface) (α : Type) := 110 | | in_left (e : i α) : iplus i j α 111 | | in_right (e : j α) : iplus i j α. 112 | 113 | Arguments in_left [i j α] (e). 114 | Arguments in_right [i j α] (e). 115 | 116 | Register iplus as freespec.core.iplus.type. 117 | Register in_left as freespec.core.iplus.in_left. 118 | Register in_right as freespec.core.iplus.in_right. 119 | 120 | Infix "+" := iplus : interface_scope. 121 | 122 | (** For [iplus] to be used seamlessly as a concrete interface composite, we 123 | provide the necessary instances for the [MayProvide], [Provide] and 124 | [Distinguish] type classes. Note that these instances always prefer the 125 | left operand of [iplus]. For instance, considering a situation where 126 | there is an instance for [Provide ix i] and an instance for [Provide jx i], 127 | the instance of [Provide (ix + jx) i] will rely on [ix]. 128 | 129 | The main use case for [iplus] is to locally provide an additional 130 | interface. For instance, we can consider a [with_state] function which would 131 | locally give access to the [STORE] interface, that is [with_state : forall 132 | ix s α, s -> impure (ix + STORE s) α -> impure ix α]. In such a case, the 133 | interface made locally available shall be the right operand of [iplus]. This 134 | way, functions such as [with_state] are reentrant. If we take an example, 135 | the following impure computation: 136 | 137 | << 138 | with_state true (with_state false get) 139 | >> 140 | 141 | will return false (that is, the variable in the inner store). *) 142 | 143 | Instance refl_MayProvide (i : interface) : MayProvide i i := 144 | { proj_p := fun _ e => Some e 145 | }. 146 | 147 | #[program] 148 | Instance refl_Provide (i : interface) : @Provide i i (refl_MayProvide i) := 149 | { inj_p := fun (a : Type) (e : i a) => e 150 | }. 151 | 152 | Instance iplus_left_MayProvide (ix i j : interface) `{MayProvide ix i} 153 | : MayProvide (ix + j) i := 154 | { proj_p := fun _ e => 155 | match e with 156 | | in_left e => proj_p e 157 | | _ => None 158 | end 159 | }. 160 | 161 | #[program] 162 | Instance iplus_left_Provide (ix i j : interface) `{Provide ix i} 163 | : @Provide (ix + j) i (iplus_left_MayProvide ix i j) := 164 | { inj_p := fun (a : Type) (e : i a) => in_left (inj_p e) 165 | }. 166 | 167 | Next Obligation. 168 | now rewrite proj_inj_p_equ. 169 | Qed. 170 | 171 | Instance iplus_right_MayProvide (i jx j : interface) `{MayProvide jx j} 172 | : MayProvide (i + jx) j := 173 | { proj_p := fun _ e => 174 | match e with 175 | | in_right e => proj_p e 176 | | _ => None 177 | end 178 | }. 179 | 180 | #[program] 181 | Instance iplus_right_Provide (i jx j : interface) `{Provide jx j} 182 | : @Provide (i + jx) j (iplus_right_MayProvide i jx j) := 183 | { inj_p := fun _ e => in_right (inj_p e) 184 | }. 185 | 186 | Next Obligation. 187 | now rewrite proj_inj_p_equ. 188 | Qed. 189 | 190 | (** By default, Coq's inference algorithm for type classe instances inference is 191 | a depth-first search. This is not without consequence in our case. For 192 | instance, if we consider the search of an instance for [MayProvide (i + j) 193 | j], Coq will first try [iplus_right_MayProvide] (as explained previously), 194 | meaning he now search for [MayProvide i j]. It turns out such an instance 195 | exists: [default_MayProvide]. 196 | 197 | To circumvent this issue, we write a dedicated tactic [find_may_provide] 198 | which attempts to find an instance for [MayProvide (?ix + ?jx) ?i] with 199 | [refl_MayProvide], [iplus_left_MayProvide] and [iplus_right_MayProvide]. *) 200 | 201 | Ltac find_may_provide := 202 | eapply refl_MayProvide + 203 | (eapply iplus_left_MayProvide; find_may_provide) + 204 | (eapply iplus_right_MayProvide; find_may_provide). 205 | 206 | #[global] Hint Extern 1 (MayProvide (iplus _ _) _) => find_may_provide : typeclass_instances. 207 | 208 | #[program] 209 | Instance refl_Distinguish (i j : interface) 210 | : @Distinguish i i j (@refl_MayProvide i) (@refl_Provide i) (@default_MayProvide i j). 211 | 212 | #[program] 213 | Instance iplus_left_default_Distinguish (ix jx i j : interface) 214 | `{M1 : MayProvide ix i} `{P1 : @Provide ix i M1} 215 | : @Distinguish (ix + jx) i j 216 | (@iplus_left_MayProvide ix i jx M1) 217 | (@iplus_left_Provide ix i jx M1 P1) 218 | (@default_MayProvide _ j). 219 | 220 | #[program] 221 | Instance iplus_right_default_Distinguish (ix jx i j : interface) 222 | `{M1 : MayProvide jx i} `{P1 : @Provide jx i M1} 223 | : @Distinguish (ix + jx) i j 224 | (@iplus_right_MayProvide ix jx i M1) 225 | (@iplus_right_Provide ix jx i M1 P1) 226 | (@default_MayProvide _ j). 227 | 228 | #[program] 229 | Instance iplus_left_may_right_Distinguish (ix jx i j : interface) 230 | `{M1 : MayProvide ix i} `{P1 : @Provide ix i M1} `{M2 : MayProvide jx j} 231 | : @Distinguish (ix + jx) i j 232 | (@iplus_left_MayProvide ix i jx M1) 233 | (@iplus_left_Provide ix i jx M1 P1) 234 | (@iplus_right_MayProvide ix jx j M2). 235 | 236 | #[program] 237 | Instance iplus_right_may_left_Distinguish (ix jx i j : interface) 238 | `{M1 : MayProvide jx i} `{P1 : @Provide jx i M1} `{M2 : MayProvide ix j} 239 | : @Distinguish (ix + jx) i j 240 | (@iplus_right_MayProvide ix jx i M1) 241 | (@iplus_right_Provide ix jx i M1 P1) 242 | (@iplus_left_MayProvide ix j jx M2). 243 | 244 | #[program] 245 | Instance iplus_left_distinguish_left_Distinguish (ix jx i j : interface) 246 | `{M1 : MayProvide ix i} `{P1 : @Provide ix i M1} `{M2 : MayProvide ix j} 247 | `{@Distinguish ix i j M1 P1 M2} 248 | : @Distinguish (ix + jx) i j 249 | (@iplus_left_MayProvide ix i jx M1) 250 | (@iplus_left_Provide ix i jx M1 P1) 251 | (@iplus_left_MayProvide ix j jx M2). 252 | 253 | Next Obligation. 254 | apply distinguish. 255 | Defined. 256 | 257 | #[program] 258 | Instance iplus_right_distinguish_right_Distinguish (ix jx i j : interface) 259 | `{M1 : MayProvide jx i} `{P1 : @Provide jx i M1} `{M2 : MayProvide jx j} 260 | `{@Distinguish jx i j M1 P1 M2} 261 | : @Distinguish (ix + jx) i j 262 | (@iplus_right_MayProvide ix jx i M1) 263 | (@iplus_right_Provide ix jx i M1 P1) 264 | (@iplus_right_MayProvide ix jx j M2). 265 | 266 | Next Obligation. 267 | apply distinguish. 268 | Defined. 269 | -------------------------------------------------------------------------------- /theories/Core/Semantics.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | (** In FreeSpec, there is no particular semantics attach to interface's 8 | primitives. Once an interface has been defined, we can provide one (or 9 | more) operational semantics to interpret its primitives. *) 10 | 11 | (** * Definition *) 12 | 13 | (** An operational [semantics] for the interface [i] is coinductively defined as 14 | a function which can be used to interpret any primitive of [i]; it produces 15 | an [interp_out] term. *) 16 | 17 | From Coq Require Import Program Setoid Morphisms. 18 | From ExtLib Require Import Monad StateMonad. 19 | From FreeSpec.Core Require Export Interface Impure. 20 | 21 | #[local] Open Scope signature_scope. 22 | 23 | CoInductive semantics (i : interface) : Type := 24 | | mk_semantics (f : forall (α : Type), i α -> α * semantics i) : semantics i. 25 | 26 | Arguments mk_semantics [i] (f). 27 | 28 | (** Thus, a [semantics] does not only compute a result for a primitive, but also 29 | provides a new semantics. This is necessary to model impurity: the same 30 | primitive may or may not return the same result when called several 31 | times. 32 | 33 | As for interfaces, the simpler [semantics] is the operational semantics for 34 | [iempty], the empty interface. *) 35 | 36 | Definition iempty_semantics : semantics iempty := 37 | mk_semantics (fun α (e : iempty α) => match e with end). 38 | 39 | (** We also provide a semantics for the [STORE s] interface: *) 40 | 41 | CoFixpoint store {s} (init : s) : semantics (STORE s) := 42 | mk_semantics (fun α (e : STORE s α) => 43 | match e with 44 | | Get => (init, store init) 45 | | Put next => (tt, store next) 46 | end). 47 | 48 | (** We provide several helper functions to interpret primitives with 49 | semantics. *) 50 | 51 | Definition run_effect {i α} (sem : semantics i) (e : i α) : α * semantics i := 52 | match sem with mk_semantics f => f α e end. 53 | 54 | Definition eval_effect {i α} (sem : semantics i) (e : i α) : α := 55 | fst (run_effect sem e). 56 | 57 | Definition exec_effect {i α} (sem : semantics i) (e : i α) : semantics i := 58 | snd (run_effect sem e). 59 | 60 | Lemma run_effect_equation {i α} (sem : semantics i) (e : i α) 61 | : run_effect sem e = (eval_effect sem e, exec_effect sem e). 62 | 63 | Proof. 64 | unfold eval_effect, exec_effect. 65 | destruct run_effect; reflexivity. 66 | Qed. 67 | 68 | (** Besides, and similarly to interfaces, operational semantics can and should 69 | be composed together. To that end, we provide the [semprod] operator. *) 70 | 71 | CoFixpoint semprod {i j} (sem_i : semantics i) (sem_j : semantics j) 72 | : semantics (i + j) := 73 | mk_semantics (fun _ e => 74 | match e with 75 | | in_left e => 76 | let (x, out) := run_effect sem_i e in 77 | (x, semprod out sem_j) 78 | | in_right e => 79 | let (x, out) := run_effect sem_j e in 80 | (x, semprod sem_i out) 81 | end). 82 | 83 | Declare Scope semantics_scope. 84 | Bind Scope semantics_scope with semantics. 85 | Delimit Scope semantics_scope with semantics. 86 | 87 | Infix "*" := semprod : semantics_scope. 88 | 89 | (** * Interpreting Impure Computations *) 90 | 91 | (** A term of type [impure a] describes an impure computation expected to return 92 | a term of type [a]. Interpreting this term means actually realizing the 93 | computation and producing the result. This requires to provide an 94 | operational semantics for the interfaces used by the computation. 95 | 96 | Some operational semantics may be defined in Gallina by means of the 97 | [semantics] type. In such a case, we provide helper functions to use them in 98 | conjunction with [impure] terms. The terminology follows a logic similar to 99 | the Haskell state monad: 100 | 101 | - [run_impure] interprets an impure computation [p] with an operational 102 | semantics [sem], and returns both the result of [p] and the new 103 | operational semantics to use afterwards. 104 | - [eval_impure] only returns the result of [p]. 105 | - [exec_impure] only returns the new operational semantics. *) 106 | 107 | Notation interp i := (state (semantics i)). 108 | 109 | Definition interface_to_state {i} : i ~> interp i := 110 | fun a e => mkState (fun sem => run_effect sem e). 111 | 112 | Definition to_state {i} : impure i ~> state (semantics i) := 113 | impure_lift interface_to_state. 114 | 115 | Arguments to_state {i α} _. 116 | 117 | Definition run_impure {i a} (sem : semantics i) (p : impure i a) : a * semantics i := 118 | runState (to_state p) sem. 119 | 120 | Definition eval_impure {i a} (sem : semantics i) (p : impure i a) : a := 121 | fst (run_impure sem p). 122 | 123 | Definition exec_impure {i a} (sem : semantics i) (p : impure i a) : semantics i := 124 | snd (run_impure sem p). 125 | 126 | (** * In-place Primitives Handling *) 127 | 128 | Fixpoint with_semantics {ix j α} (sem : semantics j) (p : impure (ix + j) α) 129 | : impure ix α := 130 | match p with 131 | | local x => local x 132 | | request_then (in_right e) f => 133 | let (res, next) := run_effect sem e in 134 | with_semantics next (f res) 135 | | request_then (in_left e) f => 136 | request_then e (fun x => with_semantics sem (f x)) 137 | end. 138 | 139 | (** We provide [with_store], a helper function to locally provide a mutable 140 | variable. *) 141 | 142 | Definition with_store {ix s a} (x : s) (p : impure (ix + STORE s) a) 143 | : impure ix a := 144 | with_semantics (store x) p. 145 | 146 | (** Nesting [with_semantics] calls works to some extends. If each 147 | [with_semantics] provides a different interface from the rest of the stack, 148 | then everything behaves as expected. If, for some reason, you end up in a 149 | situation where you provide the exact same interface twice (typically if you 150 | use [with_store]), then the typeclass inferences will favor the deepest one 151 | in the stack. For instance, 152 | 153 | << 154 | Compute (with_store 0 (with_store 1 get)). 155 | >> 156 | 157 | returns 158 | 159 | << 160 | = local 1 161 | : impure ?ix nat 162 | >> *) 163 | -------------------------------------------------------------------------------- /theories/Core/SemanticsFacts.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From ExtLib Require Import StateMonad. 8 | 9 | From FreeSpec.Core Require Import ImpureFacts Contract. 10 | From FreeSpec.Core Require Export Semantics. 11 | 12 | (** * Semantics Compliance *) 13 | 14 | (** Given a semantics [sem], and a witness [ω] if [sem] computes results which 15 | satisfies [c] callee obligations for effects which satisfy [c] caller 16 | obligations and if the resulting semantics produces after interpreting [e] 17 | complies to [c] in accordance to [ω'], where [ω'] is the new witness state 18 | after [e] interpretation then [sem] complies to [c] in accordance to [ω] *) 19 | 20 | CoInductive compliant_semantics `{MayProvide ix i} `(c : contract i Ω) 21 | : Ω -> semantics ix -> Prop := 22 | | compliant_semantics_rec 23 | (sem : semantics ix) (ω : Ω) 24 | (o_callee : forall {α} (e : ix α), 25 | gen_caller_obligation c ω e -> gen_callee_obligation c ω e (eval_effect sem e)) 26 | (next : forall {α} (e : ix α), 27 | gen_caller_obligation c ω e 28 | -> compliant_semantics c (gen_witness_update c ω e (eval_effect sem e)) (exec_effect sem e)) 29 | : compliant_semantics c ω sem. 30 | 31 | (** Proving that semantics obtained from the [store] function are compliant with 32 | [store_specs] is relatively simple. *) 33 | 34 | Lemma store_complies_to_store_specs {s} (st : s) 35 | : compliant_semantics (store_specs s) st (store st). 36 | 37 | Proof. 38 | revert st; cofix compliant_semantics_rec; intros st. 39 | constructor. 40 | + intros a [| st'] _. 41 | ++ now constructor. 42 | ++ now constructor. 43 | + intros a e req. 44 | cbn. 45 | replace (exec_effect (store st) e) 46 | with (store (store_update s st a e (eval_effect (store st) e))) 47 | by now destruct e as [| st']. 48 | apply compliant_semantics_rec. 49 | Qed. 50 | 51 | #[global] Hint Resolve store_complies_to_store_specs : freespec. 52 | 53 | Lemma compliant_semantics_caller_obligation_callee_obligation `{MayProvide ix i} 54 | `(c : contract i Ω) (ω : Ω) 55 | `(e : ix α) (o_caller : gen_caller_obligation c ω e) 56 | (sem : semantics ix) (comp : compliant_semantics c ω sem) 57 | : gen_callee_obligation c ω e (eval_effect sem e). 58 | 59 | Proof. 60 | inversion comp; ssubst. 61 | now apply o_callee. 62 | Qed. 63 | 64 | #[global] Hint Resolve compliant_semantics_caller_obligation_callee_obligation : freespec. 65 | 66 | Lemma compliant_semantics_caller_obligation_compliant `{MayProvide ix i} {Ω α} (c : contract i Ω) (ω : Ω) 67 | (e : ix α) (o_caller : gen_caller_obligation c ω e) 68 | (sem : semantics ix) (comp : compliant_semantics c ω sem) 69 | : compliant_semantics c (gen_witness_update c ω e (eval_effect sem e)) (exec_effect sem e). 70 | 71 | Proof. 72 | inversion comp; ssubst. 73 | now apply next. 74 | Qed. 75 | 76 | #[global] Hint Resolve compliant_semantics_caller_obligation_compliant : freespec. 77 | 78 | Lemma no_contract_compliant_semantics `{MayProvide ix i} (sem : semantics ix) (u : unit) 79 | : compliant_semantics (no_contract i) u sem. 80 | 81 | Proof. 82 | revert sem. 83 | cofix no_contract_compliant_semantics; intros sem. 84 | constructor. 85 | + intros α e req. 86 | unfold gen_caller_obligation, gen_callee_obligation. 87 | destruct proj_p; constructor. 88 | + intros α e req. 89 | unfold gen_witness_update. 90 | destruct (proj_p e); [ apply no_contract_compliant_semantics | auto with freespec ]. 91 | Qed. 92 | 93 | #[global] Hint Resolve no_contract_compliant_semantics : freespec. 94 | 95 | (** * Equivalences *) 96 | 97 | (** ** Semantics *) 98 | 99 | (** We say two semantics are equivalent when they produce equivalent outputs 100 | given the same primitive. *) 101 | 102 | CoInductive semantics_eq {i} : semantics i -> semantics i -> Prop := 103 | | semantics_eq_rec 104 | (sem sem' : semantics i) 105 | (res_eq : forall {a} (e : i a), eval_effect sem e = eval_effect sem' e) 106 | (next_eq : forall {a} (e : i a), 107 | semantics_eq (exec_effect sem e) (exec_effect sem' e)) 108 | : semantics_eq sem sem'. 109 | 110 | Infix "===" := semantics_eq : semantics_scope. 111 | 112 | (** We prove [semantics_eq] is indeed an equivalence. *) 113 | 114 | #[program] 115 | Instance semantics_Equivalence (i : interface) : Equivalence (@semantics_eq i). 116 | 117 | Next Obligation. 118 | cofix semantics_eq_refl. 119 | intros sem. 120 | constructor; intros α e. 121 | + reflexivity. 122 | + apply semantics_eq_refl. 123 | Qed. 124 | 125 | Next Obligation. 126 | cofix semantics_eq_sym. 127 | intros sem sem' equiv. 128 | destruct equiv as [sem sem' step]. 129 | constructor; intros α e. 130 | + now symmetry. 131 | + now apply semantics_eq_sym. 132 | Qed. 133 | 134 | Next Obligation. 135 | cofix semantics_eq_trans. 136 | intros sem sem' sem'' equiv equiv'. 137 | destruct equiv as [sem sem' equ]. 138 | destruct equiv' as [sem' sem'' equ']. 139 | constructor; intros α e; 140 | specialize equ with α e; 141 | specialize equ' with α e; 142 | inversion equ; ssubst; 143 | inversion equ'; ssubst. 144 | + now transitivity (eval_effect sem' e). 145 | + eapply semantics_eq_trans; [ apply next_eq | apply next_eq0 ]. 146 | Qed. 147 | 148 | (** ** Interpretation Results *) 149 | 150 | Definition run_effect_eq `(x : α * semantics i) (y : α * semantics i) : Prop := 151 | fst x = fst y /\ (snd x === snd y)%semantics. 152 | 153 | #[program] 154 | Instance run_effect_Equivalence a i 155 | : @Equivalence (a * semantics i) run_effect_eq. 156 | 157 | Next Obligation. 158 | intros [x next]; now split. 159 | Qed. 160 | 161 | Next Obligation. 162 | intros [x next] [y next'] [H1 H2]; now split. 163 | Qed. 164 | 165 | Next Obligation. 166 | intros [x next] [y next'] [z next_] [H1 H2] [H3 H4]. 167 | split; etransitivity; eauto. 168 | Qed. 169 | 170 | (** ** Proper Instances *) 171 | 172 | #[program] 173 | Instance fst_Proper i α 174 | : Proper (run_effect_eq ==> eq) (@fst α (semantics i)). 175 | 176 | Next Obligation. 177 | add_morphism_tactic. 178 | intros [x next] [y next'] [equ1 equ2]. 179 | apply equ1. 180 | Qed. 181 | 182 | #[program] 183 | Instance snd_Proper i α 184 | : Proper (run_effect_eq ==> semantics_eq) (@snd α (semantics i)). 185 | 186 | Next Obligation. 187 | add_morphism_tactic. 188 | intros [x next] [y next'] [equ1 equ2]. 189 | apply equ2. 190 | Qed. 191 | 192 | #[program] 193 | Instance prod_Proper i α 194 | : Proper (eq ==> semantics_eq ==> run_effect_eq) (@pair α (semantics i)). 195 | 196 | Next Obligation. 197 | add_morphism_tactic. 198 | intros x sem sem' equ. 199 | split. 200 | + reflexivity. 201 | + apply equ. 202 | Qed. 203 | 204 | Instance run_effect_Proper i α 205 | : Proper (semantics_eq ==> eq ==> run_effect_eq) (@run_effect i α). 206 | 207 | Proof. 208 | add_morphism_tactic. 209 | intros sem sem' equ e. 210 | rewrite run_effect_equation. 211 | inversion equ; subst. 212 | split. 213 | + apply res_eq. 214 | + apply next_eq. 215 | Qed. 216 | 217 | #[program] 218 | Instance eval_effect_Proper i α 219 | : Proper (semantics_eq ==> eq ==> eq) (@eval_effect i α). 220 | 221 | Next Obligation. 222 | add_morphism_tactic. 223 | intros o o' equ e. 224 | unfold eval_effect. 225 | now rewrite equ. 226 | Qed. 227 | 228 | #[program] 229 | Instance exec_effect_Proper i α 230 | : Proper (semantics_eq ==> eq ==> semantics_eq) (@exec_effect i α). 231 | 232 | Next Obligation. 233 | add_morphism_tactic. 234 | intros o o' equ e. 235 | unfold exec_effect. 236 | now rewrite equ. 237 | Qed. 238 | 239 | #[local] 240 | Remark eval_semprod_in_left_eq `(semi : semantics i) `(semj : semantics j) `(e : i α) 241 | : eval_effect (semi * semj) (in_left e) = eval_effect semi e. 242 | 243 | Proof. 244 | unfold eval_effect; cbn. 245 | destruct semi as [semi]. 246 | cbn. 247 | now destruct (semi α e). 248 | Qed. 249 | 250 | #[local] 251 | Remark eval_semprod_in_right_eq `(semi : semantics i) `(semj : semantics j) `(e : j α) 252 | : eval_effect (semi * semj) (in_right e) = eval_effect semj e. 253 | 254 | Proof. 255 | unfold eval_effect; cbn. 256 | destruct semj as [semj]. 257 | cbn. 258 | now destruct (semj α e). 259 | Qed. 260 | 261 | #[local] 262 | Remark exec_semprod_in_left_eq `(semi : semantics i) `(semj : semantics j) `(e : i α) 263 | : exec_effect (semi * semj) (in_left e) = (semprod (exec_effect semi e) semj). 264 | 265 | Proof. 266 | unfold exec_effect; cbn. 267 | destruct semi as [semi]. 268 | cbn. 269 | now destruct (semi _ e). 270 | Qed. 271 | 272 | #[local] 273 | Remark exec_semprod_in_right_eq `(semi : semantics i) `(semj : semantics j) `(e : j α) 274 | : exec_effect (semi * semj) (in_right e) = (semprod semi (exec_effect semj e)). 275 | 276 | Proof. 277 | unfold exec_effect; cbn. 278 | destruct semj as [semj]. 279 | cbn. 280 | now destruct (semj _ e). 281 | Qed. 282 | 283 | #[program] 284 | Instance semprod_Proper i j 285 | : Proper (semantics_eq ==> semantics_eq ==> semantics_eq) (@semprod i j). 286 | 287 | Next Obligation. 288 | add_morphism_tactic. 289 | cofix semprod_Proper. 290 | intros semi semi' equi semj semj' equj. 291 | constructor; intros α e; destruct e. 292 | + repeat rewrite eval_semprod_in_left_eq. 293 | now inversion equi. 294 | + repeat rewrite eval_semprod_in_right_eq. 295 | now inversion equj. 296 | + repeat rewrite exec_semprod_in_left_eq. 297 | apply semprod_Proper; auto. 298 | inversion equi. 299 | apply next_eq. 300 | + repeat rewrite exec_semprod_in_right_eq. 301 | apply semprod_Proper; auto. 302 | inversion equj. 303 | apply next_eq. 304 | Qed. 305 | 306 | #[program] 307 | Instance compliant_semantics_Proper `{MayProvide ix i} `(c : contract i Ω) 308 | : Proper (eq ==> semantics_eq ==> Basics.impl) (compliant_semantics c). 309 | 310 | Next Obligation. 311 | add_morphism_tactic. 312 | unfold Basics.impl. 313 | cofix proper. 314 | intros ω sem sem' equ comp. 315 | inversion equ; subst. 316 | inversion comp; subst. 317 | constructor; intros a e pre. 318 | + rewrite <- res_eq. 319 | now apply o_callee. 320 | + specialize next_eq with a e. 321 | eapply proper. 322 | exact next_eq. 323 | rewrite <- res_eq. 324 | now apply next. 325 | Qed. 326 | 327 | (** * General Lemmas *) 328 | 329 | (** We provide several lemmas and the necessary [Proper] instances to use these 330 | functions in conjunction with [semantics_equiv] and [impure_equiv]. *) 331 | 332 | Lemma run_impure_equation {i a} (sem : semantics i) (p : impure i a) 333 | : run_impure sem p = (eval_impure sem p, exec_impure sem p). 334 | 335 | Proof. 336 | unfold eval_impure, exec_impure. 337 | destruct run_impure; reflexivity. 338 | Qed. 339 | 340 | Lemma run_impure_request_then_assoc {i a b} 341 | (sem : semantics i) (e : i a) (f : a -> impure i b) 342 | : run_impure sem (request_then e f) 343 | = run_impure (exec_effect sem e) (f (eval_effect sem e)). 344 | 345 | Proof. 346 | cbn; now rewrite run_effect_equation. 347 | Qed. 348 | 349 | Lemma eval_impure_request_then_assoc {i a b} 350 | (sem : semantics i) (e : i a) (f : a -> impure i b) 351 | : eval_impure sem (request_then e f) 352 | = eval_impure (exec_effect sem e) (f (eval_effect sem e)). 353 | 354 | Proof. 355 | unfold eval_impure. 356 | now rewrite run_impure_request_then_assoc. 357 | Qed. 358 | 359 | Lemma exec_impure_request_then_assoc {i a b} 360 | (sem : semantics i) (e : i a) (f : a -> impure i b) 361 | : exec_impure sem (request_then e f) 362 | = exec_impure (exec_effect sem e) (f (eval_effect sem e)). 363 | 364 | Proof. 365 | unfold exec_impure. 366 | now rewrite run_impure_request_then_assoc. 367 | Qed. 368 | 369 | Lemma run_impure_bind_assoc {i a b} 370 | (sem : semantics i) (p : impure i a) (f : a -> impure i b) 371 | : run_impure sem (p >>= f) 372 | = run_impure (exec_impure sem p) (f (eval_impure sem p)). 373 | 374 | Proof. 375 | revert sem f. 376 | induction p; intros sem g. 377 | + reflexivity. 378 | + rewrite bind_request_then_assoc. 379 | rewrite run_impure_request_then_assoc. 380 | rewrite H. 381 | rewrite exec_impure_request_then_assoc. 382 | rewrite eval_impure_request_then_assoc. 383 | reflexivity. 384 | Qed. 385 | 386 | Lemma eval_impure_bind_assoc {i a b} 387 | (sem : semantics i) (p : impure i a) (f : a -> impure i b) 388 | : eval_impure sem (p >>= f) 389 | = eval_impure (exec_impure sem p) (f (eval_impure sem p)). 390 | 391 | Proof. 392 | unfold eval_impure. 393 | now rewrite run_impure_bind_assoc. 394 | Qed. 395 | 396 | Lemma exec_impure_bind_assoc {i a b} 397 | (sem : semantics i) (p : impure i a) (f : a -> impure i b) 398 | : exec_impure sem (p >>= f) 399 | = exec_impure (exec_impure sem p) (f (eval_impure sem p)). 400 | 401 | Proof. 402 | unfold exec_impure. 403 | now rewrite run_impure_bind_assoc. 404 | Qed. 405 | 406 | #[program] 407 | Instance run_impure_Proper_1 (i : interface) (a : Type) 408 | : Proper (semantics_eq ==> eq ==> run_effect_eq) (@run_impure i a). 409 | 410 | Next Obligation. 411 | add_morphism_tactic. 412 | intros sem sem' equ p. 413 | revert sem sem' equ. 414 | induction p; intros sem sem' equ. 415 | + cbn. 416 | now rewrite equ. 417 | + repeat rewrite eval_impure_request_then_assoc. 418 | repeat rewrite run_impure_request_then_assoc. 419 | specialize H 420 | with (eval_effect sem e) (exec_effect sem e) (exec_effect sem' e). 421 | inversion equ; subst. 422 | specialize next_eq with _ e. 423 | apply H in next_eq. 424 | rewrite <- res_eq. 425 | exact next_eq. 426 | Qed. 427 | 428 | #[program] 429 | Instance run_impure_Proper_2 (i : interface) (a : Type) 430 | : Proper (eq ==> impure_eq ==> run_effect_eq) (@run_impure i a). 431 | 432 | Next Obligation. 433 | add_morphism_tactic. 434 | intros sem p q equ. 435 | revert sem. 436 | induction equ; intros sem. 437 | + reflexivity. 438 | + repeat rewrite run_impure_request_then_assoc. 439 | apply H. 440 | Qed. 441 | 442 | #[program] 443 | Instance eval_impure_Proper (i : interface) (a : Type) 444 | : Proper (semantics_eq ==> impure_eq ==> eq) (@eval_impure i a). 445 | 446 | Next Obligation. 447 | add_morphism_tactic. 448 | intros sem sem' equ1 p q equ2. 449 | unfold eval_impure. 450 | now rewrite equ1, equ2. 451 | Qed. 452 | 453 | #[program] 454 | Instance exec_impure_Proper (i : interface) (a : Type) 455 | : Proper (semantics_eq ==> impure_eq ==> semantics_eq) (@exec_impure i a). 456 | 457 | Next Obligation. 458 | add_morphism_tactic. 459 | intros sem sem' equ1 p q equ2. 460 | unfold exec_impure. 461 | now rewrite equ1, equ2. 462 | Qed. 463 | -------------------------------------------------------------------------------- /theories/Core/Tactics.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From ExtLib Require Import Monad. 8 | From FreeSpec.Core Require Import Contract ImpureFacts HoareFacts. 9 | 10 | Ltac destruct_if_when := 11 | let equ_cond := fresh "equ_cond" in 12 | match goal with 13 | | |- context[when (negb ?B) _] => case_eq B; intros equ_cond; cbn 14 | | |- context[when ?B _] => case_eq B; intros equ_cond; cbn 15 | | |- context[if (negb ?B) then _ else _] => case_eq B; intros equ_cond; cbn 16 | | |- context[if ?B then _ else _] => case_eq B; intros equ_cond; cbn 17 | | _ => idtac 18 | end. 19 | 20 | Ltac destruct_if_when_in hyp := 21 | let equ_cond := fresh "equ" in 22 | match type of hyp with 23 | | context[when (negb ?B) _] => case_eq B; 24 | intro equ_cond; 25 | rewrite equ_cond in hyp 26 | | context[when ?B _] => case_eq B; 27 | intro equ_cond; 28 | rewrite equ_cond in hyp 29 | | context[if (negb ?B) then _ else _] => case_eq B; 30 | intro equ_cond; 31 | rewrite equ_cond in hyp 32 | | context[if ?B then _ else _] => case_eq B; 33 | intro equ_cond; 34 | rewrite equ_cond in hyp 35 | | _ => idtac 36 | end. 37 | 38 | Ltac simplify_gens := 39 | repeat match goal with 40 | | H : True |- _ => 41 | clear H 42 | 43 | | H: _ /\ _ |- _ => 44 | destruct H 45 | 46 | | |- context[@proj_p ?ix ?ix (refl_MayProvide ?ix) _ ?e] => 47 | change (@proj_p ix ix (refl_MayProvide ix) _ e) with (Some e); 48 | cbn match; 49 | cbn beta 50 | 51 | | H: context[@proj_p ?ix ?ix (refl_MayProvide ?ix) _ ?e] |- _ => 52 | change (@proj_p ix ix (refl_MayProvide ix) _ e) with (Some e) in H; 53 | cbn match in H; 54 | cbn beta in H 55 | 56 | | |- context[gen_witness_update _ _ _ _] => 57 | unfold gen_witness_update; 58 | repeat (rewrite proj_inj_p_equ || rewrite distinguish) 59 | 60 | | H : context[gen_witness_update _ _ _ _] |- _ => 61 | unfold gen_witness_update in H; 62 | repeat (rewrite proj_inj_p_equ in H || rewrite distinguish in H) 63 | 64 | | |- context[gen_caller_obligation ?c ?ω ?e] => 65 | unfold gen_caller_obligation; 66 | repeat (rewrite proj_inj_p_equ || rewrite distinguish) 67 | 68 | | H : context[gen_caller_obligation ?c ?ω ?e] |- _ => 69 | unfold gen_caller_obligation in H; 70 | repeat (rewrite proj_inj_p_equ in H || rewrite distinguish in H) 71 | 72 | | |- context[gen_callee_obligation ?c ?ω ?e ?x] => 73 | unfold gen_callee_obligation; 74 | repeat (rewrite proj_inj_p_equ || rewrite distinguish) 75 | 76 | | H : context[gen_callee_obligation ?c ?ω ?e ?x] |- _ => 77 | unfold gen_callee_obligation in H; 78 | repeat (rewrite proj_inj_p_equ in H || rewrite distinguish in H) 79 | end. 80 | 81 | #[local] 82 | Ltac prove_impure := 83 | repeat (cbn -[ 84 | to_hoare 85 | gen_caller_obligation 86 | gen_callee_obligation 87 | gen_witness_update 88 | ] in *; 89 | simplify_gens; 90 | destruct_if_when); 91 | lazymatch goal with 92 | 93 | | |- _ /\ _ => 94 | split; 95 | prove_impure 96 | 97 | | |- pre (to_hoare ?c (impure_map ?f ?p)) ?ω => 98 | unfold impure_map; 99 | prove_impure 100 | 101 | | |- pre (to_hoare ?c (impure_apply ?p ?q)) ?ω => 102 | unfold impure_map; 103 | prove_impure 104 | 105 | | |- forall _ _, _ /\ _ = _ -> _ => 106 | let x := fresh "x" in 107 | let ω' := fresh "ω" in 108 | let o_caller := fresh "o_caller" in 109 | let equ := fresh "equ" in 110 | intros x ω' [o_caller equ]; 111 | repeat rewrite equ in *; clear equ; clear ω'; 112 | prove_impure 113 | 114 | | |- pre (to_hoare ?c ?p) ?ω => 115 | let p := (eval hnf in p) in 116 | lazymatch p with 117 | | request_then ?e ?f => 118 | let o_caller := fresh "o_caller" in 119 | assert (o_caller : gen_caller_obligation c ω e); [ prove_impure 120 | | constructor; prove_impure 121 | ] 122 | | local _ => constructor 123 | | impure_bind (impure_bind ?p ?f) ?g => 124 | rewrite (impure_bind_assoc p f g); 125 | prove_impure 126 | | impure_bind ?p ?f => 127 | apply to_hoare_pre_bind_assoc; [ eauto with freespec 128 | | let x := fresh "x" in 129 | let ω' := fresh "ω" in 130 | let hpost := fresh "hpost" in 131 | intros x ω' hpost; 132 | prove_impure 133 | ] 134 | 135 | | _ => eauto with freespec 136 | end 137 | 138 | | |- ?a => 139 | eauto with freespec 140 | 141 | end. 142 | 143 | Tactic Notation "prove" "impure" := prove_impure. 144 | Tactic Notation "prove" "impure" "with" ident(db) := prove_impure; eauto with db. 145 | 146 | Ltac unroll_post run := 147 | repeat (cbn -[ 148 | to_hoare 149 | gen_caller_obligation 150 | gen_callee_obligation 151 | gen_witness_update 152 | ] in *; 153 | simplify_gens; 154 | destruct_if_when_in run); 155 | lazymatch type of run with 156 | 157 | | post (to_hoare ?c ?p) ?ω ?x ?ω' => 158 | let p := (eval hnf in p) in 159 | lazymatch p with 160 | | request_then ?e ?f => 161 | inversion run; ssubst; 162 | clear run; 163 | lazymatch goal with 164 | | next : exists _, post (interface_to_hoare c _ e) _ _ _ /\ _ |- _ => 165 | let ω'' := fresh "ω" in 166 | let o_callee := fresh "o_callee" in 167 | let run := fresh "run" in 168 | destruct next as [ω'' [o_callee run]]; 169 | unroll_post run 170 | | _ => idtac 171 | end 172 | 173 | | local ?x => 174 | inversion run; ssubst; 175 | clear run 176 | 177 | | impure_bind ?p ?f => 178 | apply (to_hoare_post_bind_assoc c p f) in run; 179 | let run1 := fresh "run" in 180 | let run2 := fresh "run" in 181 | let x := fresh "x" in 182 | let ω := fresh "ω" in 183 | destruct run as [x [ω [run1 run2]]]; 184 | unroll_post run1; unroll_post run2 185 | 186 | | ?a => idtac 187 | end 188 | 189 | | ?a => idtac 190 | end. 191 | -------------------------------------------------------------------------------- /theories/Core/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name gen_type_classes)) 3 | 4 | (rule (with-stdout-to Typeclasses.v (run ./gen_type_classes.exe))) 5 | 6 | (coq.theory 7 | (name FreeSpec.Core) 8 | (package coq-freespec-core) 9 | (flags -init-file ../../build.v)) -------------------------------------------------------------------------------- /theories/Core/gen_type_classes.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | 3 | (* We arbitrarily fix a upper bound for the number of generated 4 | [ProvideN] and [StrictProvideN] typeclasses. Ideally, we would 5 | like to come up with a setup where this is no longer needed, e.g., 6 | with a typeclass hierarchy that could scale with any number of 7 | interfaces, but we failed to come up with a satisfying alternative. 8 | There is nothing that prevent us from incrementing this value if 9 | there is a good use cas that needs it, but the greater the constant 10 | is, the longer it takes to compile the generated file. *) 11 | let max_interfaces = 15 12 | 13 | (** [x -- y] computes [[x; x+1; ...; y-1; y]] *) 14 | let rec ( -- ) x y = if x < y then x :: (x + 1 -- y) else [ y ] 15 | 16 | (** [x --- y] computes [[(x,x+1); ...; (x,y-1); (x,y); (x+1; x+2); 17 | ... (y-1, y)]] *) 18 | let ( --- ) x y = 19 | let ln = x -- y in 20 | let rec row x = function 21 | | y :: rst when x <> y -> (x, y) :: row x rst 22 | | _ :: rst -> row x rst 23 | | [] -> [] 24 | in 25 | List.concat_map (fun x -> row x ln) ln 26 | 27 | let prelude = "From FreeSpec.Core Require Import Interface." 28 | 29 | let pp_interfaces = 30 | pp_print_list 31 | ~pp_sep:(fun fmt () -> pp_print_string fmt " ") 32 | (fun fmt i -> fprintf fmt "i%d" i) 33 | 34 | let pp_provide_args = 35 | pp_print_list 36 | ~pp_sep:(fun fmt () -> pp_print_string fmt ", ") 37 | (fun fmt i -> fprintf fmt "Provide ix i%d" i) 38 | 39 | let pp_provide_n fmt n = 40 | fprintf fmt 41 | "Class Provide%d ix %a `{%a}.@ @ #[global] Hint Resolve Build_Provide%d : \ 42 | typeclass_instances." 43 | n pp_interfaces (1 -- n) pp_provide_args (1 -- n) n 44 | 45 | let pp_distinguish_args = 46 | pp_print_list 47 | ~pp_sep:(fun fmt () -> pp_print_string fmt ", ") 48 | (fun fmt (x, y) -> fprintf fmt "! Distinguish ix i%d i%d" x y) 49 | 50 | let pp_strict_provide_n fmt n = 51 | fprintf fmt 52 | "Class StrictProvide%d ix %a `{%a, %a}.@ @ #[global] Hint Resolve \ 53 | Build_StrictProvide%d : typeclass_instances." 54 | n pp_interfaces (1 -- n) pp_provide_args (1 -- n) pp_distinguish_args 55 | (1 --- n) n 56 | 57 | let () = 58 | printf "@["; 59 | printf "%s@ @ " prelude; 60 | printf "%a@ @ " 61 | (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ @ ") pp_provide_n) 62 | (1 -- max_interfaces); 63 | printf "%a" 64 | (pp_print_list 65 | ~pp_sep:(fun fmt () -> fprintf fmt "@ @ ") 66 | pp_strict_provide_n) 67 | (2 -- max_interfaces); 68 | printf "@]" 69 | -------------------------------------------------------------------------------- /theories/Exec/Eval.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From FreeSpec Require Import Core. 8 | 9 | Inductive EVAL (a : Type) : Type := 10 | | Eval (x : a) : EVAL a. 11 | 12 | Arguments Eval [a] (x). 13 | 14 | Definition eval `{Provide ix EVAL} {a} (x : a) : impure ix a := 15 | request (Eval x). 16 | 17 | Register EVAL as freespec.exec.eval.type. 18 | Register Eval as freespec.exec.eval.Eval. 19 | -------------------------------------------------------------------------------- /theories/Exec/Exec.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From FreeSpec.Core Require Export Core. 8 | 9 | (** This module loads a Coq plugin which provides the [Exec] 10 | vernacular command. [Exec] is analogous to [Compute], but works 11 | with [impure] terms. [Exec] uses the Coq reduction engine to make 12 | the head constructor of the term provided as argument for [Exec] 13 | appears. Then, in presence of the [request_then] constructor, it 14 | uses handler functions provided by FreeSpec users to perform the 15 | impure tasks and compute a result. This result is passed to the 16 | continuation, and the [Exec] interpreter is recursively 17 | called. When the constructor is [local], the computation is 18 | completed. 19 | 20 | By default, [Exec] uses a reduction strategy analogous to 21 | [cbn]. It also accepts the <> attribute to change this 22 | behavior, and prefers an approach analogous to 23 | <>. Changing the reduction strategy can be handy in 24 | presence of a term which takes a very long time to reduce with 25 | <>. This is typically the case with terms that relies on 26 | well-founded recursion rather than structural recursion. *) 27 | 28 | From CoqFFI Require Import Int. 29 | 30 | (* Import necessary types. *) 31 | 32 | From FreeSpec.Exec Require Import Eval. 33 | From FreeSpec.FFI Require Import FFI Refs ML. 34 | 35 | From Coq Require Import String Ascii Byte. 36 | 37 | (** * Extending FreeSpec.Exec *) 38 | 39 | (** The FreeSpec.Exec plugin has been designed to be extensible, meaning it 40 | shall be easy for FreeSpec users to provide handlers for their own 41 | interfaces. 42 | 43 | In FreeSpec, primitives are modeled with Coq constructors of an [interface] 44 | inductive type. FreeSpec.Exec allows to define so-called 45 | <> for these constructors which aim to compute the 46 | related primitive results. 47 | 48 | The OCaml type <> is defined as follows: 49 | 50 | << 51 | type effectful_semantic = 52 | Constr.constr list -> Constr.constr 53 | >> 54 | 55 | If you are not familiar with Coq internals, <> is the 56 | representation of Coq terms. Therefore, an <> is an 57 | OCaml function which maps a list of Coq terms (the arguments of the 58 | primitives) to its result. 59 | 60 | For instance, if we consider the following interface: 61 | 62 | << 63 | Inductive CONSOLE : interface := 64 | | WriteLine : string -> CONSOLE unit 65 | | ReadLine : CONSOLE string. 66 | >> 67 | 68 | Since <>, it is required to manually register both the type of an 69 | interface and its constructors for plugins to easily interact with them. This is done 70 | with the [Register] command. 71 | 72 | << 73 | Register . 74 | >> 75 | 76 | The <> plugin expects the unique ID to be of the form <<. >>for contructors and <<.type>> for the type. In 78 | the case of the <> interface, we could use: 79 | 80 | << 81 | Register CONSOLE freespec.exec.console.type. 82 | Register WriteLine freespec.exec.console.WriteLine. 83 | Register ReadLine freespec.exec.console.ReadLine. 84 | >> 85 | 86 | Then, one can implement two <>: one for the constructor 87 | <> and the other for the constructor <>: 88 | 89 | << 90 | let writeline = function 91 | | [str] -> print_bytes (bytes_of_coqstr str); 92 | coqtt 93 | | _ -> assert false 94 | 95 | let readline = function 96 | | [] -> string_to_coqstr (read_line ()) 97 | | _ -> assert false 98 | >> 99 | 100 | There are several facts to explain. 101 | 102 | First, manipulating <> value manually shall not be required 103 | most of the time, since the FreeSpec.Exec plugin provides several helpers 104 | isomorphisms to turn Coq term into OCaml values and vice-versa. 105 | Hence, <> translates a [string] term into a [bytes] value, 106 | while <> translates a OCaml [string] value into a Coq 107 | [string] term. 108 | 109 | Secondly, it is the responsibility of plugin developers to ensure they 110 | consider the right number of arguments for their <>. The 111 | <> constructor has one argument, so the <> OCaml 112 | function only considers one-element lists. The <> constructor has 113 | no argument, so the <> OCaml function only handles the empty list. 114 | 115 | Thirdly, it is also the responsibility of plugin developers to forge a 116 | well-typed result for their primitives. 117 | 118 | Once the <> have been defined, they need to be 119 | registered to FreeSpec.Exec, so that the plugin effectively use them. The 120 | <> OCaml module of FreeSpec.Exec provides a function to that hand: 121 | 122 | << 123 | val register_interface : 124 | (* The base path we have chosen to register our interface. *) 125 | string 126 | (* A list to map each constructor of this interface 127 | to an effectful semantic. *) 128 | -> (string * effectful_semantic) list 129 | -> unit 130 | >> 131 | 132 | It shall be used as follows: 133 | 134 | << 135 | let _ = 136 | register_interface 137 | "freespec.exec.console" 138 | [("WriteLine", writeline); ("ReadLine", readline)] 139 | >> *) 140 | 141 | (* TODO: this shall be in the standard library of Coq *) 142 | Register byte as coq.byte.type. 143 | (* end TODO *) 144 | 145 | Register REFS as freespec.ffi.REFS.type. 146 | Register Make_ref as freespec.ffi.REFS.Make_ref. 147 | Register Assign as freespec.ffi.REFS.Assign. 148 | Register Deref as freespec.ffi.REFS.Deref. 149 | 150 | Declare ML Module "freespec_exec". 151 | -------------------------------------------------------------------------------- /theories/Exec/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name FreeSpec.Exec) 3 | (package coq-freespec-exec) 4 | (theories FreeSpec.Core FreeSpec.FFI) 5 | (libraries coq-freespec-exec.plugin) 6 | (flags -init-file ../../build.v)) -------------------------------------------------------------------------------- /theories/FFI/FFI.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | From FreeSpec Require Import Core Extraction. 8 | From CoqFFI Require Import Interface. 9 | 10 | Instance FreeSpec_Inject `(H : Provide ix i) : Inject i (impure ix) := 11 | { inject := @request ix i _ H }. 12 | -------------------------------------------------------------------------------- /theories/FFI/FreeSpecFFI.mlpack: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lthms/FreeSpec/d4e2f3a3fc7e82effddca202a8b0210dbbcf3663/theories/FFI/FreeSpecFFI.mlpack -------------------------------------------------------------------------------- /theories/FFI/ML.v: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | Declare ML Module "FreeSpecFFI". 8 | -------------------------------------------------------------------------------- /theories/FFI/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FreeSpecFFI) 3 | (public_name coq-freespec-ffi.lib)) 4 | 5 | (rule 6 | (target Refs.v) 7 | (action (run coqffi -finterface %{cmi:refs} -o %{target}))) 8 | 9 | (coq.theory 10 | (name FreeSpec.FFI) 11 | (package coq-freespec-ffi) 12 | (theories FreeSpec.Core) 13 | (libraries coq-freespec-ffi.lib) 14 | (flags -init-file ../../build.v)) -------------------------------------------------------------------------------- /theories/FFI/refs.ml: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | type 'a reference = 'a ref 8 | 9 | let make_ref = ref 10 | let deref = (!) 11 | let assign = (:=) 12 | -------------------------------------------------------------------------------- /theories/FFI/refs.mli: -------------------------------------------------------------------------------- 1 | (* This Source Code Form is subject to the terms of the Mozilla Public 2 | * License, v. 2.0. If a copy of the MPL was not distributed with this 3 | * file, You can obtain one at https://mozilla.org/MPL/2.0/. *) 4 | 5 | (* Copyright (C) 2018–2020 ANSSI *) 6 | 7 | type 'a reference = 'a ref 8 | 9 | val make_ref : 'a -> 'a reference [@@impure] 10 | val deref : 'a reference -> 'a [@@impure] 11 | val assign : 'a reference -> 'a -> unit [@@impure] 12 | --------------------------------------------------------------------------------