├── .github └── workflows │ └── docker-action.yml ├── .gitignore ├── CoqMakefile.local ├── LICENSE ├── Makefile ├── README.md ├── _CoqProject ├── coq-bits.opam ├── dune-project ├── meta.yml ├── src ├── bits.v ├── dune ├── extraction │ ├── axioms16.v │ ├── axioms32.v │ ├── axioms8.v │ ├── forall.ml │ ├── magic.patch │ └── verif.sh ├── spec │ ├── operations.v │ ├── operations │ │ └── properties.v │ ├── spec.v │ └── spec │ │ └── properties.v └── ssrextra │ ├── nat.v │ └── tuple.v └── test ├── Makefile ├── _CoqProject ├── benchmark.v └── integers.v /.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 | - master 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 | - 'mathcomp/mathcomp:2.0.0-coq-8.16' 21 | - 'mathcomp/mathcomp:2.0.0-coq-8.18' 22 | - 'mathcomp/mathcomp:2.1.0-coq-8.16' 23 | - 'mathcomp/mathcomp:2.1.0-coq-8.18' 24 | - 'mathcomp/mathcomp:2.2.0-coq-8.16' 25 | - 'mathcomp/mathcomp:2.2.0-coq-8.19' 26 | - 'mathcomp/mathcomp:2.2.0-coq-dev' 27 | - 'mathcomp/mathcomp-dev:coq-8.19' 28 | - 'mathcomp/mathcomp-dev:coq-dev' 29 | fail-fast: false 30 | steps: 31 | - uses: actions/checkout@v3 32 | - uses: coq-community/docker-coq-action@v1 33 | with: 34 | opam_file: 'coq-bits.opam' 35 | custom_image: ${{ matrix.image }} 36 | 37 | 38 | # See also: 39 | # https://github.com/coq-community/docker-coq-action#readme 40 | # https://github.com/erikmd/docker-coq-github-action-demo 41 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # * Opam 2 | opam/ 3 | 4 | # * Coq 5 | *.vo 6 | *.vos 7 | *.vok 8 | *.glob 9 | *.v.d 10 | *.aux 11 | CoqMakefile 12 | CoqMakefile.conf 13 | .CoqMakefile.d 14 | .coqdeps.d 15 | 16 | # * Coq Extraction 17 | src/extraction/axioms16.ml 18 | src/extraction/axioms16.mli 19 | src/extraction/axioms32.ml 20 | src/extraction/axioms32.mli 21 | src/extraction/axioms8.ml 22 | src/extraction/axioms8.mli 23 | 24 | # * Emacs 25 | *~ 26 | 27 | # * OCaml 28 | *.annot 29 | *.cmo 30 | *.cma 31 | *.cmi 32 | *.a 33 | *.o 34 | *.cmx 35 | *.cmxs 36 | *.cmxa 37 | 38 | # ocamlbuild working directory 39 | _build/ 40 | 41 | # ocamlbuild targets 42 | *.byte 43 | *.native 44 | 45 | # oasis generated files 46 | setup.data 47 | setup.log 48 | 49 | -------------------------------------------------------------------------------- /CoqMakefile.local: -------------------------------------------------------------------------------- 1 | verify: all 2 | src/extraction/verif.sh 3 | 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # KNOWNTARGETS will not be passed along to CoqMakefile 2 | KNOWNTARGETS := CoqMakefile 3 | # KNOWNFILES will not get implicit targets from the final rule, and so depending on them won’t invoke the submake 4 | # Warning: These files get declared as PHONY, so any targets depending on them always get rebuilt 5 | KNOWNFILES := Makefile _CoqProject 6 | 7 | .DEFAULT_GOAL := invoke-coqmakefile 8 | 9 | CoqMakefile: Makefile _CoqProject 10 | $(COQBIN)coq_makefile -f _CoqProject -o CoqMakefile 11 | 12 | invoke-coqmakefile: CoqMakefile 13 | $(MAKE) --no-print-directory -f CoqMakefile $(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS)) 14 | 15 | .PHONY: invoke-coqmakefile $(KNOWNFILES) 16 | 17 | # This should be the last rule, to handle any targets not declared above 18 | %: invoke-coqmakefile 19 | @true 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 5 | # Bits 6 | 7 | [![Docker CI][docker-action-shield]][docker-action-link] 8 | [![Contributing][contributing-shield]][contributing-link] 9 | [![Code of Conduct][conduct-shield]][conduct-link] 10 | [![Zulip][zulip-shield]][zulip-link] 11 | [![DOI][doi-shield]][doi-link] 12 | 13 | [docker-action-shield]: https://github.com/coq-community/bits/actions/workflows/docker-action.yml/badge.svg?branch=master 14 | [docker-action-link]: https://github.com/coq-community/bits/actions/workflows/docker-action.yml 15 | 16 | [contributing-shield]: https://img.shields.io/badge/contributions-welcome-%23f7931e.svg 17 | [contributing-link]: https://github.com/coq-community/manifesto/blob/master/CONTRIBUTING.md 18 | 19 | [conduct-shield]: https://img.shields.io/badge/%E2%9D%A4-code%20of%20conduct-%23f15a24.svg 20 | [conduct-link]: https://github.com/coq-community/manifesto/blob/master/CODE_OF_CONDUCT.md 21 | 22 | [zulip-shield]: https://img.shields.io/badge/chat-on%20zulip-%23c1272d.svg 23 | [zulip-link]: https://coq.zulipchat.com/#narrow/stream/237663-coq-community-devs.20.26.20users 24 | 25 | 26 | [doi-shield]: https://zenodo.org/badge/DOI/10.1007/978-3-319-29604-3_2.svg 27 | [doi-link]: https://doi.org/10.1007/978-3-319-29604-3_2 28 | 29 | A formalization of bitset operations in Coq with a corresponding 30 | axiomatization and extraction to OCaml native integers. 31 | 32 | ## Meta 33 | 34 | - Author(s): 35 | - Andrew Kennedy (initial) 36 | - Arthur Blot (initial) 37 | - Pierre-Évariste Dagand (initial) 38 | - Coq-community maintainer(s): 39 | - Anton Trunov ([**@anton-trunov**](https://github.com/anton-trunov)) 40 | - License: [Apache License 2.0](LICENSE) 41 | - Compatible Coq versions: 8.16 or later (use releases for other Coq versions) 42 | - Additional dependencies: 43 | - OCamlbuild 44 | - [MathComp](https://math-comp.github.io) 2.0 or later (`algebra` suffices) 45 | - [MathComp Algebra Tactics](https://github.com/math-comp/algebra-tactics) 46 | - Coq namespace: `Bits` 47 | - Related publication(s): 48 | - [From Sets to Bits in Coq](https://hal.archives-ouvertes.fr/hal-01251943/document) doi:[10.1007/978-3-319-29604-3_2](https://doi.org/10.1007/978-3-319-29604-3_2) 49 | - [Coq: The world's best macro assembler?](https://www.microsoft.com/en-us/research/wp-content/uploads/2016/12/coqasm.pdf) doi:[10.1145/2505879.2505897](https://doi.org/10.1145/2505879.2505897) 50 | 51 | ## Building and installation instructions 52 | 53 | The easiest way to install the latest released version of Bits 54 | is via [OPAM](https://opam.ocaml.org/doc/Install.html): 55 | 56 | ```shell 57 | opam repo add coq-released https://coq.inria.fr/opam/released 58 | opam install coq-bits 59 | ``` 60 | 61 | To instead build and install manually, do: 62 | 63 | ``` shell 64 | git clone https://github.com/coq-community/bits.git 65 | cd bits 66 | make # or make -j 67 | make install 68 | ``` 69 | 70 | 71 | ## Origins 72 | 73 | This library has been extracted from Andrew Kennedy et al. ['x86proved' fork][xprovedkennedy]. 74 | This link presently redirects to https://github.com/nbenton/x86proved repository. 75 | 76 | The main paper for this project is [Coq: The world’s best macro assembler?][coqasm]. 77 | 78 | ## Using the library 79 | 80 | To import the main library, do: 81 | ```coq 82 | From Bits Require Import bits. 83 | ``` 84 | 85 | An axiomatic interface supporting efficient extraction to OCaml can be 86 | loaded with: 87 | ```coq 88 | From Bits Require Import extraction.axioms8. (* or 16 or 32 *) 89 | ``` 90 | 91 | ## Organization 92 | 93 | This library, briefly described in the paper [From Sets to Bits in Coq][bitstosets], 94 | helps to model operations on bitsets. It's a formalization of 95 | logical and arithmetic operations on bit vectors. A bit vector is defined as an 96 | SSReflect tuple of bits, i.e. a list of booleans of fixed (word) size. 97 | 98 | The key abstractions offered by this library are as follows: 99 | - `BITS n : Type` - vector of `n` bits 100 | - `getBit bs k` - test the `k`-th bit of `bs` bit vector 101 | - `andB xs ys` - bitwise "and" 102 | - `orB xs ys` - bitwise "or" 103 | - `xorB xs ys` - bitwise "xor" 104 | - `invB xs` - bitwise negation 105 | - `shrB xs k` - right shift by `k` bits 106 | - `shlB xs k` - left shift by `k` bits 107 | 108 | The library characterizes the interactions between these elementary operations 109 | and provides embeddings to and from the additive group ℤ/(2ⁿ)ℤ. 110 | 111 | The overall structure of the code is as follows: 112 | - [src/ssrextra](src/ssrextra): complements to the [Mathcomp][mathcomp] library 113 | - [src/spec](src/spec): specification of bit vectors 114 | - [src/extraction](src/extraction): axiomatic interface to OCaml, for extraction 115 | 116 | For a specific formalization developed in a file `A.v`, one will find its 117 | associated properties in the file `A/properties.v`. For example, bit-level 118 | operations are defined in [src/spec/operations.v](src/spec/operations.v), 119 | therefore their properties can be found in 120 | [src/spec/operations/properties.v](src/spec/operations/properties.v). 121 | 122 | ## Verification axioms 123 | 124 | Axioms can be verified for 8-bit and 16-bit (using only extracted code) using 125 | the following command: 126 | ```shell 127 | make verify 128 | ``` 129 | 130 | For 8bit, the verification process should finish in few seconds. However 131 | for 16-bit, depending on your computer speed, it could take more than 6 132 | hours. 133 | 134 | [bitstosets]: https://hal.archives-ouvertes.fr/hal-01251943/document 135 | [coqasm]: https://www.microsoft.com/en-us/research/wp-content/uploads/2016/12/coqasm.pdf 136 | [xprovedkennedy]: https://x86proved.codeplex.com/SourceControl/network/forks/andrewjkennedy/x86proved/latest#src/bits.v 137 | [mathcomp]: https://github.com/math-comp/math-comp 138 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R src Bits 2 | 3 | -arg -w -arg -notation-overridden 4 | -arg -w -arg -ambiguous-paths 5 | -arg -w -arg -extraction-opaque-accessed 6 | -arg -w -arg -extraction-reserved-identifier 7 | 8 | src/ssrextra/nat.v 9 | src/ssrextra/tuple.v 10 | src/bits.v 11 | src/spec/operations.v 12 | src/spec/operations/properties.v 13 | src/spec/spec/properties.v 14 | src/spec/spec.v 15 | src/extraction/axioms8.v 16 | src/extraction/axioms16.v 17 | src/extraction/axioms32.v 18 | -------------------------------------------------------------------------------- /coq-bits.opam: -------------------------------------------------------------------------------- 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 | 4 | opam-version: "2.0" 5 | maintainer: "anton.a.trunov@gmail.com" 6 | version: "dev" 7 | 8 | homepage: "https://github.com/coq-community/bits" 9 | dev-repo: "git+https://github.com/coq-community/bits.git" 10 | bug-reports: "https://github.com/coq-community/bits/issues" 11 | license: "Apache-2.0" 12 | 13 | synopsis: "Coq bit vector library" 14 | description: """ 15 | A formalization of bitset operations in Coq with a corresponding 16 | axiomatization and extraction to OCaml native integers.""" 17 | 18 | build: [make "-j%{jobs}%"] 19 | install: [make "install"] 20 | depends: [ 21 | "coq" {>= "8.16"} 22 | "ocamlbuild" 23 | "coq-mathcomp-algebra" {>= "2.0"} 24 | "coq-mathcomp-algebra-tactics" 25 | ] 26 | 27 | tags: [ 28 | "category:Computer Science/Data Types and Data Structures" 29 | "keyword:bit arithmetic" 30 | "keyword:bitset" 31 | "keyword:bit vector" 32 | "keyword:extraction" 33 | "logpath:Bits" 34 | ] 35 | authors: [ 36 | "Andrew Kennedy " 37 | "Arthur Blot " 38 | "Pierre-Évariste Dagand " 39 | ] 40 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.5) 2 | (using coq 0.2) 3 | (name bits) 4 | -------------------------------------------------------------------------------- /meta.yml: -------------------------------------------------------------------------------- 1 | --- 2 | fullname: Bits 3 | shortname: bits 4 | organization: coq-community 5 | community: true 6 | action: true 7 | coqdoc: false 8 | doi: 10.1007/978-3-319-29604-3_2 9 | 10 | synopsis: >- 11 | Coq bit vector library 12 | 13 | description: |- 14 | A formalization of bitset operations in Coq with a corresponding 15 | axiomatization and extraction to OCaml native integers. 16 | 17 | publications: 18 | - pub_url: https://hal.archives-ouvertes.fr/hal-01251943/document 19 | pub_title: "From Sets to Bits in Coq" 20 | pub_doi: 10.1007/978-3-319-29604-3_2 21 | - pub_url: https://www.microsoft.com/en-us/research/wp-content/uploads/2016/12/coqasm.pdf 22 | pub_title: "Coq: The world's best macro assembler?" 23 | pub_doi: 10.1145/2505879.2505897 24 | 25 | authors: 26 | - name: Andrew Kennedy 27 | email: akenn@microsoft.com 28 | initial: true 29 | - name: Arthur Blot 30 | email: arthur.blot@ens-lyon.fr 31 | initial: true 32 | - name: Pierre-Évariste Dagand 33 | email: pierre-evariste.dagand@lip6.fr 34 | initial: true 35 | 36 | maintainers: 37 | - name: Anton Trunov 38 | nickname: anton-trunov 39 | 40 | opam-file-maintainer: anton.a.trunov@gmail.com 41 | 42 | opam-file-version: dev 43 | 44 | license: 45 | fullname: Apache License 2.0 46 | identifier: Apache-2.0 47 | file: LICENSE 48 | 49 | supported_coq_versions: 50 | text: 8.16 or later (use releases for other Coq versions) 51 | opam: '{>= "8.16"}' 52 | 53 | tested_coq_opam_versions: 54 | - version: '2.0.0-coq-8.16' 55 | repo: 'mathcomp/mathcomp' 56 | - version: '2.0.0-coq-8.18' 57 | repo: 'mathcomp/mathcomp' 58 | - version: '2.1.0-coq-8.16' 59 | repo: 'mathcomp/mathcomp' 60 | - version: '2.1.0-coq-8.18' 61 | repo: 'mathcomp/mathcomp' 62 | - version: '2.2.0-coq-8.16' 63 | repo: 'mathcomp/mathcomp' 64 | - version: '2.2.0-coq-8.19' 65 | repo: 'mathcomp/mathcomp' 66 | - version: '2.2.0-coq-dev' 67 | repo: 'mathcomp/mathcomp' 68 | - version: 'coq-8.19' 69 | repo: 'mathcomp/mathcomp-dev' 70 | - version: 'coq-dev' 71 | repo: 'mathcomp/mathcomp-dev' 72 | 73 | dependencies: 74 | - opam: 75 | name: ocamlbuild 76 | description: OCamlbuild 77 | - opam: 78 | name: coq-mathcomp-algebra 79 | version: '{>= "2.0"}' 80 | description: |- 81 | [MathComp](https://math-comp.github.io) 2.0 or later (`algebra` suffices) 82 | - opam: 83 | name: coq-mathcomp-algebra-tactics 84 | description: |- 85 | [MathComp Algebra Tactics](https://github.com/math-comp/algebra-tactics) 86 | 87 | namespace: Bits 88 | 89 | keywords: 90 | - name: bit arithmetic 91 | - name: bitset 92 | - name: bit vector 93 | - name: extraction 94 | 95 | categories: 96 | - name: Computer Science/Data Types and Data Structures 97 | 98 | documentation: |- 99 | ## Origins 100 | 101 | This library has been extracted from Andrew Kennedy et al. ['x86proved' fork][xprovedkennedy]. 102 | This link presently redirects to https://github.com/nbenton/x86proved repository. 103 | 104 | The main paper for this project is [Coq: The world’s best macro assembler?][coqasm]. 105 | 106 | ## Using the library 107 | 108 | To import the main library, do: 109 | ```coq 110 | From Bits Require Import bits. 111 | ``` 112 | 113 | An axiomatic interface supporting efficient extraction to OCaml can be 114 | loaded with: 115 | ```coq 116 | From Bits Require Import extraction.axioms8. (* or 16 or 32 *) 117 | ``` 118 | 119 | ## Organization 120 | 121 | This library, briefly described in the paper [From Sets to Bits in Coq][bitstosets], 122 | helps to model operations on bitsets. It's a formalization of 123 | logical and arithmetic operations on bit vectors. A bit vector is defined as an 124 | SSReflect tuple of bits, i.e. a list of booleans of fixed (word) size. 125 | 126 | The key abstractions offered by this library are as follows: 127 | - `BITS n : Type` - vector of `n` bits 128 | - `getBit bs k` - test the `k`-th bit of `bs` bit vector 129 | - `andB xs ys` - bitwise "and" 130 | - `orB xs ys` - bitwise "or" 131 | - `xorB xs ys` - bitwise "xor" 132 | - `invB xs` - bitwise negation 133 | - `shrB xs k` - right shift by `k` bits 134 | - `shlB xs k` - left shift by `k` bits 135 | 136 | The library characterizes the interactions between these elementary operations 137 | and provides embeddings to and from the additive group ℤ/(2ⁿ)ℤ. 138 | 139 | The overall structure of the code is as follows: 140 | - [src/ssrextra](src/ssrextra): complements to the [Mathcomp][mathcomp] library 141 | - [src/spec](src/spec): specification of bit vectors 142 | - [src/extraction](src/extraction): axiomatic interface to OCaml, for extraction 143 | 144 | For a specific formalization developed in a file `A.v`, one will find its 145 | associated properties in the file `A/properties.v`. For example, bit-level 146 | operations are defined in [src/spec/operations.v](src/spec/operations.v), 147 | therefore their properties can be found in 148 | [src/spec/operations/properties.v](src/spec/operations/properties.v). 149 | 150 | ## Verification axioms 151 | 152 | Axioms can be verified for 8-bit and 16-bit (using only extracted code) using 153 | the following command: 154 | ```shell 155 | make verify 156 | ``` 157 | 158 | For 8bit, the verification process should finish in few seconds. However 159 | for 16-bit, depending on your computer speed, it could take more than 6 160 | hours. 161 | 162 | [bitstosets]: https://hal.archives-ouvertes.fr/hal-01251943/document 163 | [coqasm]: https://www.microsoft.com/en-us/research/wp-content/uploads/2016/12/coqasm.pdf 164 | [xprovedkennedy]: https://x86proved.codeplex.com/SourceControl/network/forks/andrewjkennedy/x86proved/latest#src/bits.v 165 | [mathcomp]: https://github.com/math-comp/math-comp 166 | --- 167 | -------------------------------------------------------------------------------- /src/bits.v: -------------------------------------------------------------------------------- 1 | Require Export spec.spec. 2 | Require Export spec.spec.properties. 3 | Require Export spec.operations. 4 | Require Export spec.operations.properties. -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name Bits) 3 | (package coq-bits) 4 | (synopsis "Coq bit vector library") 5 | (flags -w -notation-overridden -w -ambiguous-paths)) 6 | 7 | (include_subdirs qualified) 8 | -------------------------------------------------------------------------------- /src/extraction/axioms16.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import ZArith.ZArith Extraction. 2 | From mathcomp Require Import ssreflect ssrfun ssrbool. 3 | From mathcomp Require Import eqtype ssrnat seq fintype tuple. 4 | From Bits Require Import bits. 5 | 6 | (* TODO: 7 | * Complete missing lemmas 8 | 9 | * Fix invalid extractions (addition is wrong on 63bits arch, for instance) 10 | 11 | * Define as a functor over wordsize (and forallInt) and 12 | instanciate at 8, 16, and 32 bits 13 | 14 | * Implement an efficient [forall] for bitvectors, prove 15 | equivalence with finType's forall. 16 | 17 | * Either get an efficient version of the tests below, or 18 | implement them in OCaml 19 | 20 | *) 21 | 22 | (** * An axiomatization of OCaml native integers *) 23 | 24 | 25 | Definition wordsize := 16. 26 | 27 | Axiom Int16: Type. 28 | Extract Inlined Constant Int16 => "int". 29 | 30 | 31 | (* Our trusted computing base sums up in these two operations and 32 | their associated reflection principles in Coq. *) 33 | 34 | Axiom forallInt16 : (Int16 -> bool) -> bool. 35 | Extract Inlined Constant forallInt16 => "Forall.forall_int16". 36 | 37 | Axiom eq: Int16 -> Int16 -> bool. 38 | Extract Inlined Constant eq => "(=)". 39 | 40 | Section Trust. 41 | 42 | (* Axiom 1: Equality of integer is embedded within Coq's propositional equality: *) 43 | Axiom eqInt16P : Equality.axiom eq. 44 | 45 | Definition viewP (P: pred Int16) (PP: Int16 -> Prop) := forall x, reflect (PP x) (P x). 46 | 47 | (* Axiom 2: If a property is true for all integers, then it is propositionally true *) 48 | Axiom forallInt16P : forall P PP, 49 | viewP P PP -> 50 | reflect (forall x, PP x) (forallInt16 (fun x => P x)). 51 | 52 | End Trust. 53 | 54 | (* All the axiomatized properties below are exhautively tested. *) 55 | 56 | Axiom zero : Int16. 57 | Extract Inlined Constant zero => "0". 58 | 59 | Axiom one : Int16. 60 | Extract Inlined Constant one => "1". 61 | 62 | Axiom succ : Int16 -> Int16. 63 | Extract Constant succ => "(fun x -> (x + 1) land 0xffff)". 64 | 65 | Axiom lor: Int16 -> Int16 -> Int16. 66 | Extract Inlined Constant lor => "(lor)". 67 | 68 | Axiom lsl: Int16 -> Int16 -> Int16. 69 | Extract Inlined Constant lsl => "(fun x y -> (x lsl y) land 0xffff)". 70 | 71 | Axiom land: Int16 -> Int16 -> Int16. 72 | Extract Inlined Constant land => "(land)". 73 | 74 | Axiom lt: Int16 -> Int16 -> bool. 75 | Extract Inlined Constant lt => "(<)". 76 | 77 | Axiom lsr: Int16 -> Int16 -> Int16. 78 | Extract Inlined Constant lsr => "(lsr)". 79 | 80 | Axiom neg: Int16 -> Int16. 81 | Extract Inlined Constant neg => "(fun x -> (-x) land 0xffff)". 82 | 83 | Axiom lnot: Int16 -> Int16. 84 | Extract Inlined Constant lnot => "(fun x -> (lnot x) land 0xffff)". 85 | 86 | Axiom lxor: Int16 -> Int16 -> Int16. 87 | Extract Inlined Constant lxor => "(lxor)". 88 | 89 | Axiom dec: Int16 -> Int16. 90 | Extract Constant dec => "(fun x -> (x - 1) land 0xffff)". 91 | 92 | Axiom add: Int16 -> Int16 -> Int16. 93 | Extract Inlined Constant add => "(fun x y -> (x + y) land 0xffff)". 94 | 95 | (* Conversion between machine integers and bit vectors *) 96 | 97 | Fixpoint PbitsToInt16 (p: seq bool): Int16 := 98 | match p with 99 | | true :: p => lor one (lsl (PbitsToInt16 p) one) 100 | | false :: p => lsl (PbitsToInt16 p) one 101 | | [::] => zero 102 | end. 103 | 104 | Definition bitsToInt16 (bs: BITS wordsize): Int16 := PbitsToInt16 bs. 105 | 106 | Fixpoint bitsFromInt16S (k: nat)(n: Int16): seq bool := 107 | match k with 108 | | 0 => [::] 109 | | k.+1 => 110 | let p := bitsFromInt16S k (lsr n one) in 111 | (eq (land n one) one) :: p 112 | end. 113 | 114 | Lemma bitsFromInt16P {k} (n: Int16): size (bitsFromInt16S k n) == k. 115 | Proof. 116 | elim: k n => // [k IH] n //=. 117 | rewrite eqSS //. 118 | Qed. 119 | 120 | Canonical bitsFromInt16 (n: Int16): BITS wordsize 121 | := Tuple (bitsFromInt16P n). 122 | 123 | (** * Cancelation of [bitsToInt16] on [bitsFromInt16] *) 124 | 125 | Definition bitsToInt16K_test: bool := 126 | [forall bs , bitsFromInt16 (bitsToInt16 bs) == bs ]. 127 | 128 | (* Validation condition: 129 | Experimentally, [bitsToInt16] must be cancelled by [bitsFromInt16] *) 130 | Axiom bitsToInt16K_valid: bitsToInt16K_test. 131 | 132 | Lemma bitsToInt16K: cancel bitsToInt16 bitsFromInt16. 133 | Proof. 134 | move=> bs; apply/eqP; move: bs. 135 | by apply/forallP: bitsToInt16K_valid. 136 | Qed. 137 | 138 | (** * Injectivity of [bitsFromInt16] *) 139 | 140 | Definition bitsFromInt16_inj_test: bool := 141 | forallInt16 (fun x => 142 | forallInt16 (fun y => 143 | (bitsFromInt16 x == bitsFromInt16 y) ==> (eq x y))). 144 | 145 | (* Validation condition: 146 | Experimentally, [bitsFromInt16] must be injective *) 147 | Axiom bitsFromInt16_inj_valid: bitsFromInt16_inj_test. 148 | 149 | Lemma bitsFromInt16_inj: injective bitsFromInt16. 150 | Proof. 151 | move=> x y /eqP H. 152 | apply/eqInt16P. 153 | move: H; apply/implyP. 154 | move: y; apply/(forallInt16P (fun y => (bitsFromInt16 x == bitsFromInt16 y) ==> eq x y)). 155 | move=> y; apply idP. 156 | move: x; apply/forallInt16P; last by apply bitsFromInt16_inj_valid. 157 | move=> x; apply idP. 158 | Qed. 159 | 160 | Lemma bitsFromInt16K: cancel bitsFromInt16 bitsToInt16. 161 | Proof. 162 | apply: inj_can_sym; auto using bitsToInt16K, bitsFromInt16_inj. 163 | Qed. 164 | 165 | (** * Bijection [Int16] vs. [BITS wordsize] *) 166 | 167 | Lemma bitsFromInt16_bij: bijective bitsFromInt16. 168 | Proof. 169 | split with (g := bitsToInt16); 170 | auto using bitsToInt16K, bitsFromInt16K. 171 | Qed. 172 | 173 | 174 | (** * Representation relation *) 175 | 176 | (** We say that an [n : Int16] is the representation of a bitvector 177 | [bs : BITS ] if they satisfy the axiom [repr_native]. Morally, it 178 | means that both represent the same number (ie. the same 179 | booleans). *) 180 | 181 | Definition native_repr (i: Int16)(bs: BITS wordsize): bool 182 | := eq i (bitsToInt16 bs). 183 | 184 | (** * Representation lemma: equality *) 185 | 186 | Lemma eq_adj: forall i bs, eq i (bitsToInt16 bs) = (bitsFromInt16 i == bs) . 187 | Proof. 188 | move=> i bs. 189 | apply/eqInt16P/eqP; intro; subst; 190 | auto using bitsFromInt16K, bitsToInt16K. 191 | Qed. 192 | 193 | Lemma eq_repr: 194 | forall i i' bs bs', 195 | native_repr i bs -> native_repr i' bs' -> 196 | (eq i i') = (bs == bs'). 197 | Proof. 198 | move=> i i' bs bs'. 199 | rewrite /native_repr. 200 | repeat (rewrite eq_adj; move/eqP=> <-). 201 | apply/eqInt16P/eqP; intro; subst; auto using bitsFromInt16_inj. 202 | Qed. 203 | 204 | (** * Representation lemma: individuals *) 205 | 206 | Definition zero_test: bool 207 | := eq zero (bitsToInt16 #0). 208 | 209 | (* Validation condition: 210 | bit vector [#0] corresponds to machine [0] *) 211 | Axiom zero_valid: zero_test. 212 | 213 | Lemma zero_repr: native_repr zero #0. 214 | Proof. apply zero_valid. Qed. 215 | 216 | Definition one_test: bool 217 | := eq one (bitsToInt16 #1). 218 | 219 | (* Validation condition: 220 | bit vector [#1] corresponds to machine [1] *) 221 | Axiom one_valid: one_test. 222 | 223 | Lemma one_repr: native_repr one #1. 224 | Proof. apply one_valid. Qed. 225 | 226 | (** * Representation lemma: successor *) 227 | 228 | Definition succ_test: bool 229 | := forallInt16 (fun i => 230 | native_repr (succ i) (incB (bitsFromInt16 i))). 231 | 232 | (* Validation condition: 233 | [succ "n"] corresponds to machine [n + 1] *) 234 | Axiom succ_valid: succ_test. 235 | 236 | Lemma succ_repr: forall i bs, 237 | native_repr i bs -> native_repr (succ i) (incB bs). 238 | Proof. 239 | move=> i ?. 240 | rewrite /native_repr eq_adj. 241 | move/eqP=> <-. 242 | apply/eqInt16P. 243 | move: i; apply/forallInt16P; last by apply succ_valid. 244 | move=> x; apply/eqInt16P. 245 | Qed. 246 | 247 | (** * Representation lemma: negation *) 248 | 249 | Definition lnot_test: bool 250 | := forallInt16 (fun i => 251 | native_repr (lnot i) (invB (bitsFromInt16 i))). 252 | 253 | (* Validation condition: 254 | [invB "n"] corresponds to machine [lnot n] *) 255 | Axiom lnot_valid: lnot_test. 256 | 257 | Lemma lnot_repr: forall i bs, 258 | native_repr i bs -> native_repr (lnot i) (invB bs). 259 | Proof. 260 | move=> i ?. 261 | rewrite /native_repr eq_adj. 262 | move/eqP=> <-. 263 | apply/eqInt16P. 264 | move: i; apply/forallInt16P; last by apply lnot_valid. 265 | move=> i; apply/eqInt16P. 266 | Qed. 267 | 268 | (** * Representation lemma: logical and *) 269 | 270 | Definition land_test: bool 271 | := forallInt16 (fun i => 272 | forallInt16 (fun i' => 273 | native_repr (land i i') (andB (bitsFromInt16 i) (bitsFromInt16 i')))). 274 | 275 | (* Validation condition: 276 | [land "m" "n"] corresponds to machine [m land n] *) 277 | Axiom land_valid: land_test. 278 | 279 | Lemma land_repr: forall i i' bs bs', 280 | native_repr i bs -> native_repr i' bs' -> 281 | native_repr (land i i') (andB bs bs'). 282 | Proof. 283 | move=> i i' ? ?. 284 | repeat (rewrite /native_repr eq_adj; move/eqP=> <-). 285 | apply/eqInt16P. 286 | move: i'; apply/(forallInt16P (fun i' => eq (land i i') (bitsToInt16 (andB (bitsFromInt16 i) (bitsFromInt16 i'))))). 287 | move=> i'; apply/eqInt16P. 288 | move: i; apply/forallInt16P; last by apply land_valid. 289 | move=> i'; apply idP. 290 | Qed. 291 | 292 | (** * Representation lemma: logical or *) 293 | 294 | Definition lor_test: bool 295 | := forallInt16 (fun i => 296 | forallInt16 (fun i' => 297 | native_repr (lor i i') (orB (bitsFromInt16 i) (bitsFromInt16 i')))). 298 | 299 | (* Validation condition: 300 | [lor "m" "n"] corresponds to machine [m lor n] *) 301 | Axiom lor_valid: lor_test. 302 | 303 | Lemma lor_repr: forall i i' bs bs', 304 | native_repr i bs -> native_repr i' bs' -> 305 | native_repr (lor i i') (orB bs bs'). 306 | Proof. 307 | move=> i i' ? ?. 308 | repeat (rewrite /native_repr eq_adj; move/eqP=> <-). 309 | apply/eqInt16P. 310 | move: i'; apply/(forallInt16P (fun i' => eq (lor i i') (bitsToInt16 (orB (bitsFromInt16 i) (bitsFromInt16 i'))))). 311 | move=> i'; apply/eqInt16P. 312 | move: i; apply/forallInt16P; last by apply lor_valid. 313 | move=> i'; apply idP. 314 | Qed. 315 | 316 | (** * Representation lemma: logical xor *) 317 | 318 | Definition lxor_test: bool 319 | := forallInt16 (fun i => 320 | forallInt16 (fun i' => 321 | native_repr (lxor i i') (xorB (bitsFromInt16 i) (bitsFromInt16 i')))). 322 | 323 | (* Validation condition: 324 | [lxor "m" "n"] corresponds to machine [m lxor n] *) 325 | Axiom lxor_valid: lxor_test. 326 | 327 | 328 | Lemma lxor_repr: forall i i' bs bs', 329 | native_repr i bs -> native_repr i' bs' -> 330 | native_repr (lxor i i') (xorB bs bs'). 331 | Proof. 332 | move=> i i' ? ?. 333 | repeat (rewrite /native_repr eq_adj; move/eqP=> <-). 334 | apply/eqInt16P. 335 | move: i'; apply/(forallInt16P (fun i' => eq (lxor i i') (bitsToInt16 (xorB (bitsFromInt16 i) (bitsFromInt16 i'))))). 336 | move=> i'; apply/eqInt16P. 337 | move: i; apply/forallInt16P; last by apply lxor_valid. 338 | move=> i'; apply idP. 339 | Qed. 340 | 341 | (** * Representation of naturals *) 342 | 343 | (** We extend the refinement relation (by composition) to natural 344 | numbers, going through a [BITS wordsize] word. *) 345 | 346 | Definition natural_repr (i: Int16)(n: nat): bool := 347 | [exists bs, native_repr i bs && (# n == bs)]. 348 | 349 | (** * Representation lemma: logical shift right *) 350 | 351 | Definition lsr_test: bool 352 | := forallInt16 (fun i => 353 | forallInt16 (fun i' => 354 | (toNat (bitsFromInt16 i') <= wordsize) ==> native_repr (lsr i i') (shrBn (bitsFromInt16 i) (toNat (bitsFromInt16 i'))))). 355 | 356 | (* Validation condition: 357 | [lsr "m" "n"] corresponds to machine [m lsr n] *) 358 | Axiom lsr_valid: lsr_test. 359 | 360 | Lemma lsr_repr: forall i j bs k, k <= wordsize -> 361 | native_repr i bs -> natural_repr j k -> 362 | native_repr (lsr i j) (shrBn bs k). 363 | Proof. 364 | move=> i i' ? k ltn_k. 365 | rewrite /native_repr eq_adj; move/eqP=> <-. 366 | rewrite /natural_repr. 367 | move/existsP=> [bs' /andP [H /eqP H']]. 368 | rewrite /native_repr eq_adj in H. 369 | move/eqP: H=> H. 370 | apply/eqInt16P. 371 | have Hk: k = toNat (bitsFromInt16 i'). 372 | rewrite H. 373 | have ->: k = toNat (fromNat (n := wordsize) k). 374 | rewrite toNat_fromNatBounded=> //. 375 | by apply (leq_ltn_trans (n := wordsize)). 376 | by rewrite H'. 377 | rewrite Hk. 378 | rewrite Hk in ltn_k. 379 | clear H H' Hk. 380 | move: i' ltn_k; apply/(forallInt16P (fun i' => (toNat (bitsFromInt16 i') <= wordsize) ==> (eq (lsr i i') (bitsToInt16 (shrBn (bitsFromInt16 i) (toNat ((bitsFromInt16 i')))))))). 381 | move=> i'. 382 | apply/equivP. 383 | apply/implyP. 384 | split=> H H'. 385 | move: (H H')=> H''. 386 | by apply/eqInt16P. 387 | move: (H H')=> H''. 388 | by apply/eqInt16P. 389 | move: i; apply/forallInt16P; last by apply lsr_valid. 390 | move=> i'; apply idP. 391 | Qed. 392 | 393 | (** * Representation lemma: logical shift left *) 394 | 395 | Definition lsl_test: bool 396 | := forallInt16 (fun i => 397 | forallInt16 (fun i' => 398 | (toNat (bitsFromInt16 i') <= wordsize) ==> native_repr (lsl i i') (shlBn (bitsFromInt16 i) (toNat (bitsFromInt16 i'))))). 399 | 400 | (* Validation condition: 401 | [lsl "m" "n"] corresponds to machine [m lsl n] *) 402 | Axiom lsl_valid: lsl_test. 403 | 404 | Lemma lsl_repr: forall i j bs k, k <= wordsize -> 405 | native_repr i bs -> natural_repr j k -> 406 | native_repr (lsl i j) (shlBn bs k). 407 | Proof. 408 | move=> i i' ? k ltn_k. 409 | rewrite /native_repr eq_adj; move/eqP=> <-. 410 | rewrite /natural_repr. 411 | move/existsP=> [bs' /andP [H /eqP H']]. 412 | rewrite /native_repr eq_adj in H. 413 | move/eqP: H=> H. 414 | apply/eqInt16P. 415 | have Hk: k = toNat (bitsFromInt16 i'). 416 | rewrite H. 417 | have ->: k = toNat (fromNat (n := wordsize) k). 418 | rewrite toNat_fromNatBounded=> //. 419 | by apply (leq_ltn_trans (n := wordsize)). 420 | by rewrite H'. 421 | rewrite Hk. 422 | rewrite Hk in ltn_k. 423 | clear H H' Hk. 424 | move: i' ltn_k; apply/(forallInt16P (fun i' => (toNat (bitsFromInt16 i') <= wordsize) ==> (eq (lsl i i') (bitsToInt16 (shlBn (bitsFromInt16 i) (toNat ((bitsFromInt16 i')))))))). 425 | move=> i'. 426 | apply/equivP. 427 | apply/implyP. 428 | split=> H H'. 429 | move: (H H')=> H''. 430 | by apply/eqInt16P. 431 | move: (H H')=> H''. 432 | by apply/eqInt16P. 433 | move: i; apply/forallInt16P; last by apply lsl_valid. 434 | move=> i'; apply idP. 435 | Qed. 436 | 437 | (** * Representation lemma: negation *) 438 | 439 | Definition neg_test: bool 440 | := forallInt16 (fun i => 441 | native_repr (neg i) (negB (bitsFromInt16 i))). 442 | 443 | (* Validation condition: 444 | [negB "m"] corresponds to machine [- m] *) 445 | Axiom neg_valid: neg_test. 446 | 447 | Lemma neg_repr: forall i bs, 448 | native_repr i bs -> native_repr (neg i) (negB bs). 449 | Proof. 450 | move=> i ?. 451 | rewrite /native_repr eq_adj. 452 | move/eqP=> <-. 453 | apply/eqInt16P. 454 | move: i; apply/forallInt16P; last by apply neg_valid. 455 | move=> i; apply/eqInt16P. 456 | Qed. 457 | 458 | (** * Representation lemma: decrement *) 459 | 460 | Definition dec_test: bool 461 | := forallInt16 (fun i => 462 | native_repr (dec i) (decB (bitsFromInt16 i))). 463 | 464 | (* Validation condition: 465 | [decB "m"] corresponds to machine [dec m] *) 466 | Axiom dec_valid: dec_test. 467 | 468 | Lemma dec_repr: forall i bs, 469 | native_repr i bs -> native_repr (dec i) (decB bs). 470 | Proof. 471 | move=> i ?. 472 | rewrite /native_repr eq_adj. 473 | move/eqP=> <-. 474 | apply/eqInt16P. 475 | move: i; apply/forallInt16P; last by apply dec_valid. 476 | move=> i; apply/eqInt16P. 477 | Qed. 478 | 479 | (** * Representation lemma: addition *) 480 | 481 | Definition add_test: bool 482 | := forallInt16 (fun i => 483 | forallInt16 (fun i' => 484 | native_repr (add i i') (addB (bitsFromInt16 i) (bitsFromInt16 i')))). 485 | 486 | (* Validation condition: 487 | [decB "m"] corresponds to machine [dec m] *) 488 | Axiom add_valid: add_test. 489 | 490 | Lemma add_repr: 491 | forall i i' bs bs', 492 | native_repr i bs -> native_repr i' bs' -> 493 | native_repr (add i i') (addB bs bs'). 494 | Proof. 495 | move=> i i' ? ?. 496 | repeat (rewrite /native_repr eq_adj; move/eqP=> <-). 497 | apply/eqInt16P. 498 | move: i'; apply/(forallInt16P (fun i' => eq (add i i') (bitsToInt16 (addB (bitsFromInt16 i) (bitsFromInt16 i'))))). 499 | move=> i'; apply/eqInt16P. 500 | move: i; apply/forallInt16P; last by apply add_valid. 501 | move=> i'; apply idP. 502 | Qed. 503 | 504 | (** Extract the tests: they should all return true! *) 505 | 506 | Require Import ExtrOcamlBasic. 507 | 508 | Definition allb s := foldr (andb) true s. 509 | 510 | Definition binop_tests x bitsX y bitsY := 511 | allb 512 | [:: (bitsX == bitsY) ==> (eq x y) ; 513 | native_repr (land x y) (andB bitsX bitsY) ; 514 | native_repr (lor x y) (orB bitsX bitsY) ; 515 | native_repr (lxor x y) (xorB bitsX bitsY) ; 516 | native_repr (add x y) (addB bitsX bitsY)]. 517 | 518 | Definition shift_tests x toNatX y bitsY := 519 | allb 520 | [:: native_repr (lsr y x) (shrBn bitsY toNatX) ; 521 | native_repr (lsl y x) (shlBn bitsY toNatX)]. 522 | 523 | Definition unop_tests x := 524 | let bitsX := bitsFromInt16 x in 525 | let toNatX := toNat bitsX in 526 | allb 527 | [:: native_repr (succ x) (incB bitsX) ; 528 | native_repr (lnot x) (invB bitsX) ; 529 | native_repr (neg x) (negB bitsX) ; 530 | native_repr (dec x) (decB bitsX) ; 531 | if (toNatX <= wordsize) then 532 | forallInt16 (fun y => 533 | let bitsY := bitsFromInt16 y in 534 | (binop_tests x bitsX y bitsY) && (shift_tests x toNatX y bitsY)) 535 | else 536 | forallInt16 (fun y => binop_tests x bitsX y (bitsFromInt16 y))]. 537 | 538 | Definition tests 539 | := allb 540 | [:: bitsToInt16K_test ; 541 | zero_test ; 542 | one_test ; 543 | forallInt16 544 | (fun x => unop_tests x)]. 545 | 546 | Lemma implies_unop : tests -> forall x, unop_tests x. 547 | move=> /andP [_ /andP [_ /andP[_ /andP [H _]]]] x. 548 | rewrite /succ_test. 549 | move: H=> /forallInt16P H. 550 | move: (H unop_tests)=> H'. 551 | apply H'=> x'. 552 | by apply idP. 553 | Qed. 554 | 555 | Lemma implies_binop : tests -> forall x y, binop_tests x (bitsFromInt16 x) y (bitsFromInt16 y). 556 | move => H x y. 557 | have H': unop_tests x by apply implies_unop. 558 | move: H'=> /andP [_ /andP [_ /andP [_ /andP [_ /andP [H1 _]]]]]. 559 | case Hc: (toNat (bitsFromInt16 x) <= wordsize); rewrite Hc in H1. 560 | have Hb: (binop_tests x (bitsFromInt16 x) y (bitsFromInt16 y)) && (shift_tests x (toNat (bitsFromInt16 x)) y (bitsFromInt16 y)). 561 | move: H1=> /forallInt16P H1. 562 | move: (H1 (fun y => (binop_tests x (bitsFromInt16 x) y (bitsFromInt16 y)) && (shift_tests x (toNat (bitsFromInt16 x)) y (bitsFromInt16 y))))=> H2. 563 | apply H2=> y'. 564 | by apply idP. 565 | by move: Hb=> /andP [-> _]. 566 | move: H1=> /forallInt16P H1. 567 | move: (H1 (fun y => binop_tests x (bitsFromInt16 x) y (bitsFromInt16 y)))=> H2. 568 | apply H2=> y'. 569 | by apply idP. 570 | Qed. 571 | 572 | Lemma implies_bitsToInt16K : tests -> bitsToInt16K_test. 573 | by move=> /andP [H _]. 574 | Qed. 575 | 576 | Lemma implies_bitsFromInt16_inj : tests -> bitsFromInt16_inj_test. 577 | move=> H. 578 | apply/forallInt16P=> x. 579 | apply idP. 580 | apply/forallInt16P=> y. 581 | apply idP. 582 | by move: (implies_binop H x y)=> /andP [-> _]. 583 | Qed. 584 | 585 | Lemma implies_zero : tests -> zero_test. 586 | by move=> /andP [_ /andP [H _]]. 587 | Qed. 588 | 589 | Lemma implies_one : tests -> one_test. 590 | by move=> /andP [_ /andP [_ /andP[H _]]]. 591 | Qed. 592 | 593 | Lemma implies_succ : tests -> succ_test. 594 | move=> H. 595 | apply/forallInt16P=> x. 596 | apply idP. 597 | have H': unop_tests x by apply implies_unop. 598 | by move: H'=> /andP [H1 _]. 599 | Qed. 600 | 601 | Lemma implies_lnot : tests -> lnot_test. 602 | move=> H. 603 | apply/forallInt16P=> x. 604 | apply idP. 605 | have H': unop_tests x by apply implies_unop. 606 | by move: H'=> /andP [_ /andP [H1 _]]. 607 | Qed. 608 | 609 | Lemma implies_land : tests -> land_test. 610 | move=> H. 611 | apply/forallInt16P=> x. 612 | apply idP. 613 | apply/forallInt16P=> y. 614 | apply idP. 615 | by move: (implies_binop H x y)=> /andP [_ /andP [-> _]]. 616 | Qed. 617 | 618 | Lemma implies_lor : tests -> lor_test. 619 | move=> H. 620 | apply/forallInt16P=> x. 621 | apply idP. 622 | apply/forallInt16P=> y. 623 | apply idP. 624 | by move: (implies_binop H x y)=> /andP [_ /andP [_ /andP [-> _]]]. 625 | Qed. 626 | 627 | Lemma implies_lxor : tests -> lxor_test. 628 | move=> H. 629 | apply/forallInt16P=> x. 630 | apply idP. 631 | apply/forallInt16P=> y. 632 | apply idP. 633 | by move: (implies_binop H x y)=> /andP [_ /andP [_ /andP [_ /andP [-> _]]]]. 634 | Qed. 635 | 636 | Lemma implies_shift : tests -> forall x y, toNat (bitsFromInt16 x) <= wordsize -> shift_tests x (toNat (bitsFromInt16 x)) y (bitsFromInt16 y). 637 | move => H x y Hlt. 638 | move: (implies_unop H x)=> /andP [_ /andP [_ /andP [_ /andP [_ /andP [H1 _]]]]]. 639 | rewrite Hlt in H1. 640 | have Hb: (binop_tests x (bitsFromInt16 x) y (bitsFromInt16 y)) && (shift_tests x (toNat (bitsFromInt16 x)) y (bitsFromInt16 y)). 641 | move: H1=> /forallInt16P H1. 642 | move: (H1 (fun y => (binop_tests x (bitsFromInt16 x) y (bitsFromInt16 y)) && (shift_tests x (toNat (bitsFromInt16 x)) y (bitsFromInt16 y))))=> H2. 643 | apply H2=> y'. 644 | by apply idP. 645 | by move: Hb=> /andP [_ ->]. 646 | Qed. 647 | 648 | Lemma implies_lsr : tests -> lsr_test. 649 | move=> H. 650 | apply/forallInt16P=> y. 651 | apply idP. 652 | apply/forallInt16P=> x. 653 | apply idP. 654 | apply/implyP=> H'. 655 | by move: (implies_shift H x y H')=> /andP [-> _]. 656 | Qed. 657 | 658 | Lemma implies_lsl : tests -> lsl_test. 659 | move=> H. 660 | apply/forallInt16P=> y. 661 | apply idP. 662 | apply/forallInt16P=> x. 663 | apply idP. 664 | apply/implyP=> H'. 665 | by move: (implies_shift H x y H')=> /andP [_ /andP [-> _]]. 666 | Qed. 667 | 668 | Lemma implies_neg : tests -> neg_test. 669 | move=> H. 670 | apply/forallInt16P=> x. 671 | apply idP. 672 | have H': unop_tests x by apply implies_unop. 673 | by move: H'=> /andP [_ /andP [_ /andP [H1 _]]]. 674 | Qed. 675 | 676 | Lemma implies_dec : tests -> dec_test. 677 | move=> H. 678 | apply/forallInt16P=> x. 679 | apply idP. 680 | have H': unop_tests x by apply implies_unop. 681 | by move: H'=> /andP [_ /andP [_ /andP [_ /andP [H1 _]]]]. 682 | Qed. 683 | 684 | Lemma implies_add : tests -> add_test. 685 | move=> H. 686 | apply/forallInt16P=> x. 687 | apply idP. 688 | apply/forallInt16P=> y. 689 | apply idP. 690 | by move: (implies_binop H x y)=> /andP [_ /andP [_ /andP [_ /andP [_ /andP [-> _]]]]]. 691 | Qed. 692 | 693 | Cd "src/extraction". 694 | Extraction "axioms16.ml" tests. 695 | Cd "../..". 696 | -------------------------------------------------------------------------------- /src/extraction/axioms32.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import ZArith.ZArith Extraction. 2 | From mathcomp Require Import ssreflect ssrfun ssrbool. 3 | From mathcomp Require Import eqtype ssrnat seq fintype tuple. 4 | From Bits Require Import bits. 5 | 6 | (* TODO: 7 | * Complete missing lemmas 8 | 9 | * Fix invalid extractions (addition is wrong on 63bits arch, for instance) 10 | 11 | * Define as a functor over wordsize (and forallInt) and 12 | instanciate at 8, 16, and 32 bits 13 | 14 | * Implement an efficient [forall] for bitvectors, prove 15 | equivalence with finType's forall. 16 | 17 | * Either get an efficient version of the tests below, or 18 | implement them in OCaml 19 | 20 | *) 21 | 22 | (** * An axiomatization of OCaml native integers *) 23 | 24 | 25 | Definition wordsize := 32. 26 | 27 | Axiom Int32: Type. 28 | Extract Inlined Constant Int32 => "int". 29 | 30 | 31 | (* Our trusted computing base sums up in these two operations and 32 | their associated reflection principles in Coq. *) 33 | 34 | Axiom forallInt32 : (Int32 -> bool) -> bool. 35 | Extract Inlined Constant forallInt32 => "Forall.forall_int32". 36 | 37 | Axiom eq: Int32 -> Int32 -> bool. 38 | Extract Inlined Constant eq => "(=)". 39 | 40 | Section Trust. 41 | 42 | (* Axiom 1: Equality of integer is embedded within Coq's propositional equality: *) 43 | Axiom eqInt32P : Equality.axiom eq. 44 | 45 | Definition viewP (P: pred Int32) (PP: Int32 -> Prop) := forall x, reflect (PP x) (P x). 46 | 47 | (* Axiom 2: If a property is true for all integers, then it is propositionally true *) 48 | Axiom forallInt32P : forall P PP, 49 | viewP P PP -> 50 | reflect (forall x, PP x) (forallInt32 (fun x => P x)). 51 | 52 | End Trust. 53 | 54 | (* All the axiomatized properties below are exhautively tested. *) 55 | 56 | Axiom zero : Int32. 57 | Extract Inlined Constant zero => "0". 58 | 59 | Axiom one : Int32. 60 | Extract Inlined Constant one => "1". 61 | 62 | Axiom succ : Int32 -> Int32. 63 | Extract Constant succ => "(fun x -> (x + 1) land 0xffffffff)". 64 | 65 | Axiom lor: Int32 -> Int32 -> Int32. 66 | Extract Inlined Constant lor => "(lor)". 67 | 68 | Axiom lsl: Int32 -> Int32 -> Int32. 69 | Extract Inlined Constant lsl => "(fun x y -> (x lsl y) land 0xffffffff)". 70 | 71 | Axiom land: Int32 -> Int32 -> Int32. 72 | Extract Inlined Constant land => "(land)". 73 | 74 | Axiom lt: Int32 -> Int32 -> bool. 75 | Extract Inlined Constant lt => "(<)". 76 | 77 | Axiom lsr: Int32 -> Int32 -> Int32. 78 | Extract Inlined Constant lsr => "(lsr)". 79 | 80 | Axiom neg: Int32 -> Int32. 81 | Extract Inlined Constant neg => "(fun x -> (-x) land 0xffffffff)". 82 | 83 | Axiom lnot: Int32 -> Int32. 84 | Extract Inlined Constant lnot => "(fun x -> (lnot x) land 0xffffffff)". 85 | 86 | Axiom lxor: Int32 -> Int32 -> Int32. 87 | Extract Inlined Constant lxor => "(lxor)". 88 | 89 | Axiom dec: Int32 -> Int32. 90 | Extract Constant dec => "(fun x -> (x - 1) land 0xffffffff)". 91 | 92 | Axiom add: Int32 -> Int32 -> Int32. 93 | Extract Inlined Constant add => "(fun x y -> (x + y) land 0xffffffff)". 94 | 95 | (* Conversion between machine integers and bit vectors *) 96 | 97 | Fixpoint PbitsToInt32 (p: seq bool): Int32 := 98 | match p with 99 | | true :: p => lor one (lsl (PbitsToInt32 p) one) 100 | | false :: p => lsl (PbitsToInt32 p) one 101 | | [::] => zero 102 | end. 103 | 104 | Definition bitsToInt32 (bs: BITS wordsize): Int32 := PbitsToInt32 bs. 105 | 106 | Fixpoint bitsFromInt32S (k: nat)(n: Int32): seq bool := 107 | match k with 108 | | 0 => [::] 109 | | k.+1 => 110 | let p := bitsFromInt32S k (lsr n one) in 111 | (eq (land n one) one) :: p 112 | end. 113 | 114 | Lemma bitsFromInt32P {k} (n: Int32): size (bitsFromInt32S k n) == k. 115 | Proof. 116 | elim: k n => // [k IH] n //=. 117 | rewrite eqSS //. 118 | Qed. 119 | 120 | Canonical bitsFromInt32 (n: Int32): BITS wordsize 121 | := Tuple (bitsFromInt32P n). 122 | 123 | (** * Cancelation of [bitsToInt32] on [bitsFromInt32] *) 124 | 125 | Definition bitsToInt32K_test: bool := 126 | [forall bs , bitsFromInt32 (bitsToInt32 bs) == bs ]. 127 | 128 | (* Validation condition: 129 | Experimentally, [bitsToInt32] must be cancelled by [bitsFromInt32] *) 130 | Axiom bitsToInt32K_valid: bitsToInt32K_test. 131 | 132 | Lemma bitsToInt32K: cancel bitsToInt32 bitsFromInt32. 133 | Proof. 134 | move=> bs; apply/eqP; move: bs. 135 | by apply/forallP: bitsToInt32K_valid. 136 | Qed. 137 | 138 | (** * Injectivity of [bitsFromInt32] *) 139 | 140 | Definition bitsFromInt32_inj_test: bool := 141 | forallInt32 (fun x => 142 | forallInt32 (fun y => 143 | (bitsFromInt32 x == bitsFromInt32 y) ==> (eq x y))). 144 | 145 | (* Validation condition: 146 | Experimentally, [bitsFromInt32] must be injective *) 147 | Axiom bitsFromInt32_inj_valid: bitsFromInt32_inj_test. 148 | 149 | Lemma bitsFromInt32_inj: injective bitsFromInt32. 150 | Proof. 151 | move=> x y /eqP H. 152 | apply/eqInt32P. 153 | move: H; apply/implyP. 154 | move: y; apply/(forallInt32P (fun y => (bitsFromInt32 x == bitsFromInt32 y) ==> eq x y)). 155 | move=> y; apply idP. 156 | move: x; apply/forallInt32P; last by apply bitsFromInt32_inj_valid. 157 | move=> x; apply idP. 158 | Qed. 159 | 160 | Lemma bitsFromInt32K: cancel bitsFromInt32 bitsToInt32. 161 | Proof. 162 | apply: inj_can_sym; auto using bitsToInt32K, bitsFromInt32_inj. 163 | Qed. 164 | 165 | (** * Bijection [Int32] vs. [BITS wordsize] *) 166 | 167 | Lemma bitsFromInt32_bij: bijective bitsFromInt32. 168 | Proof. 169 | split with (g := bitsToInt32); 170 | auto using bitsToInt32K, bitsFromInt32K. 171 | Qed. 172 | 173 | 174 | (** * Representation relation *) 175 | 176 | (** We say that an [n : Int32] is the representation of a bitvector 177 | [bs : BITS ] if they satisfy the axiom [repr_native]. Morally, it 178 | means that both represent the same number (ie. the same 179 | booleans). *) 180 | 181 | Definition native_repr (i: Int32)(bs: BITS wordsize): bool 182 | := eq i (bitsToInt32 bs). 183 | 184 | (** * Representation lemma: equality *) 185 | 186 | Lemma eq_adj: forall i bs, eq i (bitsToInt32 bs) = (bitsFromInt32 i == bs) . 187 | Proof. 188 | move=> i bs. 189 | apply/eqInt32P/eqP; intro; subst; 190 | auto using bitsFromInt32K, bitsToInt32K. 191 | Qed. 192 | 193 | Lemma eq_repr: 194 | forall i i' bs bs', 195 | native_repr i bs -> native_repr i' bs' -> 196 | (eq i i') = (bs == bs'). 197 | Proof. 198 | move=> i i' bs bs'. 199 | rewrite /native_repr. 200 | repeat (rewrite eq_adj; move/eqP=> <-). 201 | apply/eqInt32P/eqP; intro; subst; auto using bitsFromInt32_inj. 202 | Qed. 203 | 204 | (** * Representation lemma: individuals *) 205 | 206 | Definition zero_test: bool 207 | := eq zero (bitsToInt32 #0). 208 | 209 | (* Validation condition: 210 | bit vector [#0] corresponds to machine [0] *) 211 | Axiom zero_valid: zero_test. 212 | 213 | Lemma zero_repr: native_repr zero #0. 214 | Proof. apply zero_valid. Qed. 215 | 216 | Definition one_test: bool 217 | := eq one (bitsToInt32 #1). 218 | 219 | (* Validation condition: 220 | bit vector [#1] corresponds to machine [1] *) 221 | Axiom one_valid: one_test. 222 | 223 | Lemma one_repr: native_repr one #1. 224 | Proof. apply one_valid. Qed. 225 | 226 | (** * Representation lemma: successor *) 227 | 228 | Definition succ_test: bool 229 | := forallInt32 (fun i => 230 | native_repr (succ i) (incB (bitsFromInt32 i))). 231 | 232 | (* Validation condition: 233 | [succ "n"] corresponds to machine [n + 1] *) 234 | Axiom succ_valid: succ_test. 235 | 236 | Lemma succ_repr: forall i bs, 237 | native_repr i bs -> native_repr (succ i) (incB bs). 238 | Proof. 239 | move=> i ?. 240 | rewrite /native_repr eq_adj. 241 | move/eqP=> <-. 242 | apply/eqInt32P. 243 | move: i; apply/forallInt32P; last by apply succ_valid. 244 | move=> x; apply/eqInt32P. 245 | Qed. 246 | 247 | (** * Representation lemma: negation *) 248 | 249 | Definition lnot_test: bool 250 | := forallInt32 (fun i => 251 | native_repr (lnot i) (invB (bitsFromInt32 i))). 252 | 253 | (* Validation condition: 254 | [invB "n"] corresponds to machine [lnot n] *) 255 | Axiom lnot_valid: lnot_test. 256 | 257 | Lemma lnot_repr: forall i bs, 258 | native_repr i bs -> native_repr (lnot i) (invB bs). 259 | Proof. 260 | move=> i ?. 261 | rewrite /native_repr eq_adj. 262 | move/eqP=> <-. 263 | apply/eqInt32P. 264 | move: i; apply/forallInt32P; last by apply lnot_valid. 265 | move=> i; apply/eqInt32P. 266 | Qed. 267 | 268 | (** * Representation lemma: logical and *) 269 | 270 | Definition land_test: bool 271 | := forallInt32 (fun i => 272 | forallInt32 (fun i' => 273 | native_repr (land i i') (andB (bitsFromInt32 i) (bitsFromInt32 i')))). 274 | 275 | (* Validation condition: 276 | [land "m" "n"] corresponds to machine [m land n] *) 277 | Axiom land_valid: land_test. 278 | 279 | Lemma land_repr: forall i i' bs bs', 280 | native_repr i bs -> native_repr i' bs' -> 281 | native_repr (land i i') (andB bs bs'). 282 | Proof. 283 | move=> i i' ? ?. 284 | repeat (rewrite /native_repr eq_adj; move/eqP=> <-). 285 | apply/eqInt32P. 286 | move: i'; apply/(forallInt32P (fun i' => eq (land i i') (bitsToInt32 (andB (bitsFromInt32 i) (bitsFromInt32 i'))))). 287 | move=> i'; apply/eqInt32P. 288 | move: i; apply/forallInt32P; last by apply land_valid. 289 | move=> i'; apply idP. 290 | Qed. 291 | 292 | (** * Representation lemma: logical or *) 293 | 294 | Definition lor_test: bool 295 | := forallInt32 (fun i => 296 | forallInt32 (fun i' => 297 | native_repr (lor i i') (orB (bitsFromInt32 i) (bitsFromInt32 i')))). 298 | 299 | (* Validation condition: 300 | [lor "m" "n"] corresponds to machine [m lor n] *) 301 | Axiom lor_valid: lor_test. 302 | 303 | Lemma lor_repr: forall i i' bs bs', 304 | native_repr i bs -> native_repr i' bs' -> 305 | native_repr (lor i i') (orB bs bs'). 306 | Proof. 307 | move=> i i' ? ?. 308 | repeat (rewrite /native_repr eq_adj; move/eqP=> <-). 309 | apply/eqInt32P. 310 | move: i'; apply/(forallInt32P (fun i' => eq (lor i i') (bitsToInt32 (orB (bitsFromInt32 i) (bitsFromInt32 i'))))). 311 | move=> i'; apply/eqInt32P. 312 | move: i; apply/forallInt32P; last by apply lor_valid. 313 | move=> i'; apply idP. 314 | Qed. 315 | 316 | (** * Representation lemma: logical xor *) 317 | 318 | Definition lxor_test: bool 319 | := forallInt32 (fun i => 320 | forallInt32 (fun i' => 321 | native_repr (lxor i i') (xorB (bitsFromInt32 i) (bitsFromInt32 i')))). 322 | 323 | (* Validation condition: 324 | [lxor "m" "n"] corresponds to machine [m lxor n] *) 325 | Axiom lxor_valid: lxor_test. 326 | 327 | 328 | Lemma lxor_repr: forall i i' bs bs', 329 | native_repr i bs -> native_repr i' bs' -> 330 | native_repr (lxor i i') (xorB bs bs'). 331 | Proof. 332 | move=> i i' ? ?. 333 | repeat (rewrite /native_repr eq_adj; move/eqP=> <-). 334 | apply/eqInt32P. 335 | move: i'; apply/(forallInt32P (fun i' => eq (lxor i i') (bitsToInt32 (xorB (bitsFromInt32 i) (bitsFromInt32 i'))))). 336 | move=> i'; apply/eqInt32P. 337 | move: i; apply/forallInt32P; last by apply lxor_valid. 338 | move=> i'; apply idP. 339 | Qed. 340 | 341 | (** * Representation of naturals *) 342 | 343 | (** We extend the refinement relation (by composition) to natural 344 | numbers, going through a [BITS wordsize] word. *) 345 | 346 | Definition natural_repr (i: Int32)(n: nat): bool := 347 | [exists bs, native_repr i bs && (# n == bs)]. 348 | 349 | (** * Representation lemma: logical shift right *) 350 | 351 | Definition lsr_test: bool 352 | := forallInt32 (fun i => 353 | forallInt32 (fun i' => 354 | (toNat (bitsFromInt32 i') <= wordsize) ==> native_repr (lsr i i') (shrBn (bitsFromInt32 i) (toNat (bitsFromInt32 i'))))). 355 | 356 | (* Validation condition: 357 | [lsr "m" "n"] corresponds to machine [m lsr n] *) 358 | Axiom lsr_valid: lsr_test. 359 | 360 | Lemma lsr_repr: forall i j bs k, k <= wordsize -> 361 | native_repr i bs -> natural_repr j k -> 362 | native_repr (lsr i j) (shrBn bs k). 363 | Proof. 364 | move=> i i' ? k ltn_k. 365 | rewrite /native_repr eq_adj; move/eqP=> <-. 366 | rewrite /natural_repr. 367 | move/existsP=> [bs' /andP [H /eqP H']]. 368 | rewrite /native_repr eq_adj in H. 369 | move/eqP: H=> H. 370 | apply/eqInt32P. 371 | have Hk: k = toNat (bitsFromInt32 i'). 372 | rewrite H. 373 | have ->: k = toNat (fromNat (n := wordsize) k). 374 | rewrite toNat_fromNatBounded=> //. 375 | by apply (leq_ltn_trans (n := wordsize)). 376 | by rewrite H'. 377 | rewrite Hk. 378 | rewrite Hk in ltn_k. 379 | clear H H' Hk. 380 | move: i' ltn_k; apply/(forallInt32P (fun i' => (toNat (bitsFromInt32 i') <= wordsize) ==> (eq (lsr i i') (bitsToInt32 (shrBn (bitsFromInt32 i) (toNat ((bitsFromInt32 i')))))))). 381 | move=> i'. 382 | apply/equivP. 383 | apply/implyP. 384 | split=> H H'. 385 | move: (H H')=> H''. 386 | by apply/eqInt32P. 387 | move: (H H')=> H''. 388 | by apply/eqInt32P. 389 | move: i; apply/forallInt32P; last by apply lsr_valid. 390 | move=> i'; apply idP. 391 | Qed. 392 | 393 | (** * Representation lemma: logical shift left *) 394 | 395 | Definition lsl_test: bool 396 | := forallInt32 (fun i => 397 | forallInt32 (fun i' => 398 | (toNat (bitsFromInt32 i') <= wordsize) ==> native_repr (lsl i i') (shlBn (bitsFromInt32 i) (toNat (bitsFromInt32 i'))))). 399 | 400 | (* Validation condition: 401 | [lsl "m" "n"] corresponds to machine [m lsl n] *) 402 | Axiom lsl_valid: lsl_test. 403 | 404 | Lemma lsl_repr: forall i j bs k, k <= wordsize -> 405 | native_repr i bs -> natural_repr j k -> 406 | native_repr (lsl i j) (shlBn bs k). 407 | Proof. 408 | move=> i i' ? k ltn_k. 409 | rewrite /native_repr eq_adj; move/eqP=> <-. 410 | rewrite /natural_repr. 411 | move/existsP=> [bs' /andP [H /eqP H']]. 412 | rewrite /native_repr eq_adj in H. 413 | move/eqP: H=> H. 414 | apply/eqInt32P. 415 | have Hk: k = toNat (bitsFromInt32 i'). 416 | rewrite H. 417 | have ->: k = toNat (fromNat (n := wordsize) k). 418 | rewrite toNat_fromNatBounded=> //. 419 | by apply (leq_ltn_trans (n := wordsize)). 420 | by rewrite H'. 421 | rewrite Hk. 422 | rewrite Hk in ltn_k. 423 | clear H H' Hk. 424 | move: i' ltn_k; apply/(forallInt32P (fun i' => (toNat (bitsFromInt32 i') <= wordsize) ==> (eq (lsl i i') (bitsToInt32 (shlBn (bitsFromInt32 i) (toNat ((bitsFromInt32 i')))))))). 425 | move=> i'. 426 | apply/equivP. 427 | apply/implyP. 428 | split=> H H'. 429 | move: (H H')=> H''. 430 | by apply/eqInt32P. 431 | move: (H H')=> H''. 432 | by apply/eqInt32P. 433 | move: i; apply/forallInt32P; last by apply lsl_valid. 434 | move=> i'; apply idP. 435 | Qed. 436 | 437 | (** * Representation lemma: negation *) 438 | 439 | Definition neg_test: bool 440 | := forallInt32 (fun i => 441 | native_repr (neg i) (negB (bitsFromInt32 i))). 442 | 443 | (* Validation condition: 444 | [negB "m"] corresponds to machine [- m] *) 445 | Axiom neg_valid: neg_test. 446 | 447 | Lemma neg_repr: forall i bs, 448 | native_repr i bs -> native_repr (neg i) (negB bs). 449 | Proof. 450 | move=> i ?. 451 | rewrite /native_repr eq_adj. 452 | move/eqP=> <-. 453 | apply/eqInt32P. 454 | move: i; apply/forallInt32P; last by apply neg_valid. 455 | move=> i; apply/eqInt32P. 456 | Qed. 457 | 458 | (** * Representation lemma: decrement *) 459 | 460 | Definition dec_test: bool 461 | := forallInt32 (fun i => 462 | native_repr (dec i) (decB (bitsFromInt32 i))). 463 | 464 | (* Validation condition: 465 | [decB "m"] corresponds to machine [dec m] *) 466 | Axiom dec_valid: dec_test. 467 | 468 | Lemma dec_repr: forall i bs, 469 | native_repr i bs -> native_repr (dec i) (decB bs). 470 | Proof. 471 | move=> i ?. 472 | rewrite /native_repr eq_adj. 473 | move/eqP=> <-. 474 | apply/eqInt32P. 475 | move: i; apply/forallInt32P; last by apply dec_valid. 476 | move=> i; apply/eqInt32P. 477 | Qed. 478 | 479 | (** * Representation lemma: addition *) 480 | 481 | Definition add_test: bool 482 | := forallInt32 (fun i => 483 | forallInt32 (fun i' => 484 | native_repr (add i i') (addB (bitsFromInt32 i) (bitsFromInt32 i')))). 485 | 486 | (* Validation condition: 487 | [decB "m"] corresponds to machine [dec m] *) 488 | Axiom add_valid: add_test. 489 | 490 | Lemma add_repr: 491 | forall i i' bs bs', 492 | native_repr i bs -> native_repr i' bs' -> 493 | native_repr (add i i') (addB bs bs'). 494 | Proof. 495 | move=> i i' ? ?. 496 | repeat (rewrite /native_repr eq_adj; move/eqP=> <-). 497 | apply/eqInt32P. 498 | move: i'; apply/(forallInt32P (fun i' => eq (add i i') (bitsToInt32 (addB (bitsFromInt32 i) (bitsFromInt32 i'))))). 499 | move=> i'; apply/eqInt32P. 500 | move: i; apply/forallInt32P; last by apply add_valid. 501 | move=> i'; apply idP. 502 | Qed. 503 | 504 | (** Extract the tests: they should all return true! *) 505 | 506 | Require Import ExtrOcamlBasic. 507 | 508 | Definition allb s := foldr (andb) true s. 509 | 510 | Definition binop_tests x bitsX y bitsY := 511 | allb 512 | [:: (bitsX == bitsY) ==> (eq x y) ; 513 | native_repr (land x y) (andB bitsX bitsY) ; 514 | native_repr (lor x y) (orB bitsX bitsY) ; 515 | native_repr (lxor x y) (xorB bitsX bitsY) ; 516 | native_repr (add x y) (addB bitsX bitsY)]. 517 | 518 | Definition shift_tests x toNatX y bitsY := 519 | allb 520 | [:: native_repr (lsr y x) (shrBn bitsY toNatX) ; 521 | native_repr (lsl y x) (shlBn bitsY toNatX)]. 522 | 523 | Definition unop_tests x := 524 | let bitsX := bitsFromInt32 x in 525 | let toNatX := toNat bitsX in 526 | allb 527 | [:: native_repr (succ x) (incB bitsX) ; 528 | native_repr (lnot x) (invB bitsX) ; 529 | native_repr (neg x) (negB bitsX) ; 530 | native_repr (dec x) (decB bitsX) ; 531 | if (toNatX <= wordsize) then 532 | forallInt32 (fun y => 533 | let bitsY := bitsFromInt32 y in 534 | (binop_tests x bitsX y bitsY) && (shift_tests x toNatX y bitsY)) 535 | else 536 | forallInt32 (fun y => binop_tests x bitsX y (bitsFromInt32 y))]. 537 | 538 | Definition tests 539 | := allb 540 | [:: bitsToInt32K_test ; 541 | zero_test ; 542 | one_test ; 543 | forallInt32 544 | (fun x => unop_tests x)]. 545 | 546 | Lemma implies_unop : tests -> forall x, unop_tests x. 547 | move=> /andP [_ /andP [_ /andP[_ /andP [H _]]]] x. 548 | rewrite /succ_test. 549 | move: H=> /forallInt32P H. 550 | move: (H unop_tests)=> H'. 551 | apply H'=> x'. 552 | by apply idP. 553 | Qed. 554 | 555 | Lemma implies_binop : tests -> forall x y, binop_tests x (bitsFromInt32 x) y (bitsFromInt32 y). 556 | move => H x y. 557 | have H': unop_tests x by apply implies_unop. 558 | move: H'=> /andP [_ /andP [_ /andP [_ /andP [_ /andP [H1 _]]]]]. 559 | case Hc: (toNat (bitsFromInt32 x) <= wordsize); rewrite Hc in H1. 560 | have Hb: (binop_tests x (bitsFromInt32 x) y (bitsFromInt32 y)) && (shift_tests x (toNat (bitsFromInt32 x)) y (bitsFromInt32 y)). 561 | move: H1=> /forallInt32P H1. 562 | move: (H1 (fun y => (binop_tests x (bitsFromInt32 x) y (bitsFromInt32 y)) && (shift_tests x (toNat (bitsFromInt32 x)) y (bitsFromInt32 y))))=> H2. 563 | apply H2=> y'. 564 | by apply idP. 565 | by move: Hb=> /andP [-> _]. 566 | move: H1=> /forallInt32P H1. 567 | move: (H1 (fun y => binop_tests x (bitsFromInt32 x) y (bitsFromInt32 y)))=> H2. 568 | apply H2=> y'. 569 | by apply idP. 570 | Qed. 571 | 572 | Lemma implies_bitsToInt32K : tests -> bitsToInt32K_test. 573 | by move=> /andP [H _]. 574 | Qed. 575 | 576 | Lemma implies_bitsFromInt32_inj : tests -> bitsFromInt32_inj_test. 577 | move=> H. 578 | apply/forallInt32P=> x. 579 | apply idP. 580 | apply/forallInt32P=> y. 581 | apply idP. 582 | by move: (implies_binop H x y)=> /andP [-> _]. 583 | Qed. 584 | 585 | Lemma implies_zero : tests -> zero_test. 586 | by move=> /andP [_ /andP [H _]]. 587 | Qed. 588 | 589 | Lemma implies_one : tests -> one_test. 590 | by move=> /andP [_ /andP [_ /andP[H _]]]. 591 | Qed. 592 | 593 | Lemma implies_succ : tests -> succ_test. 594 | move=> H. 595 | apply/forallInt32P=> x. 596 | apply idP. 597 | have H': unop_tests x by apply implies_unop. 598 | by move: H'=> /andP [H1 _]. 599 | Qed. 600 | 601 | Lemma implies_lnot : tests -> lnot_test. 602 | move=> H. 603 | apply/forallInt32P=> x. 604 | apply idP. 605 | have H': unop_tests x by apply implies_unop. 606 | by move: H'=> /andP [_ /andP [H1 _]]. 607 | Qed. 608 | 609 | Lemma implies_land : tests -> land_test. 610 | move=> H. 611 | apply/forallInt32P=> x. 612 | apply idP. 613 | apply/forallInt32P=> y. 614 | apply idP. 615 | by move: (implies_binop H x y)=> /andP [_ /andP [-> _]]. 616 | Qed. 617 | 618 | Lemma implies_lor : tests -> lor_test. 619 | move=> H. 620 | apply/forallInt32P=> x. 621 | apply idP. 622 | apply/forallInt32P=> y. 623 | apply idP. 624 | by move: (implies_binop H x y)=> /andP [_ /andP [_ /andP [-> _]]]. 625 | Qed. 626 | 627 | Lemma implies_lxor : tests -> lxor_test. 628 | move=> H. 629 | apply/forallInt32P=> x. 630 | apply idP. 631 | apply/forallInt32P=> y. 632 | apply idP. 633 | by move: (implies_binop H x y)=> /andP [_ /andP [_ /andP [_ /andP [-> _]]]]. 634 | Qed. 635 | 636 | Lemma implies_shift : tests -> forall x y, toNat (bitsFromInt32 x) <= wordsize -> shift_tests x (toNat (bitsFromInt32 x)) y (bitsFromInt32 y). 637 | move => H x y Hlt. 638 | move: (implies_unop H x)=> /andP [_ /andP [_ /andP [_ /andP [_ /andP [H1 _]]]]]. 639 | rewrite Hlt in H1. 640 | have Hb: (binop_tests x (bitsFromInt32 x) y (bitsFromInt32 y)) && (shift_tests x (toNat (bitsFromInt32 x)) y (bitsFromInt32 y)). 641 | move: H1=> /forallInt32P H1. 642 | move: (H1 (fun y => (binop_tests x (bitsFromInt32 x) y (bitsFromInt32 y)) && (shift_tests x (toNat (bitsFromInt32 x)) y (bitsFromInt32 y))))=> H2. 643 | apply H2=> y'. 644 | by apply idP. 645 | by move: Hb=> /andP [_ ->]. 646 | Qed. 647 | 648 | Lemma implies_lsr : tests -> lsr_test. 649 | move=> H. 650 | apply/forallInt32P=> y. 651 | apply idP. 652 | apply/forallInt32P=> x. 653 | apply idP. 654 | apply/implyP=> H'. 655 | by move: (implies_shift H x y H')=> /andP [-> _]. 656 | Qed. 657 | 658 | Lemma implies_lsl : tests -> lsl_test. 659 | move=> H. 660 | apply/forallInt32P=> y. 661 | apply idP. 662 | apply/forallInt32P=> x. 663 | apply idP. 664 | apply/implyP=> H'. 665 | by move: (implies_shift H x y H')=> /andP [_ /andP [-> _]]. 666 | Qed. 667 | 668 | Lemma implies_neg : tests -> neg_test. 669 | move=> H. 670 | apply/forallInt32P=> x. 671 | apply idP. 672 | have H': unop_tests x by apply implies_unop. 673 | by move: H'=> /andP [_ /andP [_ /andP [H1 _]]]. 674 | Qed. 675 | 676 | Lemma implies_dec : tests -> dec_test. 677 | move=> H. 678 | apply/forallInt32P=> x. 679 | apply idP. 680 | have H': unop_tests x by apply implies_unop. 681 | by move: H'=> /andP [_ /andP [_ /andP [_ /andP [H1 _]]]]. 682 | Qed. 683 | 684 | Lemma implies_add : tests -> add_test. 685 | move=> H. 686 | apply/forallInt32P=> x. 687 | apply idP. 688 | apply/forallInt32P=> y. 689 | apply idP. 690 | by move: (implies_binop H x y)=> /andP [_ /andP [_ /andP [_ /andP [_ /andP [-> _]]]]]. 691 | Qed. 692 | 693 | Cd "src/extraction". 694 | Extraction "axioms32.ml" tests. 695 | Cd "../..". 696 | -------------------------------------------------------------------------------- /src/extraction/axioms8.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import ZArith.ZArith Extraction. 2 | From mathcomp Require Import ssreflect ssrfun ssrbool. 3 | From mathcomp Require Import eqtype ssrnat seq fintype tuple. 4 | From Bits Require Import bits. 5 | 6 | (* TODO: 7 | * Complete missing lemmas 8 | 9 | * Fix invalid extractions (addition is wrong on 63bits arch, for instance) 10 | 11 | * Define as a functor over wordsize (and forallInt) and 12 | instanciate at 8, 16, and 32 bits 13 | 14 | * Implement an efficient [forall] for bitvectors, prove 15 | equivalence with finType's forall. 16 | 17 | * Either get an efficient version of the tests below, or 18 | implement them in OCaml 19 | 20 | *) 21 | 22 | (** * An axiomatization of OCaml native integers *) 23 | 24 | 25 | Definition wordsize := 8. 26 | 27 | Axiom Int8: Type. 28 | Extract Inlined Constant Int8 => "int". 29 | 30 | 31 | (* Our trusted computing base sums up in these two operations and 32 | their associated reflection principles in Coq. *) 33 | 34 | Axiom forallInt8 : (Int8 -> bool) -> bool. 35 | Extract Inlined Constant forallInt8 => "Forall.forall_int8". 36 | 37 | Axiom eq: Int8 -> Int8 -> bool. 38 | Extract Inlined Constant eq => "(=)". 39 | 40 | Section Trust. 41 | 42 | (* Axiom 1: Equality of integer is embedded within Coq's propositional equality: *) 43 | Axiom eqInt8P : Equality.axiom eq. 44 | 45 | Definition viewP (P: pred Int8) (PP: Int8 -> Prop) := forall x, reflect (PP x) (P x). 46 | 47 | (* Axiom 2: If a property is true for all integers, then it is propositionally true *) 48 | Axiom forallInt8P : forall P PP, 49 | viewP P PP -> 50 | reflect (forall x, PP x) (forallInt8 (fun x => P x)). 51 | 52 | End Trust. 53 | 54 | (* All the axiomatized properties below are exhautively tested. *) 55 | 56 | Axiom zero : Int8. 57 | Extract Inlined Constant zero => "0". 58 | 59 | Axiom one : Int8. 60 | Extract Inlined Constant one => "1". 61 | 62 | Axiom succ : Int8 -> Int8. 63 | Extract Constant succ => "(fun x -> (x + 1) land 0xff)". 64 | 65 | Axiom lor: Int8 -> Int8 -> Int8. 66 | Extract Inlined Constant lor => "(lor)". 67 | 68 | Axiom lsl: Int8 -> Int8 -> Int8. 69 | Extract Inlined Constant lsl => "(fun x y -> (x lsl y) land 0xff)". 70 | 71 | Axiom land: Int8 -> Int8 -> Int8. 72 | Extract Inlined Constant land => "(land)". 73 | 74 | Axiom lt: Int8 -> Int8 -> bool. 75 | Extract Inlined Constant lt => "(<)". 76 | 77 | Axiom lsr: Int8 -> Int8 -> Int8. 78 | Extract Inlined Constant lsr => "(lsr)". 79 | 80 | Axiom neg: Int8 -> Int8. 81 | Extract Inlined Constant neg => "(fun x -> (-x) land 0xff)". 82 | 83 | Axiom lnot: Int8 -> Int8. 84 | Extract Inlined Constant lnot => "(fun x -> (lnot x) land 0xff)". 85 | 86 | Axiom lxor: Int8 -> Int8 -> Int8. 87 | Extract Inlined Constant lxor => "(lxor)". 88 | 89 | Axiom dec: Int8 -> Int8. 90 | Extract Constant dec => "(fun x -> (x - 1) land 0xff)". 91 | 92 | Axiom add: Int8 -> Int8 -> Int8. 93 | Extract Inlined Constant add => "(fun x y -> (x + y) land 0xff)". 94 | 95 | (* Conversion between machine integers and bit vectors *) 96 | 97 | Fixpoint PbitsToInt8 (p: seq bool): Int8 := 98 | match p with 99 | | true :: p => lor one (lsl (PbitsToInt8 p) one) 100 | | false :: p => lsl (PbitsToInt8 p) one 101 | | [::] => zero 102 | end. 103 | 104 | Definition bitsToInt8 (bs: BITS wordsize): Int8 := PbitsToInt8 bs. 105 | 106 | Fixpoint bitsFromInt8S (k: nat)(n: Int8): seq bool := 107 | match k with 108 | | 0 => [::] 109 | | k.+1 => 110 | let p := bitsFromInt8S k (lsr n one) in 111 | (eq (land n one) one) :: p 112 | end. 113 | 114 | Lemma bitsFromInt8P {k} (n: Int8): size (bitsFromInt8S k n) == k. 115 | Proof. 116 | elim: k n => // [k IH] n //=. 117 | rewrite eqSS //. 118 | Qed. 119 | 120 | Canonical bitsFromInt8 (n: Int8): BITS wordsize 121 | := Tuple (bitsFromInt8P n). 122 | 123 | (** * Cancelation of [bitsToInt8] on [bitsFromInt8] *) 124 | 125 | Definition bitsToInt8K_test: bool := 126 | [forall bs , bitsFromInt8 (bitsToInt8 bs) == bs ]. 127 | 128 | (* Validation condition: 129 | Experimentally, [bitsToInt8] must be cancelled by [bitsFromInt8] *) 130 | Axiom bitsToInt8K_valid: bitsToInt8K_test. 131 | 132 | Lemma bitsToInt8K: cancel bitsToInt8 bitsFromInt8. 133 | Proof. 134 | move=> bs; apply/eqP; move: bs. 135 | by apply/forallP: bitsToInt8K_valid. 136 | Qed. 137 | 138 | (** * Injectivity of [bitsFromInt8] *) 139 | 140 | Definition bitsFromInt8_inj_test: bool := 141 | forallInt8 (fun x => 142 | forallInt8 (fun y => 143 | (bitsFromInt8 x == bitsFromInt8 y) ==> (eq x y))). 144 | 145 | (* Validation condition: 146 | Experimentally, [bitsFromInt8] must be injective *) 147 | Axiom bitsFromInt8_inj_valid: bitsFromInt8_inj_test. 148 | 149 | Lemma bitsFromInt8_inj: injective bitsFromInt8. 150 | Proof. 151 | move=> x y /eqP H. 152 | apply/eqInt8P. 153 | move: H; apply/implyP. 154 | move: y; apply/(forallInt8P (fun y => (bitsFromInt8 x == bitsFromInt8 y) ==> eq x y)). 155 | move=> y; apply idP. 156 | move: x; apply/forallInt8P; last by apply bitsFromInt8_inj_valid. 157 | move=> x; apply idP. 158 | Qed. 159 | 160 | Lemma bitsFromInt8K: cancel bitsFromInt8 bitsToInt8. 161 | Proof. 162 | apply: inj_can_sym; auto using bitsToInt8K, bitsFromInt8_inj. 163 | Qed. 164 | 165 | (** * Bijection [Int8] vs. [BITS wordsize] *) 166 | 167 | Lemma bitsFromInt8_bij: bijective bitsFromInt8. 168 | Proof. 169 | split with (g := bitsToInt8); 170 | auto using bitsToInt8K, bitsFromInt8K. 171 | Qed. 172 | 173 | 174 | (** * Representation relation *) 175 | 176 | (** We say that an [n : Int8] is the representation of a bitvector 177 | [bs : BITS ] if they satisfy the axiom [repr_native]. Morally, it 178 | means that both represent the same number (ie. the same 179 | booleans). *) 180 | 181 | Definition native_repr (i: Int8)(bs: BITS wordsize): bool 182 | := eq i (bitsToInt8 bs). 183 | 184 | (** * Representation lemma: equality *) 185 | 186 | Lemma eq_adj: forall i bs, eq i (bitsToInt8 bs) = (bitsFromInt8 i == bs) . 187 | Proof. 188 | move=> i bs. 189 | apply/eqInt8P/eqP; intro; subst; 190 | auto using bitsFromInt8K, bitsToInt8K. 191 | Qed. 192 | 193 | Lemma eq_repr: 194 | forall i i' bs bs', 195 | native_repr i bs -> native_repr i' bs' -> 196 | (eq i i') = (bs == bs'). 197 | Proof. 198 | move=> i i' bs bs'. 199 | rewrite /native_repr. 200 | repeat (rewrite eq_adj; move/eqP=> <-). 201 | apply/eqInt8P/eqP; intro; subst; auto using bitsFromInt8_inj. 202 | Qed. 203 | 204 | (** * Representation lemma: individuals *) 205 | 206 | Definition zero_test: bool 207 | := eq zero (bitsToInt8 #0). 208 | 209 | (* Validation condition: 210 | bit vector [#0] corresponds to machine [0] *) 211 | Axiom zero_valid: zero_test. 212 | 213 | Lemma zero_repr: native_repr zero #0. 214 | Proof. apply zero_valid. Qed. 215 | 216 | Definition one_test: bool 217 | := eq one (bitsToInt8 #1). 218 | 219 | (* Validation condition: 220 | bit vector [#1] corresponds to machine [1] *) 221 | Axiom one_valid: one_test. 222 | 223 | Lemma one_repr: native_repr one #1. 224 | Proof. apply one_valid. Qed. 225 | 226 | (** * Representation lemma: successor *) 227 | 228 | Definition succ_test: bool 229 | := forallInt8 (fun i => 230 | native_repr (succ i) (incB (bitsFromInt8 i))). 231 | 232 | (* Validation condition: 233 | [succ "n"] corresponds to machine [n + 1] *) 234 | Axiom succ_valid: succ_test. 235 | 236 | Lemma succ_repr: forall i bs, 237 | native_repr i bs -> native_repr (succ i) (incB bs). 238 | Proof. 239 | move=> i ?. 240 | rewrite /native_repr eq_adj. 241 | move/eqP=> <-. 242 | apply/eqInt8P. 243 | move: i; apply/forallInt8P; last by apply succ_valid. 244 | move=> x; apply/eqInt8P. 245 | Qed. 246 | 247 | (** * Representation lemma: negation *) 248 | 249 | Definition lnot_test: bool 250 | := forallInt8 (fun i => 251 | native_repr (lnot i) (invB (bitsFromInt8 i))). 252 | 253 | (* Validation condition: 254 | [invB "n"] corresponds to machine [lnot n] *) 255 | Axiom lnot_valid: lnot_test. 256 | 257 | Lemma lnot_repr: forall i bs, 258 | native_repr i bs -> native_repr (lnot i) (invB bs). 259 | Proof. 260 | move=> i ?. 261 | rewrite /native_repr eq_adj. 262 | move/eqP=> <-. 263 | apply/eqInt8P. 264 | move: i; apply/forallInt8P; last by apply lnot_valid. 265 | move=> i; apply/eqInt8P. 266 | Qed. 267 | 268 | (** * Representation lemma: logical and *) 269 | 270 | Definition land_test: bool 271 | := forallInt8 (fun i => 272 | forallInt8 (fun i' => 273 | native_repr (land i i') (andB (bitsFromInt8 i) (bitsFromInt8 i')))). 274 | 275 | (* Validation condition: 276 | [land "m" "n"] corresponds to machine [m land n] *) 277 | Axiom land_valid: land_test. 278 | 279 | Lemma land_repr: forall i i' bs bs', 280 | native_repr i bs -> native_repr i' bs' -> 281 | native_repr (land i i') (andB bs bs'). 282 | Proof. 283 | move=> i i' ? ?. 284 | repeat (rewrite /native_repr eq_adj; move/eqP=> <-). 285 | apply/eqInt8P. 286 | move: i'; apply/(forallInt8P (fun i' => eq (land i i') (bitsToInt8 (andB (bitsFromInt8 i) (bitsFromInt8 i'))))). 287 | move=> i'; apply/eqInt8P. 288 | move: i; apply/forallInt8P; last by apply land_valid. 289 | move=> i'; apply idP. 290 | Qed. 291 | 292 | (** * Representation lemma: logical or *) 293 | 294 | Definition lor_test: bool 295 | := forallInt8 (fun i => 296 | forallInt8 (fun i' => 297 | native_repr (lor i i') (orB (bitsFromInt8 i) (bitsFromInt8 i')))). 298 | 299 | (* Validation condition: 300 | [lor "m" "n"] corresponds to machine [m lor n] *) 301 | Axiom lor_valid: lor_test. 302 | 303 | Lemma lor_repr: forall i i' bs bs', 304 | native_repr i bs -> native_repr i' bs' -> 305 | native_repr (lor i i') (orB bs bs'). 306 | Proof. 307 | move=> i i' ? ?. 308 | repeat (rewrite /native_repr eq_adj; move/eqP=> <-). 309 | apply/eqInt8P. 310 | move: i'; apply/(forallInt8P (fun i' => eq (lor i i') (bitsToInt8 (orB (bitsFromInt8 i) (bitsFromInt8 i'))))). 311 | move=> i'; apply/eqInt8P. 312 | move: i; apply/forallInt8P; last by apply lor_valid. 313 | move=> i'; apply idP. 314 | Qed. 315 | 316 | (** * Representation lemma: logical xor *) 317 | 318 | Definition lxor_test: bool 319 | := forallInt8 (fun i => 320 | forallInt8 (fun i' => 321 | native_repr (lxor i i') (xorB (bitsFromInt8 i) (bitsFromInt8 i')))). 322 | 323 | (* Validation condition: 324 | [lxor "m" "n"] corresponds to machine [m lxor n] *) 325 | Axiom lxor_valid: lxor_test. 326 | 327 | 328 | Lemma lxor_repr: forall i i' bs bs', 329 | native_repr i bs -> native_repr i' bs' -> 330 | native_repr (lxor i i') (xorB bs bs'). 331 | Proof. 332 | move=> i i' ? ?. 333 | repeat (rewrite /native_repr eq_adj; move/eqP=> <-). 334 | apply/eqInt8P. 335 | move: i'; apply/(forallInt8P (fun i' => eq (lxor i i') (bitsToInt8 (xorB (bitsFromInt8 i) (bitsFromInt8 i'))))). 336 | move=> i'; apply/eqInt8P. 337 | move: i; apply/forallInt8P; last by apply lxor_valid. 338 | move=> i'; apply idP. 339 | Qed. 340 | 341 | (** * Representation of naturals *) 342 | 343 | (** We extend the refinement relation (by composition) to natural 344 | numbers, going through a [BITS wordsize] word. *) 345 | 346 | Definition natural_repr (i: Int8)(n: nat): bool := 347 | [exists bs, native_repr i bs && (# n == bs)]. 348 | 349 | (** * Representation lemma: logical shift right *) 350 | 351 | Definition lsr_test: bool 352 | := forallInt8 (fun i => 353 | forallInt8 (fun i' => 354 | (toNat (bitsFromInt8 i') <= wordsize) ==> native_repr (lsr i i') (shrBn (bitsFromInt8 i) (toNat (bitsFromInt8 i'))))). 355 | 356 | (* Validation condition: 357 | [lsr "m" "n"] corresponds to machine [m lsr n] *) 358 | Axiom lsr_valid: lsr_test. 359 | 360 | Lemma lsr_repr: forall i j bs k, k <= wordsize -> 361 | native_repr i bs -> natural_repr j k -> 362 | native_repr (lsr i j) (shrBn bs k). 363 | Proof. 364 | move=> i i' ? k ltn_k. 365 | rewrite /native_repr eq_adj; move/eqP=> <-. 366 | rewrite /natural_repr. 367 | move/existsP=> [bs' /andP [H /eqP H']]. 368 | rewrite /native_repr eq_adj in H. 369 | move/eqP: H=> H. 370 | apply/eqInt8P. 371 | have Hk: k = toNat (bitsFromInt8 i'). 372 | rewrite H. 373 | have ->: k = toNat (fromNat (n := wordsize) k). 374 | rewrite toNat_fromNatBounded=> //. 375 | by apply (leq_ltn_trans (n := wordsize)). 376 | by rewrite H'. 377 | rewrite Hk. 378 | rewrite Hk in ltn_k. 379 | clear H H' Hk. 380 | move: i' ltn_k; apply/(forallInt8P (fun i' => (toNat (bitsFromInt8 i') <= wordsize) ==> (eq (lsr i i') (bitsToInt8 (shrBn (bitsFromInt8 i) (toNat ((bitsFromInt8 i')))))))). 381 | move=> i'. 382 | apply/equivP. 383 | apply/implyP. 384 | split=> H H'. 385 | move: (H H')=> H''. 386 | by apply/eqInt8P. 387 | move: (H H')=> H''. 388 | by apply/eqInt8P. 389 | move: i; apply/forallInt8P; last by apply lsr_valid. 390 | move=> i'; apply idP. 391 | Qed. 392 | 393 | (** * Representation lemma: logical shift left *) 394 | 395 | Definition lsl_test: bool 396 | := forallInt8 (fun i => 397 | forallInt8 (fun i' => 398 | (toNat (bitsFromInt8 i') <= wordsize) ==> native_repr (lsl i i') (shlBn (bitsFromInt8 i) (toNat (bitsFromInt8 i'))))). 399 | 400 | (* Validation condition: 401 | [lsl "m" "n"] corresponds to machine [m lsl n] *) 402 | Axiom lsl_valid: lsl_test. 403 | 404 | Lemma lsl_repr: forall i j bs k, k <= wordsize -> 405 | native_repr i bs -> natural_repr j k -> 406 | native_repr (lsl i j) (shlBn bs k). 407 | Proof. 408 | move=> i i' ? k ltn_k. 409 | rewrite /native_repr eq_adj; move/eqP=> <-. 410 | rewrite /natural_repr. 411 | move/existsP=> [bs' /andP [H /eqP H']]. 412 | rewrite /native_repr eq_adj in H. 413 | move/eqP: H=> H. 414 | apply/eqInt8P. 415 | have Hk: k = toNat (bitsFromInt8 i'). 416 | rewrite H. 417 | have ->: k = toNat (fromNat (n := wordsize) k). 418 | rewrite toNat_fromNatBounded=> //. 419 | by apply (leq_ltn_trans (n := wordsize)). 420 | by rewrite H'. 421 | rewrite Hk. 422 | rewrite Hk in ltn_k. 423 | clear H H' Hk. 424 | move: i' ltn_k; apply/(forallInt8P (fun i' => (toNat (bitsFromInt8 i') <= wordsize) ==> (eq (lsl i i') (bitsToInt8 (shlBn (bitsFromInt8 i) (toNat ((bitsFromInt8 i')))))))). 425 | move=> i'. 426 | apply/equivP. 427 | apply/implyP. 428 | split=> H H'. 429 | move: (H H')=> H''. 430 | by apply/eqInt8P. 431 | move: (H H')=> H''. 432 | by apply/eqInt8P. 433 | move: i; apply/forallInt8P; last by apply lsl_valid. 434 | move=> i'; apply idP. 435 | Qed. 436 | 437 | (** * Representation lemma: negation *) 438 | 439 | Definition neg_test: bool 440 | := forallInt8 (fun i => 441 | native_repr (neg i) (negB (bitsFromInt8 i))). 442 | 443 | (* Validation condition: 444 | [negB "m"] corresponds to machine [- m] *) 445 | Axiom neg_valid: neg_test. 446 | 447 | Lemma neg_repr: forall i bs, 448 | native_repr i bs -> native_repr (neg i) (negB bs). 449 | Proof. 450 | move=> i ?. 451 | rewrite /native_repr eq_adj. 452 | move/eqP=> <-. 453 | apply/eqInt8P. 454 | move: i; apply/forallInt8P; last by apply neg_valid. 455 | move=> i; apply/eqInt8P. 456 | Qed. 457 | 458 | (** * Representation lemma: decrement *) 459 | 460 | Definition dec_test: bool 461 | := forallInt8 (fun i => 462 | native_repr (dec i) (decB (bitsFromInt8 i))). 463 | 464 | (* Validation condition: 465 | [decB "m"] corresponds to machine [dec m] *) 466 | Axiom dec_valid: dec_test. 467 | 468 | Lemma dec_repr: forall i bs, 469 | native_repr i bs -> native_repr (dec i) (decB bs). 470 | Proof. 471 | move=> i ?. 472 | rewrite /native_repr eq_adj. 473 | move/eqP=> <-. 474 | apply/eqInt8P. 475 | move: i; apply/forallInt8P; last by apply dec_valid. 476 | move=> i; apply/eqInt8P. 477 | Qed. 478 | 479 | (** * Representation lemma: addition *) 480 | 481 | Definition add_test: bool 482 | := forallInt8 (fun i => 483 | forallInt8 (fun i' => 484 | native_repr (add i i') (addB (bitsFromInt8 i) (bitsFromInt8 i')))). 485 | 486 | (* Validation condition: 487 | [decB "m"] corresponds to machine [dec m] *) 488 | Axiom add_valid: add_test. 489 | 490 | Lemma add_repr: 491 | forall i i' bs bs', 492 | native_repr i bs -> native_repr i' bs' -> 493 | native_repr (add i i') (addB bs bs'). 494 | Proof. 495 | move=> i i' ? ?. 496 | repeat (rewrite /native_repr eq_adj; move/eqP=> <-). 497 | apply/eqInt8P. 498 | move: i'; apply/(forallInt8P (fun i' => eq (add i i') (bitsToInt8 (addB (bitsFromInt8 i) (bitsFromInt8 i'))))). 499 | move=> i'; apply/eqInt8P. 500 | move: i; apply/forallInt8P; last by apply add_valid. 501 | move=> i'; apply idP. 502 | Qed. 503 | 504 | (** Extract the tests: they should all return true! *) 505 | 506 | Require Import ExtrOcamlBasic. 507 | 508 | Definition allb s := foldr (andb) true s. 509 | 510 | Definition binop_tests x bitsX y bitsY := 511 | allb 512 | [:: (bitsX == bitsY) ==> (eq x y) ; 513 | native_repr (land x y) (andB bitsX bitsY) ; 514 | native_repr (lor x y) (orB bitsX bitsY) ; 515 | native_repr (lxor x y) (xorB bitsX bitsY) ; 516 | native_repr (add x y) (addB bitsX bitsY)]. 517 | 518 | Definition shift_tests x toNatX y bitsY := 519 | allb 520 | [:: native_repr (lsr y x) (shrBn bitsY toNatX) ; 521 | native_repr (lsl y x) (shlBn bitsY toNatX)]. 522 | 523 | Definition unop_tests x := 524 | let bitsX := bitsFromInt8 x in 525 | let toNatX := toNat bitsX in 526 | allb 527 | [:: native_repr (succ x) (incB bitsX) ; 528 | native_repr (lnot x) (invB bitsX) ; 529 | native_repr (neg x) (negB bitsX) ; 530 | native_repr (dec x) (decB bitsX) ; 531 | if (toNatX <= wordsize) then 532 | forallInt8 (fun y => 533 | let bitsY := bitsFromInt8 y in 534 | (binop_tests x bitsX y bitsY) && (shift_tests x toNatX y bitsY)) 535 | else 536 | forallInt8 (fun y => binop_tests x bitsX y (bitsFromInt8 y))]. 537 | 538 | Definition tests 539 | := allb 540 | [:: bitsToInt8K_test ; 541 | zero_test ; 542 | one_test ; 543 | forallInt8 544 | (fun x => unop_tests x)]. 545 | 546 | Lemma implies_unop : tests -> forall x, unop_tests x. 547 | move=> /andP [_ /andP [_ /andP[_ /andP [H _]]]] x. 548 | rewrite /succ_test. 549 | move: H=> /forallInt8P H. 550 | move: (H unop_tests)=> H'. 551 | apply H'=> x'. 552 | by apply idP. 553 | Qed. 554 | 555 | Lemma implies_binop : tests -> forall x y, binop_tests x (bitsFromInt8 x) y (bitsFromInt8 y). 556 | move => H x y. 557 | have H': unop_tests x by apply implies_unop. 558 | move: H'=> /andP [_ /andP [_ /andP [_ /andP [_ /andP [H1 _]]]]]. 559 | case Hc: (toNat (bitsFromInt8 x) <= wordsize); rewrite Hc in H1. 560 | have Hb: (binop_tests x (bitsFromInt8 x) y (bitsFromInt8 y)) && (shift_tests x (toNat (bitsFromInt8 x)) y (bitsFromInt8 y)). 561 | move: H1=> /forallInt8P H1. 562 | move: (H1 (fun y => (binop_tests x (bitsFromInt8 x) y (bitsFromInt8 y)) && (shift_tests x (toNat (bitsFromInt8 x)) y (bitsFromInt8 y))))=> H2. 563 | apply H2=> y'. 564 | by apply idP. 565 | by move: Hb=> /andP [-> _]. 566 | move: H1=> /forallInt8P H1. 567 | move: (H1 (fun y => binop_tests x (bitsFromInt8 x) y (bitsFromInt8 y)))=> H2. 568 | apply H2=> y'. 569 | by apply idP. 570 | Qed. 571 | 572 | Lemma implies_bitsToInt8K : tests -> bitsToInt8K_test. 573 | by move=> /andP [H _]. 574 | Qed. 575 | 576 | Lemma implies_bitsFromInt8_inj : tests -> bitsFromInt8_inj_test. 577 | move=> H. 578 | apply/forallInt8P=> x. 579 | apply idP. 580 | apply/forallInt8P=> y. 581 | apply idP. 582 | by move: (implies_binop H x y)=> /andP [-> _]. 583 | Qed. 584 | 585 | Lemma implies_zero : tests -> zero_test. 586 | by move=> /andP [_ /andP [H _]]. 587 | Qed. 588 | 589 | Lemma implies_one : tests -> one_test. 590 | by move=> /andP [_ /andP [_ /andP[H _]]]. 591 | Qed. 592 | 593 | Lemma implies_succ : tests -> succ_test. 594 | move=> H. 595 | apply/forallInt8P=> x. 596 | apply idP. 597 | have H': unop_tests x by apply implies_unop. 598 | by move: H'=> /andP [H1 _]. 599 | Qed. 600 | 601 | Lemma implies_lnot : tests -> lnot_test. 602 | move=> H. 603 | apply/forallInt8P=> x. 604 | apply idP. 605 | have H': unop_tests x by apply implies_unop. 606 | by move: H'=> /andP [_ /andP [H1 _]]. 607 | Qed. 608 | 609 | Lemma implies_land : tests -> land_test. 610 | move=> H. 611 | apply/forallInt8P=> x. 612 | apply idP. 613 | apply/forallInt8P=> y. 614 | apply idP. 615 | by move: (implies_binop H x y)=> /andP [_ /andP [-> _]]. 616 | Qed. 617 | 618 | Lemma implies_lor : tests -> lor_test. 619 | move=> H. 620 | apply/forallInt8P=> x. 621 | apply idP. 622 | apply/forallInt8P=> y. 623 | apply idP. 624 | by move: (implies_binop H x y)=> /andP [_ /andP [_ /andP [-> _]]]. 625 | Qed. 626 | 627 | Lemma implies_lxor : tests -> lxor_test. 628 | move=> H. 629 | apply/forallInt8P=> x. 630 | apply idP. 631 | apply/forallInt8P=> y. 632 | apply idP. 633 | by move: (implies_binop H x y)=> /andP [_ /andP [_ /andP [_ /andP [-> _]]]]. 634 | Qed. 635 | 636 | Lemma implies_shift : tests -> forall x y, toNat (bitsFromInt8 x) <= wordsize -> shift_tests x (toNat (bitsFromInt8 x)) y (bitsFromInt8 y). 637 | move => H x y Hlt. 638 | move: (implies_unop H x)=> /andP [_ /andP [_ /andP [_ /andP [_ /andP [H1 _]]]]]. 639 | rewrite Hlt in H1. 640 | have Hb: (binop_tests x (bitsFromInt8 x) y (bitsFromInt8 y)) && (shift_tests x (toNat (bitsFromInt8 x)) y (bitsFromInt8 y)). 641 | move: H1=> /forallInt8P H1. 642 | move: (H1 (fun y => (binop_tests x (bitsFromInt8 x) y (bitsFromInt8 y)) && (shift_tests x (toNat (bitsFromInt8 x)) y (bitsFromInt8 y))))=> H2. 643 | apply H2=> y'. 644 | by apply idP. 645 | by move: Hb=> /andP [_ ->]. 646 | Qed. 647 | 648 | Lemma implies_lsr : tests -> lsr_test. 649 | move=> H. 650 | apply/forallInt8P=> y. 651 | apply idP. 652 | apply/forallInt8P=> x. 653 | apply idP. 654 | apply/implyP=> H'. 655 | by move: (implies_shift H x y H')=> /andP [-> _]. 656 | Qed. 657 | 658 | Lemma implies_lsl : tests -> lsl_test. 659 | move=> H. 660 | apply/forallInt8P=> y. 661 | apply idP. 662 | apply/forallInt8P=> x. 663 | apply idP. 664 | apply/implyP=> H'. 665 | by move: (implies_shift H x y H')=> /andP [_ /andP [-> _]]. 666 | Qed. 667 | 668 | Lemma implies_neg : tests -> neg_test. 669 | move=> H. 670 | apply/forallInt8P=> x. 671 | apply idP. 672 | have H': unop_tests x by apply implies_unop. 673 | by move: H'=> /andP [_ /andP [_ /andP [H1 _]]]. 674 | Qed. 675 | 676 | Lemma implies_dec : tests -> dec_test. 677 | move=> H. 678 | apply/forallInt8P=> x. 679 | apply idP. 680 | have H': unop_tests x by apply implies_unop. 681 | by move: H'=> /andP [_ /andP [_ /andP [_ /andP [H1 _]]]]. 682 | Qed. 683 | 684 | Lemma implies_add : tests -> add_test. 685 | move=> H. 686 | apply/forallInt8P=> x. 687 | apply idP. 688 | apply/forallInt8P=> y. 689 | apply idP. 690 | by move: (implies_binop H x y)=> /andP [_ /andP [_ /andP [_ /andP [_ /andP [-> _]]]]]. 691 | Qed. 692 | 693 | Cd "src/extraction". 694 | Extraction "axioms8.ml" tests. 695 | Cd "../..". 696 | -------------------------------------------------------------------------------- /src/extraction/forall.ml: -------------------------------------------------------------------------------- 1 | exception TestFailure of int ;; 2 | 3 | let forall_int wordsize k = 4 | try 5 | for i = 0 to (1 lsl wordsize) - 1 do 6 | if (not (k i)) then 7 | raise (TestFailure i) 8 | done; 9 | true 10 | with (TestFailure i) -> Printf.printf "failed %d\n" i; false 11 | 12 | let forall_int8 = forall_int 8 13 | let forall_int16 = forall_int 16 14 | let forall_int32 = forall_int 32 15 | 16 | -------------------------------------------------------------------------------- /src/extraction/magic.patch: -------------------------------------------------------------------------------- 1 | 154c154 2 | < simplPred (fun _ -> true) 3 | --- 4 | > Obj.magic simplPred (fun _ -> true) 5 | -------------------------------------------------------------------------------- /src/extraction/verif.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" 3 | cd $DIR 4 | # Some handmade patching needed for unknown reasons 5 | patch axioms8.ml magic.patch 6 | patch axioms16.ml magic.patch 7 | 8 | echo "Verifying 8bit" 9 | ocamlbuild axioms8.native && ./axioms8.native 10 | echo "... Ok" 11 | echo "Verifying 16bit" 12 | ocamlbuild axioms16.native && ./axioms16.native 13 | echo "... Ok" 14 | cd - 15 | -------------------------------------------------------------------------------- /src/spec/operations.v: -------------------------------------------------------------------------------- 1 | (*=========================================================================== 2 | Arithmetic and logical operations on n-bit words 3 | For proofs of properties of operations see bitsopsprops.v 4 | ===========================================================================*) 5 | 6 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq tuple. 7 | Require Import spec. 8 | 9 | Set Implicit Arguments. 10 | Unset Strict Implicit. 11 | Import Prenex Implicits. 12 | 13 | (*--------------------------------------------------------------------------- 14 | Increment and decrement operations 15 | ---------------------------------------------------------------------------*) 16 | 17 | Notation eta_expand x := (fst x, snd x). 18 | 19 | Fixpoint incB {n} : BITS n -> BITS n := 20 | if n is n.+1 21 | then fun p => let (p,b) := eta_expand (splitlsb p) in 22 | if b then joinlsb (incB p, false) else joinlsb (p, true) 23 | else fun _ => nilB. 24 | 25 | Fixpoint decB {n} : BITS n -> BITS n := 26 | if n is _.+1 27 | then fun p => let (p,b) := eta_expand (splitlsb p) in 28 | if b then joinlsb (p, false) else joinlsb (decB p, true) 29 | else fun _ => nilB. 30 | 31 | (*--------------------------------------------------------------------------- 32 | Bitwise logical operations 33 | ---------------------------------------------------------------------------*) 34 | 35 | (* Lift a unary operation on booleans to one on n-bit values *) 36 | Definition liftUnOp {n} op (p: BITS n): BITS n := map_tuple op p. 37 | 38 | (* Lift a binary operation on booleans to one on n-bit values *) 39 | Definition liftBinOp {n} op (p1 p2: BITS n) : BITS n := 40 | map_tuple (fun pair => op pair.1 pair.2) (zip_tuple p1 p2). 41 | 42 | Definition invB {n} := liftUnOp (n:=n) negb. 43 | Definition andB {n} := liftBinOp (n:=n) andb. 44 | Definition orB {n} := liftBinOp (n:=n) orb. 45 | Definition xorB {n} := liftBinOp (n:=n) xorb. 46 | 47 | (* Negation (two's complement) *) 48 | Definition negB {n} (p: BITS n) := incB (invB p). 49 | 50 | (*--------------------------------------------------------------------------- 51 | Addition 52 | ---------------------------------------------------------------------------*) 53 | 54 | Definition fullAdder carry b1 b2 : bool * bool := 55 | match carry, b1, b2 with 56 | | false, false, false => (false, false) 57 | | true, false, false | false, true, false | false, false, true => (false, true) 58 | | true, true, false | false, true, true | true, false, true => (true, false) 59 | | true, true, true => (true, true) 60 | end. 61 | 62 | (* Add with carry, producing a word one bit larger than the inputs *) 63 | Fixpoint adcBmain n carry : BITS n -> BITS n -> BITS n.+1 := 64 | if n is _.+1 then 65 | fun p1 p2 => let (p1,b1) := eta_expand (splitlsb p1) in let (p2,b2) := eta_expand (splitlsb p2) in 66 | let (carry',b) := fullAdder carry b1 b2 in 67 | joinlsb (adcBmain carry' p1 p2, b) 68 | else fun _ _ => singleBit carry. 69 | 70 | Definition adcB {n} carry (p1 p2: BITS n) := splitmsb (adcBmain carry p1 p2). 71 | 72 | (* Add with carry=0 and ignore carry out *) 73 | Notation carry_addB p1 p2 := (adcB false p1 p2).1. 74 | Notation addB p1 p2 := (adcB false p1 p2).2. 75 | (* Take a page from ssreflect's book of ssrfun *) 76 | Notation "@ 'addB' n" := (fun p1 p2 : BITS n => addB p1 p2) 77 | (at level 10, n at level 8, only parsing) : function_scope. 78 | 79 | (*(** Don't simpl unless everything is a constructor. *) 80 | Global Arguments adcB {!n} !carry !p1 !p2 / .*) 81 | (** Don't ever simpl adcB *) 82 | Global Opaque adcB. 83 | 84 | (* Add with carry=0 and return None on overflow *) 85 | Definition addBovf n (p1 p2: BITS n) := 86 | if carry_addB p1 p2 then None else Some (addB p1 p2). 87 | 88 | Definition computeOverflow n (arg1 arg2 res: BITS n) := 89 | match (msb arg1,msb arg2,msb res) with 90 | | (true,true,false) | (false,false,true) => true | _ => false 91 | end. 92 | 93 | (* Some handy notation *) 94 | Notation "b +# n" := (addB b #n) (at level 50, left associativity). 95 | 96 | (*--------------------------------------------------------------------------- 97 | Subtraction 98 | ---------------------------------------------------------------------------*) 99 | 100 | Definition sbbB {n} borrow (arg1 arg2: BITS n) := 101 | let (carry, res) := eta_expand (adcB (~~borrow) arg1 (invB arg2)) in 102 | (~~carry, res). 103 | Notation carry_subB p1 p2 := (sbbB false p1 p2).1. 104 | Notation subB p1 p2 := (sbbB false p1 p2).2. 105 | Notation "@ 'subB' n" := (fun p1 p2 : BITS n => subB p1 p2) 106 | (at level 10, n at level 8, only parsing) : function_scope. 107 | 108 | (** Don't ever simpl [sbbB]. *) 109 | (*Global Arguments sbbB {!n} !borrow !arg1 !arg2 / .*) 110 | Global Opaque sbbB. 111 | 112 | Notation "b -# n" := (subB b #n) (at level 50, left associativity). 113 | 114 | (*--------------------------------------------------------------------------- 115 | Unsigned comparison 116 | ---------------------------------------------------------------------------*) 117 | Fixpoint ltB {n} : BITS n -> BITS n -> bool := 118 | if n is n.+1 119 | then fun p1 p2 => let (q1,b1) := eta_expand (splitlsb p1) in 120 | let (q2,b2) := eta_expand (splitlsb p2) in 121 | (ltB q1 q2 || ((q1 == q2) && (~~b1) && b2)) 122 | else fun p1 p2 => false. 123 | 124 | Definition leB {n} (p1 p2: BITS n) := ltB p1 p2 || (p1 == p2). 125 | 126 | (*--------------------------------------------------------------------------- 127 | Multiplication 128 | ---------------------------------------------------------------------------*) 129 | Fixpoint fullmulB n1 n2 : BITS n1 -> BITS n2 -> BITS (n1+n2) := 130 | if n1 is n.+1 return BITS n1 -> BITS n2 -> BITS (n1+n2) 131 | then (fun p1 p2 => let (p,b) := eta_expand (splitlsb p1) in 132 | if b then addB (joinlsb (fullmulB p p2, false)) (zeroExtendAux n.+1 p2) 133 | else joinlsb (fullmulB p p2, false)) 134 | else (fun p1 p2 => #0). 135 | 136 | Definition mulB {n} (p1 p2: BITS n) := 137 | low n (fullmulB p1 p2). 138 | 139 | Notation "b *# n" := (mulB b #n) (at level 40, left associativity). 140 | 141 | (*--------------------------------------------------------------------------- 142 | Shift and rotation operations 143 | ---------------------------------------------------------------------------*) 144 | 145 | (* Rotate right: lsb goes into msb, everything else gets shifted right *) 146 | Definition rorB {n} (p: BITS n.+1) : BITS n.+1 := let (p, b) := eta_expand (splitlsb p) in joinmsb (b, p). 147 | 148 | (* Rotate left: msb goes into lsb, everything else gets shifted left *) 149 | Definition rolB {n} (p: BITS n.+1) := let (b, p) := eta_expand (splitmsb p) in joinlsb (p, b). 150 | 151 | (* Shift right: shift everything right and put 0 in msb *) 152 | Definition shrB {n} : BITS n -> BITS n := 153 | if n is n.+1 then fun p => joinmsb0 (droplsb (n:=n) p) else fun p => nilB. 154 | Definition shrBn {n} (p: BITS n)(k: nat): BITS n := iter k shrB p. 155 | 156 | (* Arithmetic shift right: shift one bit to the right, copy msb *) 157 | Definition sarB {n} (p: BITS n.+1) := joinmsb (msb p, droplsb p). 158 | 159 | (* Lossless shift left: shift one bit to the left, put 0 in lsb *) 160 | Definition shlBaux {n} (p: BITS n) : BITS n.+1 := joinlsb (p, false). 161 | 162 | (* Shift left: shift one bit to the left, put 0 in lsb, lose msb *) 163 | Definition shlB {n} (p: BITS n) := dropmsb (shlBaux p). 164 | Definition shlBn {n} (p: BITS n)(k: nat): BITS n := iter k shlB p. 165 | 166 | (*--------------------------------------------------------------------------- 167 | Iteration and ranges 168 | ---------------------------------------------------------------------------*) 169 | 170 | (* Iteration *) 171 | Fixpoint bIter {n A} : BITS n -> (A -> A) -> A -> A := 172 | if n is m.+1 173 | then fun p f x => if p == zero _ then x 174 | else let (p,b) := eta_expand (splitlsb p) in 175 | if b then let r := bIter p f (f x) in bIter p f r 176 | else let r := bIter p f x in bIter p f r 177 | else fun p f x => x. 178 | 179 | Definition bIterFrom {n A} (p c: BITS n) (f: BITS n -> A -> A) x := 180 | let (p',r) := bIter c (fun pair : BITS n * A => let (p,r) := pair in (incB p, f p r)) (p,x) 181 | in r. 182 | 183 | (* Ranges *) 184 | Definition bIota {n} (p m: BITS n) : seq (BITS n) := rev (bIterFrom p m cons nil). 185 | Definition bRange {n} (p q: BITS n) := bIota p (subB q p). 186 | 187 | (*--------------------------------------------------------------------------- 188 | Notations 189 | ---------------------------------------------------------------------------*) 190 | 191 | Declare Scope bits_scope. 192 | 193 | Module BitsNotations. 194 | Infix "<<" := shlBn (at level 30, no associativity) : bits_scope. 195 | Infix ">>" := shrBn (at level 30, no associativity) : bits_scope. 196 | Infix "|" := orB (at level 40, left associativity) : bits_scope. 197 | Infix "&" := andB (at level 40, left associativity) : bits_scope. 198 | (*Infix "^" := xorB (at level 40, left associativity) : bits_scope.*) 199 | Notation "n + m" := (addB n m) : bits_scope. 200 | Notation "m .+1" := (incB m) : bits_scope. 201 | Notation "m .-1" := (decB m) : bits_scope. 202 | Notation "- m" := (negB m) : bits_scope. 203 | Notation "~ m" := (invB m) : bits_scope. 204 | End BitsNotations. 205 | 206 | Open Scope bits_scope. 207 | Delimit Scope bits_scope with bits. 208 | Bind Scope bits_scope with BITS. 209 | 210 | -------------------------------------------------------------------------------- /src/spec/spec.v: -------------------------------------------------------------------------------- 1 | (*=========================================================================== 2 | Basic representation of n-bit words 3 | 4 | We use n.-tuples of bools, as this gives decidable equality and finiteness 5 | for free. 6 | 7 | Tuples are practical for evaluation inside Coq, and so all operations on 8 | words can be evaluated using compute, cbv, etc. 9 | 10 | Proofs of various properties of bitvectors can be found in bitsprops.v 11 | Definitions of operations on bitvectors can be found in bitsops.v 12 | Proofs of properties of operations can be found in bitsopsprops.v 13 | ===========================================================================*) 14 | 15 | From Coq Require Import ZArith.ZArith Strings.String. 16 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype tuple zmodp. 17 | 18 | (* We represent n-bit words by a tuple of booleans, least-significant 19 | bit at the head DWORDorBYTE is especially useful for multi-mode 20 | instructions *) 21 | 22 | Definition BITS n := n.-tuple bool. 23 | 24 | (** We define aliases for various numbers, to speed up proofs. We use 25 | [.+1] to ensure convertibility after adding or subtracting 1. *) 26 | 27 | Definition n3 := 3. 28 | Definition n7 := 7. 29 | Definition n15 := 15. 30 | Definition n31 := 31. 31 | Definition n63 := 63. 32 | Arguments n3 : simpl never. 33 | Arguments n7 : simpl never. 34 | Arguments n15 : simpl never. 35 | Arguments n31 : simpl never. 36 | Arguments n63 : simpl never. 37 | Opaque n3 n7 n15 n31 n63. 38 | Notation n4 := n3.+1. 39 | Notation n8 := n7.+1. 40 | Notation n16 := n15.+1. 41 | Notation n32 := n31.+1. 42 | Notation n64 := n63.+1. 43 | Definition n24 := 24. 44 | Arguments n24 : simpl never. 45 | Opaque n24. 46 | Definition NIBBLE := BITS n4. 47 | 48 | (* Range of word sizes that we support for registers etc. *) 49 | Inductive OpSize := OpSize1 | OpSize2 | OpSize4 | OpSize8. 50 | 51 | Definition opSizeToNat s := 52 | match s with OpSize1 => 1 | OpSize2 => 2 | OpSize4 => 4 | OpSize8 => 8 end. 53 | 54 | Definition VWORD s := 55 | BITS (match s with OpSize1 => n8 | OpSize2 => n16 | OpSize4 => n32 | OpSize8 => n64 end). 56 | Definition BYTE := (VWORD OpSize1). 57 | Definition WORD := (VWORD OpSize2). 58 | Definition DWORD := (VWORD OpSize4). 59 | Definition QWORD := (VWORD OpSize8). 60 | 61 | 62 | Identity Coercion VWORDtoBITS : VWORD >-> BITS. 63 | Identity Coercion BYTEtoVWORD : BYTE >-> VWORD. 64 | Identity Coercion WORDtoVWORD : WORD >-> VWORD. 65 | Identity Coercion DWORDtoVWORD : DWORD >-> VWORD. 66 | Identity Coercion QWORDtoVWORD : QWORD >-> VWORD. 67 | 68 | (* Construction *) 69 | Notation "'nilB'" := (nil_tuple _). 70 | Definition consB {n} (b:bool) (p: BITS n) : BITS n.+1 := cons_tuple b p. 71 | Definition joinlsb {n} (pair: BITS n*bool) : BITS n.+1 := cons_tuple pair.2 pair.1. 72 | 73 | (* Destruction *) 74 | Definition splitlsb {n} (p: BITS n.+1): BITS n*bool := (behead_tuple p, thead p). 75 | Definition droplsb {n} (p: BITS n.+1) := (splitlsb p).1. 76 | 77 | (*--------------------------------------------------------------------------- 78 | Conversion to and from natural numbers. 79 | 80 | For large naturals, be careful to use ssrnat's Num and [Num of] constructs 81 | for creating and printing naturals. 82 | ---------------------------------------------------------------------------*) 83 | Fixpoint fromNat {n} m : BITS n := 84 | if n is _.+1 85 | then joinlsb (fromNat m./2, odd m) 86 | else nilB. 87 | Notation "# m" := (fromNat m) (at level 0). 88 | Arguments fromNat n m : simpl never. 89 | 90 | Definition toNat {n} (p: BITS n) := foldr (fun (b:bool) n => b + n.*2) 0 p. 91 | 92 | Coercion natAsQWORD := @fromNat _ : nat -> QWORD. 93 | Coercion natAsDWORD := @fromNat _ : nat -> DWORD. 94 | Coercion natAsWORD := @fromNat _ : nat -> WORD. 95 | Coercion natAsBYTE := @fromNat _ : nat -> BYTE. 96 | 97 | (*--------------------------------------------------------------------------- 98 | All bits identical 99 | ---------------------------------------------------------------------------*) 100 | Definition copy n b : BITS n := nseq_tuple n b. 101 | Definition zero n := copy n false. 102 | Definition ones n := copy n true. 103 | 104 | (*--------------------------------------------------------------------------- 105 | Concatenation and splitting of bit strings 106 | ---------------------------------------------------------------------------*) 107 | 108 | (* Most and least significant bits, defaulting to 0 *) 109 | Definition msb {n} (b: BITS n) := last false b. 110 | Definition lsb {n} (b: BITS n) := head false b. 111 | 112 | Definition catB {n1 n2} (p1: BITS n1) (p2: BITS n2) : BITS (n2+n1) := 113 | cat_tuple p2 p1. 114 | Notation "y ## x" := (catB y x) (right associativity, at level 60). 115 | 116 | (* The n high bits *) 117 | Fixpoint high n {n2} : BITS (n2+n) -> BITS n := 118 | if n2 is _.+1 then fun p => let (p,b) := splitlsb p in high _ p else fun p => p. 119 | 120 | (* The n low bits *) 121 | Fixpoint low {n1} n : BITS (n+n1) -> BITS n := 122 | if n is _.+1 then fun p => let (p,b) := splitlsb p in joinlsb (low _ p, b) 123 | else fun p => nilB. 124 | 125 | (* n1 high and n2 low bits *) 126 | Definition split2 n1 n2 p := (high n1 p, low n2 p). 127 | 128 | Definition split3 n1 n2 n3 (p: BITS (n3+n2+n1)) : BITS n1 * BITS n2 * BITS n3 := 129 | let (hi,lo) := split2 n1 _ p in 130 | let (lohi,lolo) := split2 n2 _ lo in (hi,lohi,lolo). 131 | 132 | Definition split4 n1 n2 n3 n4 (p: BITS (n4+n3+n2+n1)): BITS n1 * BITS n2 * BITS n3 * BITS n4 := 133 | let (b1,rest) := split2 n1 _ p in 134 | let (b2,rest) := split2 n2 _ rest in 135 | let (b3,b4) := split2 n3 _ rest in (b1,b2,b3,b4). 136 | 137 | (* Sign extend by {extra} bits *) 138 | Definition signExtend extra {n} (p: BITS n.+1) := copy extra (msb p) ## p. 139 | 140 | (* Truncate a signed integer by {extra} bits; return None if this would overflow *) 141 | Definition signTruncate extra {n} (p: BITS (n.+1 + extra)) : option (BITS n.+1) := 142 | let (hi,lo) := split2 extra _ p in 143 | if msb lo && (hi == ones _) || negb (msb lo) && (hi == zero _) 144 | then Some lo 145 | else None. 146 | 147 | (* Zero extend by {extra} bits *) 148 | Definition zeroExtend extra {n} (p: BITS n) := zero extra ## p. 149 | (* 150 | Coercion DWORDtoQWORD := zeroExtend (n:=32) 32 : DWORD -> QWORD. 151 | Coercion WORDtoDWORD := zeroExtend (n:=16) 16 : WORD -> DWORD. 152 | Coercion BYTEtoDWORD := zeroExtend (n:=8) 24 : BYTE -> DWORD. 153 | *) 154 | 155 | (* Take m least significant bits of n-bit argument and fill with zeros if m>n *) 156 | Fixpoint lowWithZeroExtend m {n} : BITS n -> BITS m := 157 | if n is _.+1 158 | then fun p => let (p,b) := splitlsb p in 159 | if m is m'.+1 then joinlsb (@lowWithZeroExtend m' _ p, b) 160 | else zero 0 161 | else fun p => zero m. 162 | 163 | (* Truncate an unsigned integer by {extra} bits; return None if this would overflow *) 164 | Definition zeroTruncate extra {n} (p: BITS (n + extra)) : option (BITS n) := 165 | let (hi,lo) := split2 extra _ p in 166 | if hi == zero _ then Some lo else None. 167 | 168 | (* Special case: split at the most significant bit. 169 | split 1 n doesn't work because it requires BITS (n+1) not BITS n.+1 *) 170 | Fixpoint splitmsb {n} : BITS n.+1 -> bool * BITS n := 171 | if n is _.+1 172 | then fun p => let (p,b) := splitlsb p in let (c,r) := splitmsb p in (c,joinlsb(r,b)) 173 | else fun p => let (p,b) := splitlsb p in (b,p). 174 | Definition dropmsb {n} (p: BITS n.+1) := (splitmsb p).2. 175 | 176 | (* Extend by one bit at the most significant bit. Again, signExtend 1 n does not work 177 | because BITS (n+1) is not definitionally equal to BITS n.+1 *) 178 | Fixpoint joinmsb {n} : bool * BITS n -> BITS n.+1 := 179 | if n is _.+1 180 | then fun p => let (hibit, p) := p in 181 | let (p,b) := splitlsb p in joinlsb (joinmsb (hibit, p), b) 182 | else fun p => joinlsb (nilB, p.1). 183 | Definition joinmsb0 {n} (p: BITS n) : BITS n.+1 := joinmsb (false,p). 184 | 185 | Fixpoint zeroExtendAux extra {n} (p: BITS n) : BITS (extra+n) := 186 | if extra is e.+1 then joinmsb0 (zeroExtendAux e p) else p. 187 | 188 | Definition joinNibble {n} (p:NIBBLE) (q: BITS n) : BITS (n.+4) := 189 | let (p1,b0) := splitlsb p in 190 | let (p2,b1) := splitlsb p1 in 191 | let (p3,b2) := splitlsb p2 in 192 | let (p4,b3) := splitlsb p3 in 193 | joinmsb (b3, joinmsb (b2, joinmsb (b1, joinmsb (b0, q)))). 194 | 195 | Notation "y ## x" := (catB y x) (right associativity, at level 60). 196 | 197 | (* Slice of bits *) 198 | (* 199 | Definition slice n n1 n2 (p: BITS (n+(n1+n2))) := low n1 (high (n1+n2) p). 200 | *) 201 | 202 | Definition slice n n1 n2 (p: BITS (n+n1+n2)) : BITS n1 := 203 | let: (a,b,c) := split3 n2 n1 n p in b. 204 | 205 | Definition updateSlice n n1 n2 (p: BITS (n+n1+n2)) (m:BITS n1) : BITS (n+n1+n2) := 206 | let: (a,b,c) := split3 n2 n1 n p in a ## m ## c. 207 | 208 | (* Little-endian conversion of n-tuples of bytes (first component is least significant) 209 | into BITS (n*8) *) 210 | Fixpoint seqBytesToBits (xs : seq BYTE) : BITS (size xs*8) := 211 | if xs is x::xs' return BITS (size xs*8) then seqBytesToBits xs' ## x 212 | else nilB. 213 | 214 | Fixpoint bytesToBits {n} : (n.-tuple BYTE) -> BITS (n*8) := 215 | if n is n'.+1 return n.-tuple BYTE -> BITS (n*8) 216 | then fun xs => bytesToBits (behead_tuple xs) ## (thead xs) 217 | else fun xs => nilB. 218 | 219 | Definition splitAtByte n (bits : BITS ((n.+1)*8)) :BITS (n*8) * BYTE := (split2 (n*8) 8 bits). 220 | 221 | Fixpoint bitsToBytes n : BITS (n*8) -> n.-tuple BYTE := 222 | if n is n'.+1 return BITS (n*8) -> n.-tuple BYTE 223 | then fun xs => 224 | let (hi,lo) := splitAtByte n' xs in cons_tuple lo (bitsToBytes _ hi) 225 | else fun xs => nil_tuple _. 226 | 227 | (*--------------------------------------------------------------------------- 228 | Single bit operations 229 | ---------------------------------------------------------------------------*) 230 | 231 | (* Booleans are implicitly coerced to one-bit words, useful in combination with ## *) 232 | Coercion singleBit b : BITS 1 := joinlsb (nilB, b). 233 | 234 | (* Get bit i, counting 0 as least significant *) 235 | (* For some reason tnth is not efficiently computable, so we use nth *) 236 | Definition getBit {n} (p: BITS n) (i:nat) := nth false p i. 237 | 238 | (* Set bit i to b *) 239 | Fixpoint setBitAux {n} i b : BITS n -> BITS n := 240 | if n is _.+1 241 | then fun p => let (p,oldb) := splitlsb p in 242 | if i is i'.+1 then joinlsb (setBitAux i' b p, oldb) else joinlsb (p,b) 243 | else fun p => nilB. 244 | 245 | Definition setBit {n} (p: BITS n) i b := setBitAux i b p. 246 | 247 | (*--------------------------------------------------------------------------- 248 | Efficient conversion to and from Z 249 | ---------------------------------------------------------------------------*) 250 | 251 | Definition toPosZ {n} (p: BITS n) := 252 | foldr (fun b z => if b then Z.succ (Z.double z) else Z.double z) Z0 p. 253 | 254 | Definition toNegZ {n} (p: BITS n) := 255 | foldr (fun b z => if b then Z.double z else Z.succ (Z.double z)) Z0 p. 256 | 257 | Definition toZ {n} (bs: BITS n.+1) := 258 | match splitmsb bs with 259 | | (false, bs') => toPosZ bs' 260 | | (true, bs') => Z.opp (Z.succ (toNegZ bs')) 261 | end. 262 | 263 | Fixpoint fromPosZ {n} (z: Z): BITS n := 264 | if n is _.+1 265 | then joinlsb (fromPosZ (Z.div2 z), negb (Zeven_bool z)) 266 | else nilB. 267 | 268 | Fixpoint fromNegZ {n} (z: Z): BITS n := 269 | if n is _.+1 270 | then joinlsb (fromNegZ (Z.div2 z), Zeven_bool z) 271 | else nilB. 272 | 273 | Definition fromZ {n} (z:Z) : BITS n := 274 | match z with 275 | | Zpos _ => fromPosZ z 276 | | Zneg _ => fromNegZ (Z.pred (Z.opp z)) 277 | | _ => zero _ 278 | end. 279 | 280 | (*--------------------------------------------------------------------------- 281 | Conversion to and from 'Z_(2^n) 282 | ---------------------------------------------------------------------------*) 283 | 284 | Definition toZp {n} (p: BITS n) : 'Z_(2^n) := inZp (toNat p). 285 | Definition fromZp {n} (z: 'Z_(2^n)) : BITS n := fromNat z. 286 | 287 | Definition bool_inZp m (b:bool): 'Z_m := inZp b. 288 | Definition toZpAux {m n} (p:BITS n) : 'Z_(2^m) := inZp (toNat p). 289 | 290 | 291 | (*--------------------------------------------------------------------------- 292 | Support for hexadecimal notation 293 | ---------------------------------------------------------------------------*) 294 | Section HexStrings. 295 | Import Ascii. 296 | 297 | Definition charToNibble c : NIBBLE := 298 | fromNat (findex 0 (String c EmptyString) "0123456789ABCDEF0123456789abcdef"). 299 | Definition charToBit c : bool := ascii_dec c "1". 300 | 301 | (*=fromBin *) 302 | Fixpoint fromBin s : BITS (length s) := 303 | if s is String c s 304 | then joinmsb (charToBit c, fromBin s) else #0. 305 | (*=End *) 306 | 307 | (*=fromHex *) 308 | Fixpoint fromHex s : BITS (length s * 4) := 309 | if s is String c s 310 | then joinNibble (charToNibble c) (fromHex s) else #0. 311 | (*=End *) 312 | 313 | Fixpoint fromString s : BITS (length s * 8) := 314 | if s is String c s return BITS (length s * 8) 315 | then fromString s ## fromNat (n:=8) (nat_of_ascii c) else nilB. 316 | 317 | Definition nibbleToChar (n: NIBBLE) := 318 | match String.get (toNat n) "0123456789ABCDEF" with None => " "%char | Some c => c end. 319 | 320 | Definition appendNibbleOnString n s := 321 | (s ++ String.String (nibbleToChar n) EmptyString)%string. 322 | 323 | End HexStrings. 324 | 325 | Fixpoint toHex {n} := 326 | match n return BITS n -> string with 327 | | 0 => fun bs => EmptyString 328 | | 1 => fun bs => appendNibbleOnString (zero 3 ## bs) EmptyString 329 | | 2 => fun bs => appendNibbleOnString (zero 2 ## bs) EmptyString 330 | | 3 => fun bs => appendNibbleOnString (zero 1 ## bs) EmptyString 331 | | _ => fun bs => let (hi,lo) := split2 _ 4 bs in appendNibbleOnString lo (toHex hi) 332 | end. 333 | 334 | Import Ascii. 335 | (*Fixpoint bytesToHex (b: seq BYTE) := 336 | if b is b::bs then 337 | String.String (nibbleToChar (high (n2:=4) 4 b)) ( 338 | String.String (nibbleToChar (low 4 b)) ( 339 | String.String (" "%char) ( 340 | bytesToHex bs))) 341 | else ""%string. 342 | *) 343 | 344 | Fixpoint bytesToHexAux (b: seq BYTE) res := 345 | match b with b::bs => 346 | bytesToHexAux bs (String.String (nibbleToChar (high (n2:=4) 4 b)) ( 347 | String.String (nibbleToChar (low 4 b)) ( 348 | String.String (" "%char) res))) 349 | | nil => res end. 350 | 351 | Definition bytesToHex b := bytesToHexAux (rev b) ""%string. 352 | 353 | (* Convert an ASCII character (from the standard Coq library) to a BYTE *) 354 | Definition charToBYTE (c: ascii) : BYTE := 355 | let (a0,a1,a2,a3,a4,a5,a6,a7) := c in 356 | [tuple a0;a1;a2;a3;a4;a5;a6;a7]. 357 | 358 | (* Convert an ASCII string to a tuple of BYTEs... *) 359 | Fixpoint stringToTupleBYTE (s: string) : (length s).-tuple BYTE := 360 | if s is String c s then cons_tuple (charToBYTE c) (stringToTupleBYTE s) 361 | else nil_tuple _. 362 | 363 | (* ...which is easily coerced to a sequence *) 364 | Definition stringToSeqBYTE (s: string) : seq BYTE := 365 | stringToTupleBYTE s. 366 | 367 | (* Notation for hex, binary, and character/string *) 368 | Notation "#x y" := (fromHex y) (at level 0). 369 | Notation "#b y" := (fromBin y) (at level 0). 370 | Notation "#c y" := (fromString y : BYTE) (at level 0). 371 | 372 | 373 | Example fortytwo := #42 : BYTE. 374 | Example fortytwo1 := #x"2A". 375 | Example fortytwo2 := #b"00101010". 376 | Example fortytwo3 := #c"*". 377 | 378 | -------------------------------------------------------------------------------- /src/spec/spec/properties.v: -------------------------------------------------------------------------------- 1 | (*=========================================================================== 2 | Properties of bit vectors 3 | ===========================================================================*) 4 | From Coq Require Import ZArith.ZArith. 5 | (*Require Import common.tuplehelp common.nathelp.*) 6 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype tuple div zmodp ssralg. 7 | From mathcomp Require Import ring. 8 | Require Import ssrextra.nat ssrextra.tuple. 9 | Require Import spec.spec. 10 | 11 | Set Implicit Arguments. 12 | Unset Strict Implicit. 13 | Import Prenex Implicits. 14 | 15 | Lemma trivialBits (p q: BITS 0) : p = q. 16 | Proof. by rewrite (tuple0 p) (tuple0 q). Qed. 17 | 18 | (*--------------------------------------------------------------------------- 19 | Properties of conversion to and from natural numbers. 20 | ---------------------------------------------------------------------------*) 21 | Lemma toNatCons n b (p:BITS n) : toNat (consB b p) = b + (toNat p).*2. 22 | Proof. done. Qed. 23 | 24 | Lemma toNatNil (p:BITS 0) : toNat p = 0. 25 | Proof. by rewrite (tuple0 p). Qed. 26 | 27 | (* toNat is left-inverse to fromNat *) 28 | Lemma toNatK n : cancel (@toNat n) (@fromNat n). 29 | Proof. induction n; first (move => p; apply trivialBits). 30 | + case/tupleP => b x. rewrite toNatCons/fromNat-/fromNat /= half_bit_double. 31 | rewrite IHn oddD odd_double. by case b. 32 | Qed. 33 | 34 | (* Hence toNat is injective *) 35 | Definition toNat_inj n := can_inj (@toNatK n). 36 | 37 | (* toNat result is bounded *) 38 | Lemma toNatBounded n : forall (p: BITS n), toNat p < 2^n. 39 | Proof. induction n. move => p. by rewrite toNatNil. 40 | case/tupleP => [b p]. 41 | rewrite expnS mul2n toNatCons. 42 | case b. 43 | + rewrite ltn_Sdouble. apply IHn. 44 | + rewrite ltn_double. apply IHn. 45 | Qed. 46 | 47 | Lemma toNat_fromNatBounded n : forall m, m < 2^n -> toNat (fromNat (n:=n) m) = m. 48 | Proof. induction n. 49 | + rewrite expn0. by case. 50 | + rewrite expnS. move => m. specialize (IHn m./2). 51 | move => LT. 52 | assert (m./2 < 2^n). 53 | rewrite -ltn_double. rewrite -(odd_double_half m) mul2n in LT. 54 | rewrite -(ltn_add2l (odd m)). 55 | by apply ltn_addl. 56 | specialize (IHn H). 57 | rewrite /toNat-/toNat/=. 58 | rewrite /toNat/= in IHn. rewrite IHn. 59 | by rewrite odd_double_half. 60 | Qed. 61 | 62 | Lemma fromNatBounded_eq m1 m2 n : m1 < 2^n -> m2 < 2^n -> 63 | (m1==m2) = (fromNat (n:=n) m1 == fromNat m2). 64 | Proof. move => B1 B2. 65 | case E: (m1 == m2); 66 | case E': (#m1 == #m2) => //. by rewrite (eqP E) eq_refl in E'. 67 | rewrite -(toNat_fromNatBounded B1) -(toNat_fromNatBounded B2) in E. 68 | by rewrite (eqP E') eq_refl in E. 69 | Qed. 70 | 71 | Lemma fromNatHalf n m : cons_tuple (odd m) (fromNat (n:=n) m./2) = fromNat m. 72 | Proof. done. Qed. 73 | 74 | Lemma fromNat_wrap n : forall m, fromNat (n:=n) m = fromNat (n:=n) (m + 2^n). 75 | Proof. induction n => //. 76 | rewrite expnS. 77 | move => m. 78 | case ODD: (odd m); rewrite /fromNat-/fromNat /=ODD oddD oddM/=ODD/= halfD ODD/=. 79 | specialize (IHn m./2). by rewrite oddM/= add0n mul2n doubleK IHn. 80 | specialize (IHn m./2). by rewrite add0n mul2n doubleK IHn. 81 | Qed. 82 | 83 | Lemma fromNat_wrapMany n c : forall m, fromNat (n:=n) m = fromNat (n:=n) (m + c * 2^n). 84 | Proof. induction c => m. by rewrite mul0n addn0. 85 | rewrite mulSn (addnC (2^n)) addnA fromNat_wrap. rewrite IHc. 86 | by rewrite -addnA (addnC (2^n)) addnA. 87 | Qed. 88 | 89 | Lemma toNat_mod n (p:BITS n): toNat p = toNat p %% 2^n. 90 | Proof. rewrite modn_small => //. apply toNatBounded. Qed. 91 | 92 | Lemma toNat_fromNat n m : @toNat n (fromNat m) = m %% 2^n. 93 | Proof. have H:= divn_eq m (2^n). rewrite {1}H. 94 | have HH:= @fromNat_wrapMany n (m %/ 2^n) (m %% 2^n). rewrite addnC in HH. rewrite -HH. 95 | rewrite toNat_fromNatBounded. done. apply ltn_pmod. apply expn_gt0. Qed. 96 | 97 | (* TODO: remove *) 98 | Lemma splitTuple {X n} {a b:X} {c d:n.-tuple X} : cons_tuple a c = cons_tuple b d -> a = b /\ c = d. 99 | Proof. move => H. split. by inversion H. apply val_inj. by inversion H. Qed. 100 | 101 | 102 | Lemma fromNat_succn n : forall b c, @fromNat n b = fromNat c -> @fromNat n (b.+1) = fromNat(c.+1). 103 | Proof. induction n => //. 104 | move => b c EQ. rewrite /fromNat-/fromNat. rewrite /fromNat-/fromNat in EQ. 105 | elim: (splitTuple EQ) => [EQ1 EQ2]. simpl in EQ1. simpl in EQ2. 106 | specialize (IHn _ _ EQ2). rewrite/= !uphalf_half /=EQ1. 107 | case ODD: (odd c). + by rewrite !add1n IHn. + by rewrite !add0n EQ2. 108 | Qed. 109 | 110 | Lemma fromNat_addn n : forall a b c, @fromNat n b = fromNat c -> @fromNat n (a+b) = fromNat(a+c). 111 | Proof. induction a => //. 112 | move => b c EQ. rewrite -addn1 -!addnA !add1n. apply IHa. by apply fromNat_succn. 113 | Qed. 114 | 115 | Lemma toZp_fromNat n m : toZp (fromNat (n:=n.+1) m) = (m%:R)%R. 116 | Proof. apply val_inj. 117 | rewrite /toZp toNat_fromNat Zp_nat. 118 | rewrite /=Zp_cast; last apply pow2_gt1. 119 | by rewrite modn_mod. 120 | Qed. 121 | 122 | Lemma toZpAux_fromNat n c : toZpAux (m:=n.+1) (fromNat (n:=n.+1) c) = (c%:R)%R. 123 | Proof. apply val_inj. 124 | rewrite /toZpAux toNat_fromNat Zp_nat. 125 | rewrite /=Zp_cast; last apply pow2_gt1. 126 | by rewrite modn_mod. 127 | Qed. 128 | 129 | #[export] 130 | Hint Rewrite toZp_fromNat toZpAux_fromNat : ZpHom. 131 | 132 | Lemma toNat_droplsb n (p: BITS n.+1) : toNat (droplsb p) = (toNat p)./2. 133 | Proof. case/tupleP: p => [b p]. rewrite /droplsb/splitlsb beheadCons theadCons. 134 | by rewrite toNatCons/= half_bit_double. 135 | Qed. 136 | 137 | Lemma toNatCat m n (p : BITS m) (q: BITS n) : 138 | toNat (p ## q) = toNat p * 2^n + toNat q. 139 | Proof. 140 | elim: n q; first by move=> q; rewrite (tuple0 q) addn0 expn0 muln1. 141 | move=> n IHn; case/tupleP => [b q]. 142 | rewrite /catB catCons !toNatCons IHn expnS -!muln2; ring. 143 | Qed. 144 | 145 | (*--------------------------------------------------------------------------- 146 | Properties of conversion to and from 'Z_(2^n) 147 | ---------------------------------------------------------------------------*) 148 | 149 | (* This only holds for n.+1 because 'Z_1 actually has two elements - it's 150 | definitionally the same as 'Z_2 in order to force a ring structure. See zmodp 151 | for more details *) 152 | Lemma fromZpK n : cancel (@fromZp n.+1) (@toZp n.+1). 153 | Proof. 154 | move => x. rewrite /toZp/fromZp. rewrite toNat_fromNat modn_small. apply valZpK. 155 | destruct x. simpl. rewrite Zp_cast in i => //. 156 | apply pow2_gt1. 157 | Qed. 158 | 159 | Lemma toZpK n : cancel (@toZp n) (@fromZp n). 160 | Proof. case E: (n == 0). 161 | + rewrite /cancel. rewrite (eqP E). move => x. apply trivialBits. 162 | + move => x. rewrite /fromZp/toZp/=. 163 | rewrite Zp_cast. by rewrite (modn_small (toNatBounded _)) toNatK. 164 | apply negbT in E. destruct n => //. apply pow2_gt1. 165 | Qed. 166 | 167 | Lemma toZp_inj n : injective (@toZp n). 168 | Proof. apply (can_inj (@toZpK _)). Qed. 169 | 170 | Lemma fromZp_inj n : injective (@fromZp n.+1). 171 | Proof. apply (can_inj (@fromZpK _)). Qed. 172 | 173 | Lemma toZp_eq n (x y: BITS n) : (x == y) = (toZp x == toZp y). 174 | Proof. destruct n. by rewrite (tuple0 x) (tuple0 y). 175 | case E: (toZp x == toZp y). 176 | rewrite (toZp_inj (eqP E)). by rewrite eq_refl. 177 | apply (contraFF (b:=false)) => // => H. 178 | rewrite (eqP H) (eq_refl) in E. done. 179 | Qed. 180 | 181 | Corollary toZp_neq n (x y: BITS n) : (x != y) = (toZp x != toZp y). 182 | Proof. by rewrite toZp_eq. Qed. 183 | 184 | (*--------------------------------------------------------------------------- 185 | Properties of bit get and set 186 | ---------------------------------------------------------------------------*) 187 | 188 | Lemma setBitThenGetSame n : forall (p: BITS n) i b, i getBit (setBit p i b) i = b. 189 | Proof. 190 | induction n => //. 191 | case/tupleP => [b' p]. move => i b LT. 192 | destruct i => //. 193 | simpl. rewrite theadCons beheadCons. assert (LT' : i < n) by done. 194 | rewrite /getBit/=. apply IHn; done. 195 | Qed. 196 | 197 | Lemma setBitThenGetDistinct n : 198 | forall (p: BITS n) i i' b, i i' i<>i' -> getBit (setBit p i b) i' = getBit p i'. 199 | Proof. 200 | induction n => //. 201 | case/tupleP => [b' p]. move => i i' b LT LT' NEQ. 202 | destruct i. 203 | (* i = 0 *) simpl. rewrite beheadCons. destruct i' => //. 204 | (* i <> 0 *) 205 | destruct i' => //. 206 | rewrite /= theadCons beheadCons /getBit/=. 207 | assert (lt : i < n) by done. 208 | assert (lt' : i' < n) by done. 209 | assert (neq' : i <> i') by intuition. 210 | specialize (IHn p _ _ b lt lt' neq'). apply IHn. 211 | Qed. 212 | 213 | Lemma getBit_joinmsb : 214 | forall n (bs: BITS n) k, 215 | k <= n -> 216 | getBit (joinmsb (false , bs)) k = getBit bs k. 217 | Proof. 218 | elim=> [|n IHn] bs k leq_k_n. 219 | - (* Case: n ~ 0 *) 220 | rewrite leqn0 in leq_k_n. 221 | move/eqP: leq_k_n=> ->. 222 | by rewrite !tuple0. 223 | - (* Case: n ~ n.+1 *) 224 | case/tupleP: bs=> [b bs]. 225 | case: k leq_k_n => [|k leq_k_n]. 226 | + (* Case: k ~ 0 *) 227 | by trivial. 228 | + (* Case: k ~ k.+1 *) 229 | rewrite /joinmsb/splitlsb tuple.beheadCons 230 | tuple.theadCons -/joinmsb /joinlsb //=. 231 | by apply: IHn; assumption. 232 | Qed. 233 | 234 | Lemma getBit_dropmsb: 235 | forall n (bs : BITS n.+1) k, k < n -> 236 | getBit (dropmsb bs) k = getBit bs k. 237 | Proof. 238 | elim=> // n /= IHn /tupleP[b bs] k le_k. 239 | rewrite /dropmsb /splitmsb /= 240 | tuple.theadCons tuple.beheadCons /= 241 | -/splitmsb. 242 | set cr := splitmsb bs; rewrite (surjective_pairing cr). 243 | have ->: ((cr.1, joinlsb (cr.2, b))).2 = joinlsb (dropmsb bs, b) 244 | by rewrite /dropmsb. 245 | case: k le_k => // k le_k. 246 | + (* k ~ k + 1 *) 247 | have H: forall bs', getBit (joinlsb (bs', b)) k.+1 = getBit bs' k by compute. 248 | by rewrite !H; auto with arith. 249 | Qed. 250 | 251 | (*--------------------------------------------------------------------------- 252 | Properties of all zeroes and all ones 253 | ---------------------------------------------------------------------------*) 254 | Lemma fromNat0 n : #0 = zero n. 255 | Proof. induction n; first apply trivialBits. 256 | + rewrite /zero /copy. rewrite /zero /copy in IHn. by rewrite /fromNat-/fromNat IHn nseqCons. 257 | Qed. 258 | 259 | Lemma count_ones: 260 | forall n, (count_mem true (ones n)) = n. 261 | Proof. 262 | elim=> //=. 263 | auto with arith. 264 | Qed. 265 | 266 | Lemma getBit_zero: 267 | forall n k, getBit (n := n) #0 k = false. 268 | Proof. 269 | move=> n k. 270 | rewrite fromNat0 /zero /copy /getBit nth_nseq if_same //. 271 | Qed. 272 | 273 | Lemma getBit_ones: 274 | forall n k, k < n -> getBit (ones n) k = true. 275 | Proof. 276 | move=> n k le_k. 277 | by rewrite /getBit nth_nseq le_k. 278 | Qed. 279 | 280 | Lemma toNat_zero n : toNat (zero n) = 0. 281 | Proof. induction n => //. rewrite /toNat/=. rewrite /toNat in IHn. by rewrite IHn. Qed. 282 | 283 | Corollary toNat_fromNat0 n : @toNat n #0 = 0. 284 | Proof. by rewrite fromNat0 toNat_zero. Qed. 285 | 286 | Lemma msb_zero n : msb (zero n) = false. 287 | Proof. by induction n. Qed. 288 | 289 | Lemma toNat_ones_succ n : (toNat (ones n)).+1 = 2^n. 290 | Proof. induction n => //. 291 | rewrite /toNat/=. rewrite /toNat/= in IHn. 292 | by rewrite expnS mul2n addnC addn1 -doubleS IHn. 293 | Qed. 294 | 295 | Corollary toNat_ones n : toNat (ones n) = (2^n).-1. 296 | Proof. by rewrite -toNat_ones_succ succnK. Qed. 297 | 298 | Lemma msb_ones n : msb (ones n.+1) = true. 299 | Proof. by induction n. Qed. 300 | 301 | Lemma toZp_zero n : toZp (zero n) = 0%R. 302 | Proof. rewrite /toZp toNat_zero. by apply val_inj. Qed. 303 | 304 | Lemma toZpAux_zero m n : toZpAux (m:=m) (zero n) = 0%R. 305 | Proof. rewrite /toZpAux toNat_zero. by apply val_inj. Qed. 306 | 307 | Lemma toZp_ones n : toZp (ones n.+1) = (-1)%R. 308 | Proof. rewrite /toZp toNat_ones. apply val_inj. 309 | rewrite /= Zp_cast; last apply pow2_gt1. 310 | rewrite -subn1. replace (1 %% 2^n.+1) with 1 => //. 311 | by rewrite modn_small; last apply pow2_gt1. 312 | Qed. 313 | 314 | #[export] 315 | Hint Rewrite toZpK fromZpK toZp_zero toZpAux_zero toZp_ones : ZpHom. 316 | 317 | 318 | (*--------------------------------------------------------------------------- 319 | Properties of joinmsb and splitmsb 320 | ---------------------------------------------------------------------------*) 321 | 322 | Lemma toNat_joinmsb n : forall c (p: BITS n), toNat (joinmsb (c, p)) = c * 2^n + toNat p. 323 | Proof. induction n. 324 | + move => c p. by rewrite /joinmsb (tuple0 p) expn0 muln1. 325 | + move => c. case/tupleP => [b p]. 326 | rewrite /joinmsb-/joinmsb /splitlsb theadCons beheadCons !toNatCons expnS IHn. 327 | by rewrite doubleD addnCA -mul2n mulnCA. 328 | Qed. 329 | 330 | Lemma toNat_joinmsb0 n (p: BITS n) : toNat (joinmsb0 p) = toNat p. 331 | Proof. by rewrite toNat_joinmsb. Qed. 332 | 333 | Lemma splitmsb_fromNat n : 334 | forall m, splitmsb (n:=n) (fromNat m) = (odd (m %/ 2^n), fromNat m). 335 | Proof. induction n => m. 336 | + by rewrite /dropmsb/=beheadCons!theadCons expn0 divn1. 337 | + rewrite expnS. rewrite /fromNat-/fromNat/=. 338 | rewrite /joinlsb !beheadCons!theadCons fromNatHalf. specialize (IHn m./2). rewrite IHn. 339 | by rewrite -divn2 -divnMA. 340 | Qed. 341 | 342 | Corollary dropmsb_fromNat n m : dropmsb (n:=n) (fromNat m) = (fromNat m). 343 | Proof. by rewrite /dropmsb splitmsb_fromNat. Qed. 344 | 345 | Corollary toNat_dropmsb n (p: BITS n.+1) : toNat (dropmsb p) = toNat p %% 2^n. 346 | Proof. rewrite -{1}(toNatK p). rewrite dropmsb_fromNat. by rewrite toNat_fromNat. Qed. 347 | 348 | Lemma toZp_joinmsb0 n (p: BITS n) : toZp (joinmsb0 p) = toZpAux p. 349 | Proof. apply val_inj. 350 | rewrite /toZp/toZpAux/= Zp_cast; last apply pow2_gt1. 351 | by rewrite toNat_joinmsb0. 352 | Qed. 353 | 354 | Lemma toZp_dropmsb n (p: BITS n.+2) : toZp (n:=n.+1) (dropmsb p) = toZpAux (m:=n.+1) p. 355 | Proof. 356 | apply val_inj. 357 | rewrite /toZp/toZpAux/= Zp_cast; last apply pow2_gt1. 358 | rewrite toNat_dropmsb. 359 | by rewrite modn_mod. 360 | Qed. 361 | 362 | #[export] 363 | Hint Rewrite toZp_joinmsb0 toZp_dropmsb : ZpHom. 364 | 365 | Lemma splitmsbK n : cancel (@splitmsb n) (@joinmsb n). 366 | Proof. induction n. 367 | + case/tupleP => [b p]. by rewrite (tuple0 p). 368 | + case/tupleP => [b p]. rewrite /= beheadCons theadCons. specialize (IHn p). 369 | case E: (splitmsb p) => [b' p']. 370 | rewrite beheadCons theadCons. 371 | rewrite E in IHn. by rewrite IHn. 372 | Qed. 373 | 374 | Lemma joinmsbK n : cancel (@joinmsb n) (@splitmsb n). 375 | Proof. induction n. 376 | + move => [b p]. by rewrite !(tuple0 p) /= theadCons beheadCons. 377 | + move => [c p]. case/tupleP: p => [b p]. 378 | by rewrite /= !theadCons !beheadCons IHn. 379 | Qed. 380 | 381 | Corollary dropmsb_joinmsb n b (p:BITS n) : dropmsb (joinmsb (b, p)) = p. 382 | Proof. by rewrite /dropmsb joinmsbK. Qed. 383 | 384 | Lemma splitlsbK n : cancel (@splitlsb n) (@joinlsb n). 385 | Proof. case/tupleP => [b p]. by rewrite /splitlsb beheadCons theadCons. Qed. 386 | 387 | Lemma joinlsbK n : cancel (@joinlsb n) (@splitlsb n). 388 | Proof. move => [p b]. by rewrite /joinlsb /splitlsb beheadCons theadCons. Qed. 389 | 390 | Lemma toNat_joinlsb n (p:BITS n) b : toNat (joinlsb (p, b)) = b + (toNat p).*2. 391 | Proof. done. Qed. 392 | 393 | (* Totally ridiculous proof *) 394 | Lemma splitmsb_rev n : forall (b: BITS n.+1) hi (lo:BITS n), 395 | splitmsb b = (hi,lo) -> rev b = hi::rev lo. 396 | Proof. induction n => b hi lo/=. 397 | + move => [<- <-] {lo}/=. case/tupleP:b => [b u]//=. by rewrite tuple0/=. 398 | + move => H. 399 | specialize (IHn (behead_tuple b) hi). 400 | destruct (splitmsb (behead_tuple b)). 401 | injection H => [H1 H2] {H}. rewrite H2 {H2} in IHn. 402 | specialize (IHn b1 refl_equal). rewrite -H1/=. 403 | case/tupleP E: b => [b' u]/=. rewrite E/= in IHn. 404 | by rewrite 2!rev_cons IHn rcons_cons. 405 | Qed. 406 | 407 | (*--------------------------------------------------------------------------- 408 | Properties of concatenation and splitting of bit strings 409 | ---------------------------------------------------------------------------*) 410 | Lemma high_catB n2 n1 (p:BITS n1) (q:BITS n2) : high n1 (p ## q) = p. 411 | Proof. induction n2. 412 | - rewrite /high (tuple0 q). by apply catNil. 413 | - case/tupleP: q => x q. rewrite /catB catCons /= beheadCons. apply IHn2. 414 | Qed. 415 | 416 | Lemma low_catB n2 n1 (p:BITS n1) (q:BITS n2) : low n2 (p ## q) = q. 417 | Proof. induction n2; first apply trivialBits. 418 | case/tupleP: q => x q. rewrite /catB catCons /= beheadCons. by rewrite IHn2. 419 | Qed. 420 | 421 | Lemma low_fromNat n2 n1: forall m, low n2 (fromNat (n:=n2+n1) m) = fromNat (n:=n2) m. 422 | Proof. induction n2 => m //. by rewrite /= /joinlsb !beheadCons !theadCons/= IHn2. Qed. 423 | 424 | Lemma split2eta : forall n2 n1 p, let (p1,p2) := split2 n1 n2 p in p = p1 ## p2. 425 | Proof. unfold split2. induction n2. 426 | - move =>n1 p. by rewrite /catB catNil. 427 | - move => n1. case/tupleP => x p. rewrite /= (IHn2 n1 p). 428 | rewrite beheadCons theadCons high_catB low_catB. by rewrite /catB catCons. Qed. 429 | 430 | Lemma split2app n2 n1 p1 p2 : split2 n1 n2 (p1 ## p2) = (p1,p2). 431 | Proof. by rewrite /split2 high_catB low_catB. Qed. 432 | 433 | Lemma split3app n3 n2 n1 p1 p2 p3 : split3 n1 n2 n3 (p1 ## p2 ## p3) = (p1,p2,p3). 434 | Proof. by rewrite /split3 !split2app. Qed. 435 | 436 | Lemma split4app n4 n3 n2 n1 p1 p2 p3 p4 : 437 | split4 n1 n2 n3 n4 (p1 ## p2 ## p3 ## p4) = (p1,p2,p3,p4). 438 | Proof. by rewrite /split4 !split2app. Qed. 439 | 440 | Lemma split3eta n3 n2 n1 p: match split3 n1 n2 n3 p with (p1,p2,p3) => p1 ## p2 ## p3 end = p. Proof. rewrite /split3 /=. by rewrite -!split2eta. Qed. 441 | 442 | Lemma split4eta n4 n3 n2 n1 p: 443 | match split4 n1 n2 n3 n4 p with (p1,p2,p3,p4) => p1 ## p2 ## p3 ## p4 end = p. 444 | Proof. rewrite /split4 /=. by rewrite -!split2eta. Qed. 445 | 446 | Lemma split4eta' n4 n3 n2 n1 p: 447 | let: (p1,p2,p3,p4) := split4 n1 n2 n3 n4 p in p1 ## p2 ## p3 ## p4 = p. 448 | Proof. rewrite /split4 /=. by rewrite -!split2eta. Qed. 449 | 450 | Lemma catB_inj n1 n2 (p1 q1: BITS n1) (p2 q2: BITS n2) : 451 | p1 ## p2 = q1 ## q2 -> p1 = q1 /\ p2 = q2. 452 | Proof. 453 | move => EQ. 454 | have H1 := high_catB p1 p2. 455 | have H2 := high_catB q1 q2. 456 | have L1 := low_catB p1 p2. 457 | have L2 := low_catB q1 q2. 458 | split. by rewrite -H1 -H2 EQ. 459 | by rewrite -L1 -L2 EQ. 460 | Qed. 461 | 462 | Lemma toNat_low n1 n2 (p: BITS (n1+n2)) : toNat (low n1 p) = toNat p %% 2^n1. 463 | Proof. by rewrite -{1}(toNatK p) low_fromNat toNat_fromNat. Qed. 464 | 465 | Lemma allBitsEq n (p q: BITS n) : (forall i, i < n -> getBit p i = getBit q i) -> p = q. 466 | Proof. induction n. by rewrite (tuple0 p) (tuple0 q). 467 | case/tupleP: p => [b p]. 468 | case/tupleP: q => [c q]. 469 | move => H. have H0:= H 0. rewrite /getBit/= in H0. rewrite H0 => //. 470 | rewrite (IHn p q). done. 471 | move => i LT. apply (H i.+1 LT). 472 | Qed. 473 | 474 | Lemma lowBitsEq n1 n2 (p q: BITS (n1+n2)) : 475 | (forall i, i < n1 -> getBit p i = getBit q i) <-> low n1 p = low n1 q. 476 | Proof. induction n1 => //=. 477 | case/tupleP: p => [b p]. fold plus in p. 478 | case/tupleP: q => [c q]. fold plus in q. 479 | rewrite 2!beheadCons 2!theadCons /getBit/=. split => H. 480 | + have H0:= H 0. rewrite /= in H0. rewrite H0 => //. 481 | rewrite (proj1 (IHn1 p q)). done. move => i LT. apply (H i.+1 LT). 482 | + move => i LT. destruct i. by injection H. 483 | injection H => H1 H2. subst. apply (IHn1 p q). apply val_inj. apply H1. apply LT. 484 | Qed. 485 | 486 | Lemma highBitsEq n1 n2 (p q: BITS (n1+n2)) : 487 | (forall i, n1 <= i -> getBit p i = getBit q i) <-> high n2 p = high n2 q. 488 | Proof. induction n1 => /=. 489 | split. 490 | have ABE := @allBitsEq _ p q. move => H. apply: ABE. move => i H'. rewrite H => //. 491 | by move => ->. 492 | case/tupleP: p => [b p]. fold plus in p. 493 | case/tupleP: q => [c q]. fold plus in q. 494 | rewrite 2!beheadCons /getBit/=. split => H. 495 | + apply IHn1. move => i LE. apply (H i.+1 LE). 496 | + have IH' := (proj2 (IHn1 p q)). case => // i. by apply IH'. 497 | Qed. 498 | 499 | Lemma getBit_low n1: forall n2 (p: BITS (n1+n2)) i, 500 | getBit (low n1 p) i = if i < n1 then getBit p i else false. 501 | Proof. induction n1 => // n2 p i. destruct i => //. case/tupleP: p => [b p]. 502 | rewrite /getBit/joinlsb/= beheadCons theadCons. destruct i => //. apply IHn1. 503 | Qed. 504 | 505 | Lemma getBit_high n1: forall n2 (p: BITS (n1+n2)) i, 506 | getBit (high n2 p) i = getBit p (i+n1). 507 | Proof. induction n1 => // n2 p i. by rewrite addn0. 508 | rewrite addnS. case/tupleP: p => [b p]. apply IHn1. Qed. 509 | 510 | Lemma getBit_catB n1 n2 (p:BITS n1) (q:BITS n2) : 511 | forall i, getBit (p ## q) i = if i < n2 then getBit q i else getBit p (i-n2). 512 | Proof. induction n2 => // i. 513 | rewrite (tuple0 q). destruct i => //. 514 | case/tupleP: q => [b q] //. destruct i => //. apply IHn2. 515 | Qed. 516 | 517 | Lemma sliceEq n1 n2 n3 (p q: BITS (n1+n2+n3)) : 518 | (forall i, n1 <= i < n1+n2 -> getBit p i = getBit q i) <-> 519 | slice n1 n2 n3 p = slice n1 n2 n3 q. 520 | Proof. rewrite /slice/split3/split2. 521 | rewrite <-highBitsEq. split. 522 | move => H1 i LE. rewrite 2!getBit_low. 523 | case LT: (i < (n1+n2)) => //. 524 | - apply H1. by rewrite LE LT. 525 | move => H i. move/andP => [LE LT]. 526 | specialize (H i LE). by rewrite 2!getBit_low LT in H. 527 | Qed. 528 | 529 | Lemma getUpdateSlice n1 n2 n3 (p: BITS (n1+n2+n3)) (q: BITS n2) : 530 | slice n1 n2 n3 (updateSlice _ _ _ p q) = q. 531 | Proof. rewrite /slice/updateSlice/split3/split2. 532 | by rewrite low_catB high_catB. 533 | Qed. 534 | 535 | Lemma bitsToBytesK n : cancel (@bitsToBytes n) (@bytesToBits n). 536 | Proof. induction n. 537 | + move => x. by rewrite (tuple0 _) (tuple0 x). 538 | + move => xs. rewrite /bitsToBytes-/bitsToBytes. 539 | rewrite /splitAtByte. rewrite (split2eta xs) split2app. 540 | by rewrite /bytesToBits-/bytesToBits beheadCons theadCons IHn. 541 | Qed. 542 | 543 | Lemma bytesToBitsK n : cancel (@bytesToBits n) (@bitsToBytes n). 544 | Proof. induction n. 545 | + move => x. by rewrite (tuple0 _) (tuple0 x). 546 | + move => xs. rewrite /bitsToBytes-/bitsToBytes/splitAtByte. 547 | rewrite (split2eta (bytesToBits xs)) split2app. 548 | case/tupleP: xs => [x xs]. 549 | rewrite /bytesToBits-/bytesToBits beheadCons theadCons. 550 | by rewrite high_catB IHn low_catB. Qed. 551 | 552 | (*--------------------------------------------------------------------------- 553 | Zero and sign extension 554 | ---------------------------------------------------------------------------*) 555 | 556 | Lemma signExtendK extra n : pcancel (@signExtend extra n) (signTruncate extra). 557 | Proof. move => p. rewrite /signExtend /signTruncate split2app. 558 | case: (msb p). 559 | + by rewrite /ones eq_refl. 560 | + by rewrite /zero eq_refl. 561 | Qed. 562 | 563 | Lemma signTruncateK extra n p q : 564 | signTruncate extra (n:=n) p = Some q -> 565 | signExtend extra (n:=n) q = p. 566 | Proof. rewrite /signTruncate/signExtend. 567 | rewrite (split2eta p) split2app. 568 | case P: (_ || _) => // H. 569 | have EQ: low n.+1 p = q by congruence. subst. 570 | case M: (msb _). 571 | + rewrite M andTb andFb orbF in P. by rewrite (eqP P). 572 | + rewrite M andTb andFb orFb in P. by rewrite (eqP P). 573 | Qed. 574 | 575 | Lemma zeroExtendK extra n : pcancel (@zeroExtend extra n) (zeroTruncate extra). 576 | Proof. move => p. by rewrite /zeroExtend/zeroTruncate split2app eq_refl. Qed. 577 | 578 | Lemma zeroTruncateK extra n p q : 579 | zeroTruncate extra (n:=n) p = Some q -> 580 | zeroExtend extra (n:=n) q = p. 581 | Proof. rewrite /zeroTruncate/zeroExtend. 582 | rewrite (split2eta p) split2app. 583 | case P: (high extra p == zero extra) => // H. 584 | have EQ: low n p = q by congruence. subst. 585 | by rewrite (eqP P). 586 | Qed. 587 | 588 | 589 | 590 | Lemma toNat_zeroExtend extra n (p: BITS n) : toNat (zeroExtend extra p) = toNat p. 591 | Proof. rewrite /zeroExtend. rewrite toNatCat. by rewrite toNat_zero. Qed. 592 | 593 | Lemma toNat_zeroExtendAux extra n (p: BITS n) : toNat (zeroExtendAux extra p) = toNat p. 594 | Proof. induction extra => //. by rewrite /= toNat_joinmsb0 IHextra. Qed. 595 | 596 | Lemma zeroExtend_fromNat extra n m : 597 | m < 2^n -> 598 | zeroExtend extra (fromNat (n:=n) m) = #m. 599 | Proof. move => LT. 600 | apply toNat_inj. rewrite toNat_zeroExtend. rewrite toNat_fromNatBounded => //. 601 | rewrite toNat_fromNatBounded => //. 602 | rewrite expnD. 603 | apply (leq_trans LT). apply leq_pmulr. apply expn_gt0. 604 | Qed. 605 | 606 | Lemma msbNonNil n (p: BITS n.+1) b : msb p = last b p. 607 | Proof. by case/tupleP: p => b' q. Qed. 608 | 609 | Lemma splitmsb_msb n (p:BITS n.+1) : (splitmsb p).1 = msb p. 610 | Proof. induction n. 611 | + case/tupleP: p => b q. by rewrite (tuple0 q)/= theadCons. 612 | + case/tupleP: p => b q. rewrite /= beheadCons theadCons. case E: (splitmsb q) => [b' q']. 613 | specialize (IHn q). rewrite E/= in IHn. simpl. rewrite (msbNonNil q b) in IHn. by subst. 614 | Qed. 615 | 616 | Lemma signExtend_fromNat extra n m : 617 | m < 2^n -> 618 | signExtend extra (fromNat (n:=n.+1) m) = #m. 619 | Proof. move => LT. 620 | unfold signExtend. rewrite -splitmsb_msb. 621 | rewrite splitmsb_fromNat. simpl. 622 | rewrite divn_small => //. simpl. 623 | replace (copy extra false ## (fromNat (n:=n.+1) m)) with (zeroExtend extra (fromNat (n:=n.+1) m)). apply zeroExtend_fromNat. rewrite expnS. 624 | apply: (ltn_trans LT). apply ltn_Pmull => //. apply expn_gt0. 625 | done. 626 | Qed. 627 | 628 | (*--------------------------------------------------------------------------- 629 | Properties of equality 630 | ---------------------------------------------------------------------------*) 631 | 632 | Lemma iffBool (b1 b2:bool) : (b1 <-> b2) -> b1==b2. 633 | Proof. destruct b1; destruct b2; intuition. Qed. 634 | 635 | Lemma bitsEq_nat n {b1 b2: BITS n} : (b1 == b2) = (toNat b1 == toNat b2). 636 | Proof. suff: b1 == b2 <-> (toNat b1 == toNat b2). 637 | 638 | move => H. assert (H' := iffBool H). apply (eqP H'). 639 | split. move => H. rewrite (eqP H). done. 640 | move => H. assert (EQ:toNat b1 = toNat b2) by apply (eqP H). by rewrite (toNat_inj EQ). 641 | Qed. 642 | -------------------------------------------------------------------------------- /src/ssrextra/nat.v: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Various helpers for halving, double and powers of 2 3 | ---------------------------------------------------------------------------*) 4 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype tuple zmodp div. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Import Prenex Implicits. 9 | 10 | 11 | 12 | Lemma half_ltn_double m n : m < n.*2 -> m./2 < n. 13 | Proof. move => H. 14 | rewrite -ltn_double. rewrite -(odd_double_half m) in H. 15 | rewrite -(ltn_add2l (odd m)). 16 | by apply ltn_addl. 17 | Qed. 18 | 19 | Lemma half_double_subn1 a : ((a.*2).-1)./2 = a.-1. 20 | Proof. case a. done. move => a'. simpl; apply uphalf_double. Qed. 21 | 22 | Lemma uphalf_double_subn1 a : uphalf ((a.*2).-1) = a. 23 | Proof. case a. done. move => a'. simpl; by rewrite half_double. Qed. 24 | 25 | Lemma half_subn1 : forall a b, (b - a.+1)./2 = (uphalf (b - a)).-1. 26 | Proof. induction a. 27 | + case => //. move => b. by rewrite subn1. 28 | + move => b. specialize (IHa (b.-1)). 29 | rewrite -subn1 in IHa. by rewrite -!subnDA !add1n in IHa. 30 | Qed. 31 | 32 | (* Strictly speaking we don't need the precondition *) 33 | Lemma half_sub a : forall b, a <= b.*2 -> (b.*2 - a)./2 = b - uphalf a. 34 | Proof. 35 | induction a => b H. 36 | + by rewrite !subn0 doubleK. 37 | + rewrite half_subn1. rewrite uphalf_half. rewrite IHa. 38 | rewrite oddB. rewrite odd_double/=. rewrite -subn1. 39 | rewrite uphalf_half. 40 | case ODD: (odd a). 41 | by rewrite add1n subn1. 42 | by rewrite !add0n/= -subnDA addn1. 43 | apply (ltnW H). apply (ltnW H). 44 | Qed. 45 | 46 | Lemma odd_oddsubn1 : forall n, n > 0 -> odd n.-1 = ~~odd n. 47 | Proof. induction n => //. destruct n => //. simpl. by case (odd n). Qed. 48 | 49 | Lemma odd_power2 n : odd (2^(n.+1)) = false. 50 | Proof. by rewrite expnS mul2n odd_double. Qed. 51 | 52 | Lemma odd_power2subn1 n : odd ((2^(n.+1)).-1) = true. 53 | Proof. induction n => //. 54 | rewrite expnS mul2n odd_oddsubn1. 55 | by rewrite odd_double. 56 | rewrite -mul2n -expnS. apply expn_gt0. 57 | Qed. 58 | 59 | Lemma leq_subn a b : 0 < b -> a < b -> a <= b.-1. 60 | Proof. by case b. Qed. 61 | 62 | Lemma pow2_gt1 n : 1 < 2^n.+1. 63 | Proof. rewrite expnS. 64 | suff: 2*1 <= 2*2^n => //. 65 | rewrite leq_mul2l/=. 66 | apply expn_gt0. 67 | Qed. 68 | 69 | Lemma nat_lt0_succ m : (0 < m) = true -> exists m', m = m'+1. 70 | Proof. destruct m => //. move => _. exists m. by rewrite addn1. 71 | Qed. 72 | 73 | Lemma pow2_sub_ltn n x : (2^n)-(x.+1) < 2^n. 74 | Proof. have H := expn_gt0 2 n. simpl in H. 75 | destruct (nat_lt0_succ H) as [m' HH]. rewrite HH. 76 | rewrite addn1 subSS. by rewrite ltnS leq_subr. 77 | Qed. 78 | 79 | Lemma modn_sub : forall N x y, 0 < N -> x < N -> y < N -> N <= x+y -> 80 | (x + y) %% N + N = x+y. 81 | Proof. 82 | move => N x y B H1 H2 H3. 83 | assert (H4:= divn_eq (x+y) N). 84 | rewrite {2}H4. 85 | rewrite addnC. 86 | assert (LT:(x + y) %/ N < 2). 87 | rewrite ltn_divLR. rewrite mul2n -addnn. 88 | rewrite -(ltn_add2r y) in H1. 89 | apply (ltn_trans H1). 90 | by rewrite ltn_add2l. 91 | done. 92 | assert (GT:0 < (x + y) %/ N). 93 | by rewrite divn_gt0. rewrite ltnS in LT. 94 | assert (1 <= (x+y) %/ N <= 1). by rewrite GT LT. 95 | rewrite -eqn_leq in H. rewrite -(eqP H). 96 | by rewrite mul1n. 97 | Qed. 98 | -------------------------------------------------------------------------------- /src/ssrextra/tuple.v: -------------------------------------------------------------------------------- 1 | (* Additional lemmas about tuples *) 2 | From Coq Require Import Setoid. 3 | From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq fintype tuple. 4 | 5 | Lemma mapCons {n A B} (f: A -> B) b (p: n.-tuple A) : 6 | map_tuple f [tuple of b :: p] = [tuple of f b :: map_tuple f p]. 7 | Proof. by apply: eq_from_tnth=> i; rewrite !(tnth_nth (f b)). Qed. 8 | 9 | Lemma mapNil {A B} (f:A -> B) : 10 | map_tuple f [tuple] = [tuple]. 11 | Proof. exact: val_inj. Qed. 12 | 13 | Lemma theadCons : forall {n A} (a:A) (aa: n.-tuple A), thead [tuple of a::aa] = a. 14 | Proof. done. Qed. 15 | 16 | Lemma beheadCons {n A} a (aa: n.-tuple A) : behead_tuple [tuple of a::aa] = aa. 17 | Proof. by apply: eq_from_tnth=> i; rewrite !(tnth_nth a). Qed. 18 | 19 | Lemma zipCons {n A B} a (aa: n.-tuple A) b (bb: n.-tuple B) : 20 | zip_tuple [tuple of a::aa] [tuple of b::bb] = [tuple of (a,b) :: zip_tuple aa bb]. 21 | Proof. by apply: eq_from_tnth=> i; rewrite !(tnth_nth (a,b)). Qed. 22 | 23 | Lemma nseqCons {n A} (a:A) : nseq_tuple (S n) a = [tuple of a::nseq_tuple n a]. 24 | Proof. by apply: eq_from_tnth=> i; rewrite !(tnth_nth a). Qed. 25 | 26 | Lemma catCons {n1 n2 A} (a:A) (aa:n1.-tuple A) (bb:n2.-tuple A) : 27 | cat_tuple [tuple of a::aa] bb = [tuple of a::cat_tuple aa bb]. 28 | Proof. by apply: eq_from_tnth=> i; rewrite !(tnth_nth a). Qed. 29 | 30 | Lemma catNil {n A} (aa:n.-tuple A) : 31 | cat_tuple [tuple] aa = aa. 32 | Proof. exact: val_inj. Qed. 33 | 34 | Lemma mapId T n (t: n.-tuple T) : map_tuple id t = t. 35 | Proof. 36 | induction n. 37 | + by rewrite (tuple0 t) mapNil. 38 | + case : t / tupleP => h t. 39 | by rewrite mapCons IHn. 40 | Qed. 41 | 42 | #[export] 43 | Hint Rewrite @mapCons @mapNil @theadCons @ beheadCons @zipCons @nseqCons @catCons @catNil @mapId : tuple. 44 | 45 | Lemma behead_nseq {n A} (a:A) : behead_tuple (nseq_tuple n.+1 a) = nseq_tuple n a. 46 | Proof. by apply: eq_from_tnth=> i; rewrite !(tnth_nth a). Qed. 47 | 48 | Lemma splitTuple {X n} {a b:X} {c d:n.-tuple X} : cons_tuple a c = cons_tuple b d -> a = b /\ c = d. 49 | Proof. move => H. split. by inversion H. apply val_inj. by inversion H. Qed. 50 | 51 | (* The last n elements *) 52 | Fixpoint lastn {T} n {n2} : (n2+n).-tuple T -> n.-tuple T := 53 | if n2 is _.+1 return (n2+n).-tuple T -> n.-tuple T 54 | then fun p => lastn _ (behead_tuple p) else fun p => p. 55 | 56 | (* The first n elements *) 57 | Fixpoint firstn {T} {n1} n : (n+n1).-tuple T -> n.-tuple T := 58 | if n is _.+1 return (n+n1).-tuple T -> n.-tuple T 59 | then fun p => cons_tuple (thead p) (firstn _ (behead_tuple p)) else fun p => nil_tuple _. 60 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | # KNOWNTARGETS will not be passed along to CoqMakefile 2 | KNOWNTARGETS := CoqMakefile 3 | # KNOWNFILES will not get implicit targets from the final rule, and so depending on them won’t invoke the submake 4 | # Warning: These files get declared as PHONY, so any targets depending on them always get rebuilt 5 | KNOWNFILES := Makefile _CoqProject 6 | 7 | .DEFAULT_GOAL := invoke-coqmakefile 8 | 9 | CoqMakefile: Makefile _CoqProject 10 | $(COQBIN)coq_makefile -f _CoqProject -o CoqMakefile 11 | 12 | invoke-coqmakefile: CoqMakefile 13 | $(MAKE) --no-print-directory -f CoqMakefile $(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS)) 14 | 15 | .PHONY: invoke-coqmakefile $(KNOWNFILES) 16 | 17 | # This should be the last rule, to handle any targets not declared above 18 | %: invoke-coqmakefile 19 | @true 20 | -------------------------------------------------------------------------------- /test/_CoqProject: -------------------------------------------------------------------------------- 1 | -R . BitTest 2 | 3 | -arg -w -arg -notation-overridden 4 | -arg -w -arg -ambiguous-paths 5 | 6 | benchmark.v 7 | integers.v 8 | -------------------------------------------------------------------------------- /test/benchmark.v: -------------------------------------------------------------------------------- 1 | (*=========================================================================== 2 | Test the performance of bits operations 3 | ===========================================================================*) 4 | From Coq Require Import ZArith. 5 | From mathcomp 6 | Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq tuple ssralg. 7 | From Bits.spec 8 | Require Import spec operations. 9 | 10 | Set Implicit Arguments. 11 | Unset Strict Implicit. 12 | Import Prenex Implicits. 13 | 14 | (* Open Scope ring_scope. *) 15 | 16 | Definition n' := Eval cbv in 31. 17 | Definition n := n'.+1. 18 | 19 | (* 20 | Example ex:BITS n := #59 + #23 *+ 3. 21 | *) 22 | 23 | Definition c := Eval compute in @fromZ n 12345. 24 | 25 | Example incTest := 26 | toZ (n:=n') (iter 500 (iter 200 (@incB n)) c). 27 | 28 | Example addTest := 29 | toZ (n:=n') (iter 200 (iter 200 (@addB n c)) c). 30 | 31 | Example mulTest := 32 | toZ (n:=n') (iter 10 (iter 20 (@mulB n c)) c). 33 | 34 | Time Compute incTest. 35 | (* Finished transaction in 4.223 secs (4.075u,0.136s) (successful) *) 36 | 37 | Time Compute addTest. 38 | (* Finished transaction in 33.505 secs (33.104u,0.104s) (successful) *) 39 | 40 | Time Compute mulTest. 41 | (* Finished transaction in 12.261 secs (12.076u,0.151s) (successful) *) 42 | 43 | (* Compare against compcert *) 44 | Require Import integers. 45 | 46 | Example auxIncTest := 47 | let v := Int.repr 12345 in 48 | Int.unsigned (iter 500 (iter 200 (fun x => Int.add x (Int.repr 1))) v). 49 | 50 | Example auxAddTest := 51 | let v := Int.repr 12345 in 52 | Int.unsigned (iter 200 (iter 200 (fun x => Int.add x v)) v). 53 | 54 | Time Compute auxIncTest. 55 | (* Finished transaction in 2.878 secs (2.875u,0.s) (successful) *) 56 | 57 | Time Compute auxAddTest. 58 | (* Finished transaction in 1.755 secs (1.743u,0.s) (successful) *) 59 | -------------------------------------------------------------------------------- /test/integers.v: -------------------------------------------------------------------------------- 1 | (* *********************************************************************) 2 | (* *) 3 | (* The Compcert verified compiler *) 4 | (* *) 5 | (* Xavier Leroy, INRIA Paris-Rocquencourt *) 6 | (* *) 7 | (* Copyright Institut National de Recherche en Informatique et en *) 8 | (* Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU General Public License as published by *) 10 | (* the Free Software Foundation, either version 2 of the License, or *) 11 | (* (at your option) any later version. This file is also distributed *) 12 | (* under the terms of the INRIA Non-Commercial License Agreement. *) 13 | (* *) 14 | (* *********************************************************************) 15 | 16 | (** Formalizations of machine integers modulo $2^N$ #2N#. *) 17 | 18 | Require Import Eqdep_dec. 19 | Require Import Zquot. 20 | Require Import Zwf. 21 | Require Import ZArith. 22 | Require Import Znumtheory. 23 | Require Import Bool. 24 | Require Import List. 25 | 26 | (* Require Import Coqlib. *) 27 | 28 | Definition proj_sumbool (P Q: Prop) (a: {P} + {Q}) : bool := 29 | if a then true else false. 30 | 31 | Arguments proj_sumbool [P Q]. 32 | 33 | Coercion proj_sumbool: sumbool >-> bool. 34 | 35 | (** * Definitions and theorems over the type [Z] *) 36 | 37 | Definition zeq: forall (x y: Z), {x = y} + {x <> y} := Z.eq_dec. 38 | 39 | Open Scope Z_scope. 40 | 41 | Definition zlt: forall (x y: Z), {x < y} + {x >= y} := Z_lt_dec. 42 | Definition zle: forall (x y: Z), {x <= y} + {x > y} := Z_le_gt_dec. 43 | Definition Zdivide_dec: 44 | forall (p q: Z), p > 0 -> { (p|q) } + { ~(p|q) }. 45 | Proof. 46 | admit. 47 | Admitted. 48 | Global Opaque Zdivide_dec. 49 | 50 | 51 | (** Conversion from [Z] to [nat]. *) 52 | 53 | Definition nat_of_Z: Z -> nat := Z.to_nat. 54 | 55 | (** Alignment: [align n amount] returns the smallest multiple of [amount] 56 | greater than or equal to [n]. *) 57 | 58 | Definition align (n: Z) (amount: Z) := 59 | ((n + amount - 1) / amount) * amount. 60 | 61 | 62 | (** * Comparisons *) 63 | 64 | Inductive comparison : Type := 65 | | Ceq : comparison (**r same *) 66 | | Cne : comparison (**r different *) 67 | | Clt : comparison (**r less than *) 68 | | Cle : comparison (**r less than or equal *) 69 | | Cgt : comparison (**r greater than *) 70 | | Cge : comparison. (**r greater than or equal *) 71 | 72 | Definition negate_comparison (c: comparison): comparison := 73 | match c with 74 | | Ceq => Cne 75 | | Cne => Ceq 76 | | Clt => Cge 77 | | Cle => Cgt 78 | | Cgt => Cle 79 | | Cge => Clt 80 | end. 81 | 82 | Definition swap_comparison (c: comparison): comparison := 83 | match c with 84 | | Ceq => Ceq 85 | | Cne => Cne 86 | | Clt => Cgt 87 | | Cle => Cge 88 | | Cgt => Clt 89 | | Cge => Cle 90 | end. 91 | 92 | (** * Parameterization by the word size, in bits. *) 93 | 94 | Module Type WORDSIZE. 95 | Parameter wordsize: nat. 96 | Axiom wordsize_not_zero: wordsize <> 0%nat. 97 | End WORDSIZE. 98 | 99 | (* To avoid useless definitions of inductors in extracted code. *) 100 | Local Unset Elimination Schemes. 101 | Local Unset Case Analysis Schemes. 102 | 103 | Module Make(WS: WORDSIZE). 104 | 105 | Definition wordsize: nat := WS.wordsize. 106 | Definition zwordsize: Z := Z_of_nat wordsize. 107 | Definition modulus : Z := two_power_nat wordsize. 108 | Definition half_modulus : Z := modulus / 2. 109 | Definition max_unsigned : Z := modulus - 1. 110 | Definition max_signed : Z := half_modulus - 1. 111 | Definition min_signed : Z := - half_modulus. 112 | 113 | Remark wordsize_pos: zwordsize > 0. 114 | Proof. 115 | unfold zwordsize, wordsize. generalize WS.wordsize_not_zero. omega. 116 | Qed. 117 | 118 | Remark modulus_power: modulus = two_p zwordsize. 119 | Proof. 120 | unfold modulus. admit. (*apply two_power_nat_two_p.*) 121 | Admitted. 122 | 123 | Remark modulus_pos: modulus > 0. 124 | Proof. 125 | rewrite modulus_power. apply two_p_gt_ZERO. generalize wordsize_pos; omega. 126 | Qed. 127 | 128 | (** * Representation of machine integers *) 129 | 130 | (** A machine integer (type [int]) is represented as a Coq arbitrary-precision 131 | integer (type [Z]) plus a proof that it is in the range 0 (included) to 132 | [modulus] (excluded). *) 133 | 134 | Record int: Type := mkint { intval: Z; intrange: -1 < intval < modulus }. 135 | 136 | (** Fast normalization modulo [2^wordsize] *) 137 | 138 | Fixpoint P_mod_two_p (p: positive) (n: nat) {struct n} : Z := 139 | match n with 140 | | O => 0 141 | | S m => 142 | match p with 143 | | xH => 1 144 | | xO q => Z.double (P_mod_two_p q m) 145 | | xI q => Z.succ_double (P_mod_two_p q m) 146 | end 147 | end. 148 | 149 | Definition Z_mod_modulus (x: Z) : Z := 150 | match x with 151 | | Z0 => 0 152 | | Zpos p => P_mod_two_p p wordsize 153 | | Zneg p => let r := P_mod_two_p p wordsize in if zeq r 0 then 0 else modulus - r 154 | end. 155 | 156 | 157 | (** The [unsigned] and [signed] functions return the Coq integer corresponding 158 | to the given machine integer, interpreted as unsigned or signed 159 | respectively. *) 160 | 161 | Definition unsigned (n: int) : Z := intval n. 162 | 163 | Definition signed (n: int) : Z := 164 | let x := unsigned n in 165 | if zlt x half_modulus then x else x - modulus. 166 | 167 | (** Conversely, [repr] takes a Coq integer and returns the corresponding 168 | machine integer. The argument is treated modulo [modulus]. *) 169 | 170 | Definition admitted {X}: X. admit. Admitted. 171 | 172 | Definition repr (x: Z) : int := 173 | mkint (Z_mod_modulus x) admitted (*(Z_mod_modulus_range' x).*). 174 | 175 | Definition zero := repr 0. 176 | Definition one := repr 1. 177 | Definition mone := repr (-1). 178 | Definition iwordsize := repr zwordsize. 179 | 180 | 181 | (** * Arithmetic and logical operations over machine integers *) 182 | 183 | Definition eq (x y: int) : bool := 184 | if zeq (unsigned x) (unsigned y) then true else false. 185 | Definition lt (x y: int) : bool := 186 | if zlt (signed x) (signed y) then true else false. 187 | Definition ltu (x y: int) : bool := 188 | if zlt (unsigned x) (unsigned y) then true else false. 189 | 190 | Definition neg (x: int) : int := repr (- unsigned x). 191 | 192 | Definition add (x y: int) : int := 193 | repr (unsigned x + unsigned y). 194 | Definition sub (x y: int) : int := 195 | repr (unsigned x - unsigned y). 196 | Definition mul (x y: int) : int := 197 | repr (unsigned x * unsigned y). 198 | 199 | Definition divs (x y: int) : int := 200 | repr (Z.quot (signed x) (signed y)). 201 | Definition mods (x y: int) : int := 202 | repr (Z.rem (signed x) (signed y)). 203 | 204 | Definition divu (x y: int) : int := 205 | repr (unsigned x / unsigned y). 206 | Definition modu (x y: int) : int := 207 | repr ((unsigned x) mod (unsigned y)). 208 | 209 | (** Bitwise boolean operations. *) 210 | 211 | Definition and (x y: int): int := repr (Z.land (unsigned x) (unsigned y)). 212 | Definition or (x y: int): int := repr (Z.lor (unsigned x) (unsigned y)). 213 | Definition xor (x y: int) : int := repr (Z.lxor (unsigned x) (unsigned y)). 214 | 215 | Definition not (x: int) : int := xor x mone. 216 | 217 | (** Shifts and rotates. *) 218 | 219 | Definition shl (x y: int): int := repr (Z.shiftl (unsigned x) (unsigned y)). 220 | Definition shru (x y: int): int := repr (Z.shiftr (unsigned x) (unsigned y)). 221 | Definition shr (x y: int): int := repr (Z.shiftr (signed x) (unsigned y)). 222 | 223 | Definition rol (x y: int) : int := 224 | let n := (unsigned y) mod zwordsize in 225 | repr (Z.lor (Z.shiftl (unsigned x) n) (Z.shiftr (unsigned x) (zwordsize - n))). 226 | Definition ror (x y: int) : int := 227 | let n := (unsigned y) mod zwordsize in 228 | repr (Z.lor (Z.shiftr (unsigned x) n) (Z.shiftl (unsigned x) (zwordsize - n))). 229 | 230 | Definition rolm (x a m: int): int := and (rol x a) m. 231 | 232 | (** Viewed as signed divisions by powers of two, [shrx] rounds towards 233 | zero, while [shr] rounds towards minus infinity. *) 234 | 235 | Definition shrx (x y: int): int := 236 | divs x (shl one y). 237 | 238 | (** High half of full multiply. *) 239 | 240 | Definition mulhu (x y: int): int := repr ((unsigned x * unsigned y) / modulus). 241 | Definition mulhs (x y: int): int := repr ((signed x * signed y) / modulus). 242 | 243 | (** Condition flags *) 244 | 245 | Definition negative (x: int): int := 246 | if lt x zero then one else zero. 247 | 248 | Definition add_carry (x y cin: int): int := 249 | if zlt (unsigned x + unsigned y + unsigned cin) modulus then zero else one. 250 | 251 | Definition add_overflow (x y cin: int): int := 252 | let s := signed x + signed y + signed cin in 253 | if zle min_signed s && zle s max_signed then zero else one. 254 | 255 | Definition sub_borrow (x y bin: int): int := 256 | if zlt (unsigned x - unsigned y - unsigned bin) 0 then one else zero. 257 | 258 | Definition sub_overflow (x y bin: int): int := 259 | let s := signed x - signed y - signed bin in 260 | if zle min_signed s && zle s max_signed then zero else one. 261 | 262 | (** [shr_carry x y] is 1 if [x] is negative and at least one 1 bit is shifted away. *) 263 | 264 | Definition shr_carry (x y: int) : int := 265 | if andb (lt x zero) (negb (eq (and x (sub (shl one y) one)) zero)) 266 | then one else zero. 267 | 268 | (** Zero and sign extensions *) 269 | 270 | Definition Zshiftin (b: bool) (x: Z) : Z := 271 | if b then Z.succ_double x else Z.double x. 272 | 273 | (** In pseudo-code: 274 | << 275 | Fixpoint Zzero_ext (n: Z) (x: Z) : Z := 276 | if zle n 0 then 277 | 0 278 | else 279 | Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)). 280 | Fixpoint Zsign_ext (n: Z) (x: Z) : Z := 281 | if zle n 1 then 282 | if Z.odd x then -1 else 0 283 | else 284 | Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)). 285 | >> 286 | We encode this [nat]-like recursion using the [Z.iter] iteration 287 | function, in order to make the [Zzero_ext] and [Zsign_ext] 288 | functions efficiently executable within Coq. 289 | *) 290 | 291 | Definition Zzero_ext (n: Z) (x: Z) : Z := 292 | Z.iter n 293 | (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x))) 294 | (fun x => 0) 295 | x. 296 | 297 | Definition Zsign_ext (n: Z) (x: Z) : Z := 298 | Z.iter (Z.pred n) 299 | (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x))) 300 | (fun x => if Z.odd x then -1 else 0) 301 | x. 302 | 303 | Definition zero_ext (n: Z) (x: int) : int := repr (Zzero_ext n (unsigned x)). 304 | 305 | Definition sign_ext (n: Z) (x: int) : int := repr (Zsign_ext n (unsigned x)). 306 | 307 | (** Decomposition of a number as a sum of powers of two. *) 308 | 309 | Fixpoint Z_one_bits (n: nat) (x: Z) (i: Z) {struct n}: list Z := 310 | match n with 311 | | O => nil 312 | | S m => 313 | if Z.odd x 314 | then i :: Z_one_bits m (Z.div2 x) (i+1) 315 | else Z_one_bits m (Z.div2 x) (i+1) 316 | end. 317 | 318 | Definition one_bits (x: int) : list int := 319 | List.map repr (Z_one_bits wordsize (unsigned x) 0). 320 | 321 | (** Recognition of powers of two. *) 322 | 323 | Definition is_power2 (x: int) : option int := 324 | match Z_one_bits wordsize (unsigned x) 0 with 325 | | i :: nil => Some (repr i) 326 | | _ => None 327 | end. 328 | 329 | (** Comparisons. *) 330 | 331 | Definition cmp (c: comparison) (x y: int) : bool := 332 | match c with 333 | | Ceq => eq x y 334 | | Cne => negb (eq x y) 335 | | Clt => lt x y 336 | | Cle => negb (lt y x) 337 | | Cgt => lt y x 338 | | Cge => negb (lt x y) 339 | end. 340 | 341 | Definition cmpu (c: comparison) (x y: int) : bool := 342 | match c with 343 | | Ceq => eq x y 344 | | Cne => negb (eq x y) 345 | | Clt => ltu x y 346 | | Cle => negb (ltu y x) 347 | | Cgt => ltu y x 348 | | Cge => negb (ltu x y) 349 | end. 350 | 351 | Definition is_false (x: int) : Prop := x = zero. 352 | Definition is_true (x: int) : Prop := x <> zero. 353 | Definition notbool (x: int) : int := if eq x zero then one else zero. 354 | 355 | (** * Properties of integers and integer arithmetic *) 356 | 357 | (** ** Properties of [modulus], [max_unsigned], etc. *) 358 | 359 | 360 | (** ** Modulo arithmetic *) 361 | 362 | (** We define and state properties of equality and arithmetic modulo a 363 | positive integer. *) 364 | 365 | Section EQ_MODULO. 366 | 367 | Variable modul: Z. 368 | Hypothesis modul_pos: modul > 0. 369 | 370 | Definition eqmod (x y: Z) : Prop := exists k, x = k * modul + y. 371 | End EQ_MODULO. 372 | 373 | (** We then specialize these definitions to equality modulo 374 | $2^{wordsize}$ #2wordsize#. *) 375 | 376 | Hint Resolve modulus_pos: ints. 377 | 378 | Definition eqm := eqmod modulus. 379 | 380 | 381 | (** ** Bit-level reasoning over type [int] *) 382 | 383 | Definition testbit (x: int) (i: Z) : bool := Z.testbit (unsigned x) i. 384 | 385 | 386 | (** Non-overlapping test *) 387 | 388 | Definition no_overlap (ofs1: int) (sz1: Z) (ofs2: int) (sz2: Z) : bool := 389 | let x1 := unsigned ofs1 in let x2 := unsigned ofs2 in 390 | (zlt (x1 + sz1) modulus && zlt (x2 + sz2) modulus) 391 | && (zle (x1 + sz1) x2 || zle (x2 + sz2) x1). 392 | 393 | (** Size of integers, in bits. *) 394 | 395 | Definition Zsize (x: Z) : Z := 396 | match x with 397 | | Zpos p => Zpos (Pos.size p) 398 | | _ => 0 399 | end. 400 | 401 | Definition size (x: int) : Z := Zsize (unsigned x). 402 | 403 | End Make. 404 | 405 | (** * Specialization to integers of size 8, 32, and 64 bits *) 406 | 407 | Module Wordsize_32. 408 | Definition wordsize := 32%nat. 409 | Remark wordsize_not_zero: wordsize <> 0%nat. 410 | Proof. unfold wordsize; congruence. Qed. 411 | End Wordsize_32. 412 | 413 | Module Int := Make(Wordsize_32). 414 | 415 | Notation int := Int.int. 416 | 417 | Module Wordsize_8. 418 | Definition wordsize := 8%nat. 419 | Remark wordsize_not_zero: wordsize <> 0%nat. 420 | Proof. unfold wordsize; congruence. Qed. 421 | End Wordsize_8. 422 | 423 | Module Byte := Make(Wordsize_8). 424 | 425 | Notation byte := Byte.int. 426 | 427 | Module Wordsize_64. 428 | Definition wordsize := 64%nat. 429 | Remark wordsize_not_zero: wordsize <> 0%nat. 430 | Proof. unfold wordsize; congruence. Qed. 431 | End Wordsize_64. 432 | 433 | Module Int64. 434 | 435 | Include Make(Wordsize_64). 436 | 437 | (** Shifts with amount given as a 32-bit integer *) 438 | 439 | Definition iwordsize': Int.int := Int.repr zwordsize. 440 | 441 | Definition shl' (x: int) (y: Int.int): int := 442 | repr (Z.shiftl (unsigned x) (Int.unsigned y)). 443 | Definition shru' (x: int) (y: Int.int): int := 444 | repr (Z.shiftr (unsigned x) (Int.unsigned y)). 445 | Definition shr' (x: int) (y: Int.int): int := 446 | repr (Z.shiftr (signed x) (Int.unsigned y)). 447 | 448 | 449 | (** Decomposing 64-bit ints as pairs of 32-bit ints *) 450 | 451 | Definition loword (n: int) : Int.int := Int.repr (unsigned n). 452 | 453 | Definition hiword (n: int) : Int.int := Int.repr (unsigned (shru n (repr Int.zwordsize))). 454 | 455 | Definition ofwords (hi lo: Int.int) : int := 456 | or (shl (repr (Int.unsigned hi)) (repr Int.zwordsize)) (repr (Int.unsigned lo)). 457 | 458 | 459 | Definition mul' (x y: Int.int) : int := repr (Int.unsigned x * Int.unsigned y). 460 | 461 | End Int64. 462 | 463 | Notation int64 := Int64.int. 464 | 465 | Global Opaque Int.repr Int64.repr Byte.repr. 466 | --------------------------------------------------------------------------------