diff options
119 files changed, 13771 insertions, 2000 deletions
@@ -1,8 +1 @@ -if type lorri &>/dev/null; then - echo "direnv: using lorri" - eval "$(lorri direnv)" -else - # fall back to using direnv's builtin nix support - # to prevent bootstrapping problems. - use nix -fi +use nix diff --git a/.gitattributes b/.gitattributes index 30dd12d..8c19733 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1,4 +1,4 @@ *.h linguist-language=C *.c linguist-language=C *.v linguist-language=Coq -benchmarks/* linguist-vendored +benchmarks/** linguist-vendored @@ -62,3 +62,81 @@ lib/COMPCERTSTAMP # Misc lpsolve.txt + +# Benchmarks + +benchmarks/**/*.v + +*.gcc +*.iver +*.dot + +/benchmarks/polybench-syn/stencils/seidel-2d +/benchmarks/polybench-syn/stencils/jacobi-2d +/benchmarks/polybench-syn/data-mining/covariance +/benchmarks/polybench-syn/linear-algebra/blas/gemm +/benchmarks/polybench-syn/linear-algebra/blas/gemver +/benchmarks/polybench-syn/linear-algebra/blas/gesummv +/benchmarks/polybench-syn/linear-algebra/blas/symm +/benchmarks/polybench-syn/linear-algebra/blas/syr2k +/benchmarks/polybench-syn/linear-algebra/blas/syrk +/benchmarks/polybench-syn/linear-algebra/blas/trmm +/benchmarks/polybench-syn/linear-algebra/kernels/2mm +/benchmarks/polybench-syn/linear-algebra/kernels/3mm +/benchmarks/polybench-syn/linear-algebra/kernels/atas +/benchmarks/polybench-syn/linear-algebra/kernels/bicg +/benchmarks/polybench-syn/linear-algebra/kernels/doitgen +/benchmarks/polybench-syn/linear-algebra/kernels/mvt +/benchmarks/polybench-syn/linear-algebra/solvers/cholesky +/benchmarks/polybench-syn/linear-algebra/solvers/durbin +/benchmarks/polybench-syn/linear-algebra/solvers/lu +/benchmarks/polybench-syn/linear-algebra/solvers/ludcmp +/benchmarks/polybench-syn/linear-algebra/solvers/trisolv +/benchmarks/polybench-syn/medley/floyd-warshall +/benchmarks/polybench-syn/medley/nussinov +/benchmarks/polybench-syn/stencils/adi +/benchmarks/polybench-syn/stencils/fdtd-2d +/benchmarks/polybench-syn/stencils/heat-3d +/benchmarks/polybench-syn/stencils/jacobi-1d + +/benchmarks/polybench-syn-div/stencils/seidel-2d +/benchmarks/polybench-syn-div/stencils/jacobi-2d +/benchmarks/polybench-syn-div/data-mining/covariance +/benchmarks/polybench-syn-div/linear-algebra/blas/gemm +/benchmarks/polybench-syn-div/linear-algebra/blas/gemver +/benchmarks/polybench-syn-div/linear-algebra/blas/gesummv +/benchmarks/polybench-syn-div/linear-algebra/blas/symm +/benchmarks/polybench-syn-div/linear-algebra/blas/syr2k +/benchmarks/polybench-syn-div/linear-algebra/blas/syrk +/benchmarks/polybench-syn-div/linear-algebra/blas/trmm +/benchmarks/polybench-syn-div/linear-algebra/kernels/2mm +/benchmarks/polybench-syn-div/linear-algebra/kernels/3mm +/benchmarks/polybench-syn-div/linear-algebra/kernels/atas +/benchmarks/polybench-syn-div/linear-algebra/kernels/bicg +/benchmarks/polybench-syn-div/linear-algebra/kernels/doitgen +/benchmarks/polybench-syn-div/linear-algebra/kernels/mvt +/benchmarks/polybench-syn-div/linear-algebra/solvers/cholesky +/benchmarks/polybench-syn-div/linear-algebra/solvers/durbin +/benchmarks/polybench-syn-div/linear-algebra/solvers/lu +/benchmarks/polybench-syn-div/linear-algebra/solvers/ludcmp +/benchmarks/polybench-syn-div/linear-algebra/solvers/trisolv +/benchmarks/polybench-syn-div/medley/floyd-warshall +/benchmarks/polybench-syn-div/medley/nussinov +/benchmarks/polybench-syn-div/stencils/adi +/benchmarks/polybench-syn-div/stencils/fdtd-2d +/benchmarks/polybench-syn-div/stencils/heat-3d +/benchmarks/polybench-syn-div/stencils/jacobi-1d + +# Test +*.check +*.txt +*.verilator/ +*.tmp +*.clog +obj_dir/ +*.[0-9] +/*.c +/*.sv +/*.v + +.direnv/ diff --git a/CHANGELOG.org b/CHANGELOG.org index 621683c..88c0953 100644 --- a/CHANGELOG.org +++ b/CHANGELOG.org @@ -1,42 +1,65 @@ # -*- fill-column: 80 -*- +#+title: Vericert Changelog +#+author: Yann Herklotz +#+email: git@ymhg.org -* Vericert Changelog +* Unreleased -** Unreleased +** New Features -*** New Features - -- Add *RTLBlock*, a basic block intermediate language that is based on CompCert's +- Add ~RTLBlock~, a basic block intermediate language that is based on CompCert's RTL. -- Add *RTLPar*, which can execute groups of instructions in parallel. -- Add scheduling pass to go from RTLBlock to RTLPar. +- Add ~RTLPar~, which can execute groups of instructions in parallel. +- Add SDC hyper-block scheduling pass to go from RTLBlock to RTLPar using. +- Add operation chaining support to scheduler. +- Add ~Abstr~ intermediate language for equivalence checking of schedule. +- Add built-in verified SAT solver used for equivalence checking of + hyper-blocks. + +* 2021-10-01 - v1.2.2 + +Mainly fix some documentation and remove any ~Admitted~ theorems, even though +these were in parts of the compiler that were never used. + +* 2021-07-12 - v1.2.1 + +Main release for OOPSLA'21 paper. + +- Add better documentation on how to run Vericert. +- Add =Dockerfile= with instructions on how to get figures of the paper. + +* 2021-04-07 - v1.2.0 + +** New Features + +- Add memory inference capabilities in generated hardware. -** v1.1.0 - 2020-12-17 +* 2020-12-17 - v1.1.0 Add a stable release with all proofs completed. -** v1.0.1 - 2020-08-14 +* 2020-08-14 - v1.0.1 Release a new minor version fixing all proofs and fixing scripts to generate the badges. -*** Bug Fixes +** Fixes - Fix some of the proofs which were not passing. -** v1.0.0 - 2020-08-13 +* 2020-08-13 - v1.0.0 First release of a fully verified version of Vericert with support for the translation of many C constructs to Verilog. -*** New Features +** New Features - Most int instructions and operators. - Non-recursive function calls. - Local arrays, structs and unions of type int. - Pointer arithmetic with int. -** v0.1.0 - 2020-04-03 +* 2020-04-03 - v0.1.0 This is the first release with working HLS but without any proofs associated with it. diff --git a/CITATION.cff b/CITATION.cff new file mode 100644 index 0000000..c114ec6 --- /dev/null +++ b/CITATION.cff @@ -0,0 +1,46 @@ +# -*- mode: yaml -*- +cff-version: 1.2.0 +message: "If you use this software, please cite it as below." +authors: +- family-names: "Herklotz" + given-names: "Yann" + orcid: "https://orcid.org/0000-0002-2329-1029" +- family-names: "Pollard" + given-names: "James D." + orcid: "https://orcid.org/0000-0003-1404-1527" +- family-names: "Ramanathan" + given-names: "Nadesh" + orcid: "https://orcid.org/0000-0001-9083-8349" +- family-names: "Wickerson" + given-names: "John" + orcid: "https://orcid.org/0000-0001-6735-5533" +title: "Vericert" +version: 1.2.2 +doi: 10.5281/zenodo.5093839 +date-released: 2021-10-01 +url: "https://github.com/ymherklotz/vericert" +preferred-citation: + type: article + authors: + - family-names: "Herklotz" + given-names: "Yann" + orcid: "https://orcid.org/0000-0002-2329-1029" + - family-names: "Pollard" + given-names: "James D." + orcid: "https://orcid.org/0000-0003-1404-1527" + - family-names: "Ramanathan" + given-names: "Nadesh" + orcid: "https://orcid.org/0000-0001-9083-8349" + - family-names: "Wickerson" + given-names: "John" + orcid: "https://orcid.org/0000-0001-6735-5533" + doi: "10.1145/3485494" + journal: "Proc. ACM Program. Lang." + month: 11 + pages: 30 + title: "Formal Verification of High-Level Synthesis" + volume: 5 + year: 2021 + number: OOPSLA + publisher: Association for Computing Machinery + address: New York, NY, USA @@ -1,13 +1,3 @@ -Everything under src/ is licensed under the GPLv3 shown below, except for the -following files: - -src/SoftwarePipeline/*: MIT - - Copyright (c) 2008-2010 Jean-Baptiste Tristan and INRIA - Copyright (c) 2020-2021 Yann Herklotz - --------------------------------------------------------------------------------- - GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 @@ -682,25 +672,3 @@ may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read <https://www.gnu.org/licenses/why-not-lgpl.html>. - --------------------------------------------------------------------------------- - -Copyright (c) 2008,2009,2010 Jean-Baptiste Tristan and INRIA - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. @@ -31,8 +31,10 @@ all: lib/COMPCERTSTAMP $(MAKE) proof $(MAKE) compile -lib/COMPCERTSTAMP: +lib/CompCert/Makefile.config: lib/CompCert/configure (cd lib/CompCert && ./configure --ignore-coq-version $(ARCH)) + +lib/COMPCERTSTAMP: lib/CompCert/Makefile.config $(MAKE) HAS_RUNTIME_LIB=false CLIGHTGEN=false INSTALL_COQDEV=false -C lib/CompCert touch $@ @@ -52,7 +54,7 @@ doc: Makefile.coq extraction: src/extraction/STAMP test: - ./test/test_all.sh ./test + $(MAKE) -C test compile: src/extraction/STAMP @echo "OCaml bin/vericert" @@ -71,6 +73,7 @@ Makefile.coq: clean:: Makefile.coq $(MAKE) -f Makefile.coq clean + $(MAKE) -C test clean rm -f Makefile.coq clean:: @@ -1,23 +1,20 @@ -* Vericert - :PROPERTIES: -:CUSTOM_ID: vericert -:END: -#+html: <a href="https://github.com/ymherklotz/vericert/actions"><img src="https://github.com/ymherklotz/vericert/workflows/CI/badge.svg" /></a> -#+html: <a href="https://vericert.ymhg.org/"><img src="https://github.com/ymherklotz/vericert-docs/workflows/docs/badge.svg" /></a> +#+title: + +#+html: <a href="https://vericert.ymhg.org"><img src="https://vericert.ymhg.org/vericert-main.svg" width="100%" height="144" /></a> -A formally verified high-level synthesis (HLS) tool written in Coq, -building on top of [[https://github.com/AbsInt/CompCert][CompCert]]. -This ensures the correctness of the C to Verilog translation according -to our Verilog semantics and CompCert's C semantics, removing the need -to check the resulting hardware for behavioural correctness. +#+html: <p align=center><a href="https://github.com/ymherklotz/vericert/actions"><img src="https://github.com/ymherklotz/vericert/workflows/CI/badge.svg" /></a> <a href="https://vericert.ymhg.org/"><img src="https://github.com/ymherklotz/vericert-docs/workflows/docs/badge.svg" /></a></p> + +A formally verified high-level synthesis (HLS) tool written in Coq, building on top of [[https://github.com/AbsInt/CompCert][CompCert]]. +This ensures the correctness of the C to Verilog translation according to our Verilog semantics and +CompCert's C semantics, removing the need to check the resulting hardware for behavioural +correctness. ** Features :PROPERTIES: :CUSTOM_ID: features :END: -The project is currently a work in progress, so proofs remain to be -finished. Currently, the following C features are supported, but are not -all proven correct yet: + +Currently all proofs of the following features have been completed. - all int operations, - non-recursive function calls, @@ -28,66 +25,55 @@ all proven correct yet: :PROPERTIES: :CUSTOM_ID: building :END: -To build Vericert, the provided [[/Makefile][Makefile]] can be used. -External dependencies are needed to build the project, which can be -pulled in automatically with [[https://nixos.org/nix/][nix]] using the -provided [[/default.nix][default.nix]] and [[/shell.nix][shell.nix]] +To build Vericert, the provided [[/Makefile][Makefile]] can be used. External dependencies are needed to build the +project, which can be pulled in automatically with [[https://nixos.org/nix/][nix]] using the provided [[/default.nix][default.nix]] and [[/shell.nix][shell.nix]] files. -The project is written in Coq, a theorem prover, which is extracted to -OCaml so that it can then be compiled and executed. The dependencies of -this project are the following: - -- [[https://coq.inria.fr/][Coq]]: theorem prover that is used to also - program the HLS tool. -- [[https://ocaml.org/][OCaml]]: the OCaml compiler to compile the - extracted files. -- [[https://github.com/mit-plv/bbv][bbv]]: an efficient bit vector - library. -- [[https://github.com/ocaml/dune][dune]]: build tool for ocaml projects - to gather all the ocaml files and compile them in the right order. -- [[http://gallium.inria.fr/~fpottier/menhir/][menhir]]: parser - generator for ocaml. -- [[https://github.com/ocaml/ocamlfind][findlib]] to find installed - OCaml libraries. +The project is written in Coq, a theorem prover, which is extracted to OCaml so that it can then be +compiled and executed. The dependencies of this project are the following: + +- [[https://coq.inria.fr/][Coq]]: theorem prover that is used to also program the HLS tool. +- [[https://ocaml.org/][OCaml]]: the OCaml compiler to compile the extracted files. +- [[https://github.com/ocaml/dune][dune]]: build tool for ocaml projects to gather all the ocaml files and compile them in the right + order. +- [[http://gallium.inria.fr/~fpottier/menhir/][menhir]]: parser generator for ocaml. +- [[https://github.com/ocaml/ocamlfind][findlib]] to find installed OCaml libraries. - [[https://gcc.gnu.org/][GCC]]: compiler to help build CompCert. -These dependencies can be installed manually, or automatically through -Nix. +These dependencies can be installed manually, or automatically through Nix. -*** Downloading CompCert +*** Downloading Vericert and CompCert :PROPERTIES: :CUSTOM_ID: downloading-compcert :END: -CompCert is added as a submodule in the =lib/CompCert= directory. It is -needed to run the build process below, as it is the one dependency that -is not downloaded by nix, and has to be downloaded together with the -repository. To clone CompCert together with this project, you can run: +CompCert is added as a submodule in the =lib/CompCert= directory. It is needed to run the build +process below, as it is the one dependency that is not downloaded by nix, and has to be downloaded +together with the repository. To clone CompCert together with this project, and check it out at the +correct revision, you can run: #+begin_src shell - git clone --recursive https://github.com/ymherklotz/vericert +git clone -b v1.2.2 --recursive https://github.com/ymherklotz/vericert #+end_src -If the repository is already cloned, you can run the following command -to make sure that CompCert is also downloaded: +If the repository is already cloned, you can run the following command to make sure that CompCert is +also downloaded and the correct branch is checked out: #+begin_src shell - git submodule update --init +git checkout v1.2.2 +git submodule update --init #+end_src *** Setting up Nix :PROPERTIES: :CUSTOM_ID: setting-up-nix :END: -Nix is a package manager that can create an isolated environment so that -the builds are reproducible. Once nix is installed, it can be used in -the following way. +Nix is a package manager that can create an isolated environment so that the builds are +reproducible. Once nix is installed, it can be used in the following way. -To open a shell which includes all the necessary dependencies, one can -use: +To open a shell which includes all the necessary dependencies, one can use: #+begin_src shell - nix-shell +nix-shell #+end_src which will open a shell that has all the dependencies loaded. @@ -96,11 +82,11 @@ which will open a shell that has all the dependencies loaded. :PROPERTIES: :CUSTOM_ID: makefile-build :END: -If the dependencies were installed manually, or if one is in the -=nix-shell=, the project can be built by running: +If the dependencies were installed manually, or if one is in the =nix-shell=, the project can be built +by running: #+begin_src shell - make -j8 +make -j8 #+end_src and installed locally, or under the =PREFIX= location using: @@ -109,19 +95,50 @@ and installed locally, or under the =PREFIX= location using: make install #+end_src -Which will install the binary in =./bin/vericert= by default. However, -this can be changed by changing the =PREFIX= environment variable, in -which case the binary will be installed in =$PREFIX/bin/vericert=. +Which will install the binary in =./bin/vericert= by default. However, this can be changed by changing +the =PREFIX= environment variable, in which case the binary will be installed in =$PREFIX/bin/vericert=. ** Running :PROPERTIES: :CUSTOM_ID: running :END: -To test out =vericert= you can try the following examples which are in -the test folder using the following: +To test out =vericert= you can try the following examples which are in the test folder using the +following: #+begin_src shell - ./bin/vericert test/loop.c -o loop.v - ./bin/vericert test/conditional.c -o conditional.v - ./bin/vericert test/add.c -o add.v +./bin/vericert test/loop.c -o loop.v +./bin/vericert test/conditional.c -o conditional.v +./bin/vericert test/add.c -o add.v +#+end_src + +** Citation + +If you use Vericert in any way, please cite it using our [[https://yannherklotz.com/papers/fvhls_oopsla21.pdf][OOPSLA'21 paper]]: + +#+begin_src bibtex +@inproceedings{herklotz21_fvhls, + author = {Herklotz, Yann and Pollard, James D. and Ramanathan, Nadesh and Wickerson, John}, + title = {Formal Verification of High-Level Synthesis}, + year = {2021}, + number = {OOPSLA}, + numpages = {30}, + month = {11}, + journal = {Proc. ACM Program. Lang.}, + volume = {5}, + publisher = {Association for Computing Machinery}, + address = {New York, NY, USA}, + doi = {10.1145/3485494} +} +#+end_src + +** License + +This project is licensed under [[https://www.gnu.org/licenses/gpl-3.0.en.html][GPLv3]]. The license can be seen in [[/LICENSE][/LICENSE]]. + +The following external code and its license is present in this repository: + +- [[/src/SoftwarePipelining][/src/SoftwarePipelining]] :: MIT + +#+begin_src text +Copyright (c) 2008,2009,2010 Jean-Baptiste Tristan and INRIA #+end_src diff --git a/benchmarks/README.md b/benchmarks/README.md index 59edf78..c10f357 100644 --- a/benchmarks/README.md +++ b/benchmarks/README.md @@ -1,14 +1,11 @@ -Hi, +# Benchmarks -I have collected a set of benchmarks that you may be interested in. The main idea is to run the existing HLS benchmarks to see if they work - they can only test correctness for a single set of input by a customised test bench. +The main idea is to run the existing HLS benchmarks to see if they work - they can only test correctness for a single set of input by a customised test bench. -* jacob_2d: a benchmark from Polybench -* sobel: a benchmark from LegUp HLS -* getTanh: a benchmark from DASS -* fft: a benchmark from MachSuite -* KMeans: a benchmark from Felix's work +- jacob_2d: a benchmark from Polybench +- sobel: a benchmark from LegUp HLS +- getTanh: a benchmark from DASS +- fft: a benchmark from MachSuite +- KMeans: a benchmark from Felix's work -Note all the benchmark set above (links included in the source code) should be all synthesisable in your case, so you may be show coverage instead of a single benchmark. - -Best, -Jianyi +Note all the benchmark set above (links included in the source code) should be all synthesisable, so you may be able to show coverage instead of a single benchmark. diff --git a/benchmarks/polybench-syn-div/Makefile b/benchmarks/polybench-syn-div/Makefile new file mode 100644 index 0000000..2c20246 --- /dev/null +++ b/benchmarks/polybench-syn-div/Makefile @@ -0,0 +1,15 @@ +all: + $(MAKE) -C stencils + $(MAKE) -C medley + $(MAKE) -C linear-algebra/blas + $(MAKE) -C linear-algebra/kernels + $(MAKE) -C linear-algebra/solvers + $(MAKE) -C data-mining + +clean: + $(MAKE) clean -C stencils + $(MAKE) clean -C medley + $(MAKE) clean -C linear-algebra/blas + $(MAKE) clean -C linear-algebra/kernels + $(MAKE) clean -C linear-algebra/solvers + $(MAKE) clean -C data-mining diff --git a/benchmarks/polybench-syn-div/benchmark-list-master b/benchmarks/polybench-syn-div/benchmark-list-master new file mode 100644 index 0000000..ef0d0d0 --- /dev/null +++ b/benchmarks/polybench-syn-div/benchmark-list-master @@ -0,0 +1,27 @@ +stencils/adi +stencils/heat-3d +stencils/fdtd-2d +stencils/jacobi-1d +stencils/seidel-2d +stencils/jacobi-2d +medley/nussinov +medley/floyd-warshall +linear-algebra/kernels/3mm +linear-algebra/kernels/2mm +linear-algebra/kernels/doitgen +linear-algebra/kernels/bicg +linear-algebra/kernels/mvt +linear-algebra/kernels/atas +linear-algebra/blas/syrk +linear-algebra/blas/gemver +linear-algebra/blas/symm +linear-algebra/blas/gesummv +linear-algebra/blas/gemm +linear-algebra/blas/trmm +linear-algebra/blas/syr2k +linear-algebra/solvers/cholesky +linear-algebra/solvers/trisolv +linear-algebra/solvers/lu +linear-algebra/solvers/ludcmp +linear-algebra/solvers/durbin +data-mining/covariance diff --git a/benchmarks/polybench-syn-div/common.mk b/benchmarks/polybench-syn-div/common.mk new file mode 100644 index 0000000..fbada0b --- /dev/null +++ b/benchmarks/polybench-syn-div/common.mk @@ -0,0 +1,33 @@ +VERICERT ?= vericert +VERICERT_OPTS ?= -DSYNTHESIS + +IVERILOG ?= iverilog +IVERILOG_OPTS ?= + +TARGETS ?= + +%.v: %.c + $(VERICERT) $(VERICERT_OPTS) $< -o $@ + +%.iver: %.v + $(IVERILOG) -o $@ $(IVERILOG_OPTS) $< + +%.gcc: %.c + $(CC) $(CFLAGS) $< -o $@ + +%: %.iver %.gcc + cp $< $@ + +all: $(TARGETS) + +clean: + rm -f *.iver + rm -f *.v + rm -f *.gcc + rm -f *.clog + rm -f *.tmp + rm -f $(TARGETS) + +.PRECIOUS: %.v %.gcc %.iver +.PHONY: all clean +.SUFFIXES: diff --git a/benchmarks/polybench-syn-div/data-mining/Makefile b/benchmarks/polybench-syn-div/data-mining/Makefile new file mode 100644 index 0000000..d4817a0 --- /dev/null +++ b/benchmarks/polybench-syn-div/data-mining/Makefile @@ -0,0 +1,3 @@ +TARGETS := covariance + +include ../common.mk diff --git a/benchmarks/polybench-syn-div/data-mining/covariance.c b/benchmarks/polybench-syn-div/data-mining/covariance.c new file mode 100644 index 0000000..88de67e --- /dev/null +++ b/benchmarks/polybench-syn-div/data-mining/covariance.c @@ -0,0 +1,113 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* covariance.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS +#include <stdio.h> +#endif + + +#define plus(i) i = i + ONE +static +void init_array (int m, int n, + int *float_n, + int data[ 32 + 0][28 + 0]) +{ + int i, j; + int ONE = 1; + + *float_n = (int)n; + + for (i = 0; i < 32; plus(i)) + for (j = 0; j < 28; plus(j)) + data[i][j] = ((int) i*j) / (27+ONE); +} + + + + +static +int print_array(int m, + int cov[ 28 + 0][28 + 0]) + +{ + int i, j; + int ONE = 1; + int res = 0; + for (i = 0; i < m; plus(i)) + for (j = 0; j < m; plus(j)) { + res ^= cov[i][j]; + } +#ifndef SYNTHESIS + printf("finished: %u\n", res); +#endif + return res; +} + + + + +static +void kernel_covariance(int m, int n, + int float_n, + int data[ 32 + 0][28 + 0], + int cov[ 28 + 0][28 + 0], + int mean[ 28 + 0]) +{ + int i, j, k; + int ONE = 1; + + for (j = 0; j < m; plus(j)) + { + mean[j] = 0; + for (i = 0; i < n; plus(i)) + mean[j] += data[i][j]; + mean[j] = mean[j] / float_n; + } + + for (i = 0; i < n; plus(i)) + for (j = 0; j < m; plus(j)) + data[i][j] -= mean[j]; + + for (i = 0; i < m; plus(i)) + for (j = i; j < m; plus(j)) + { + cov[i][j] = 0; + for (k = 0; k < n; plus(k)) + cov[i][j] += data[k][i] * data[k][j]; + cov[i][j] = cov[i][j] / (float_n - ONE); + cov[j][i] = cov[i][j]; + } + +} + + +int main() +{ + + int n = 32; + int m = 28; + + + int float_n; + int data[32 + 0][28 + 0]; + int mean[28 + 0]; + int cov[28 + 0][28 + 0]; + + init_array (m, n, &float_n, data); + + kernel_covariance (m, n, float_n, + data, + cov, + mean); + + return print_array(m, cov); + +} diff --git a/benchmarks/polybench-syn-div/exec.csv b/benchmarks/polybench-syn-div/exec.csv new file mode 100644 index 0000000..e28109b --- /dev/null +++ b/benchmarks/polybench-syn-div/exec.csv @@ -0,0 +1,27 @@ +adi,1422354 +heat-3d,580770 +fdtd-2d,901430 +jacobi-1d,19622 +seidel-2d,664780 +jacobi-2d,344072 +nussinov,954402 +floyd-warshall,5373798 +3mm,536114 +2mm,404478 +doitgen,351988 +bicg,53916 +mvt,70204 +atas,58424 +syrk,271816 +gemver,117394 +symm,240172 +gesummv,37700 +gemm,328104 +trmm,144688 +syr2k,436520 +cholesky,2535686 +trisolv,25192 +lu,2853646 +ludcmp,2601382 +durbin,22974 +covariance,288392 diff --git a/benchmarks/polybench-syn-div/include/misc.h b/benchmarks/polybench-syn-div/include/misc.h new file mode 100644 index 0000000..664677c --- /dev/null +++ b/benchmarks/polybench-syn-div/include/misc.h @@ -0,0 +1,105 @@ +unsigned int modulo(unsigned int x, unsigned int y) +{ + unsigned int r0, q0, y0, y1; + + r0 = x; + q0 = 0; + y0 = y; + y1 = y; + do + { + y1 = 2 * y1; + } + while (y1 <= x); + do + { + y1 = y1 / 2; + q0 = 2 * q0; + if (r0 >= y1) + { + r0 = r0 - y1; + q0 = q0 + 1; + } + } + while ((int)y1 != (int)y0); + return r0; +} + +int smodulo(int N, int D) { + if (D < 0) { + if (N < 0) + return modulo(-N, -D); + else + return -modulo(N, -D); + } else { + if (N < 0) + return -modulo(-N, D); + else + return modulo(N, D); + } +} + +unsigned divider_fast(unsigned x, unsigned y) { + unsigned r0, q0, y0, y1; + + r0 = x; + q0 = 0; + y0 = y; + y1 = y; + do { + y1 = 2 * y1; + } while (y1 <= x); + do { + y1 /= 2; + q0 *= 2; + if (r0 >= y1) { + r0 -= y1; + q0++; + } + } while ((int)y1 != (int)y0); + return q0; +} + +unsigned divider(unsigned x, unsigned y) { + unsigned q0, acc; + q0 = 0; + acc = y; + + while (acc <= x) { + q0++; + acc += y; + } + + return q0; +} + +/* + * Signed division operation for faster frequency division. + */ +int sdivider(int N, int D) { + if (D < 0) { + if (N < 0) + return divider(-N, -D); + else + return -divider(N, -D); + } else { + if (N < 0) + return -divider(-N, D); + else + return divider(N, D); + } +} + +int sdivider_fast(int N, int D) { + if (D < 0) { + if (N < 0) + return divider_fast(-N, -D); + else + return -divider_fast(N, -D); + } else { + if (N < 0) + return -divider_fast(-N, D); + else + return divider_fast(N, D); + } +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/blas/Makefile b/benchmarks/polybench-syn-div/linear-algebra/blas/Makefile new file mode 100644 index 0000000..e1f3b58 --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/blas/Makefile @@ -0,0 +1,3 @@ +TARGETS := gemm gemver gesummv symm syr2k syrk trmm + +include ../../common.mk diff --git a/benchmarks/polybench-syn-div/linear-algebra/blas/gemm.c b/benchmarks/polybench-syn-div/linear-algebra/blas/gemm.c new file mode 100644 index 0000000..a2c507f --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/blas/gemm.c @@ -0,0 +1,115 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* gemm.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS + #include <stdio.h> +#endif +#define plus(i) i = i + ONE + static +void init_array(int ni, int nj, int nk, + int *alpha, + int *beta, + int C[ 20 + 0][25 + 0], + int A[ 20 + 0][30 + 0], + int B[ 30 + 0][25 + 0]) +{ + int i, j; + int ONE = 1; + + *alpha = 2; + *beta = 2; + for (i = 0; i < ni; plus(i)) + for (j = 0; j < nj; plus(j)) + C[i][j] = (int) ((i*j+ONE) % ni) / ni; + for (i = 0; i < ni; plus(i)) + for (j = 0; j < nk; plus(j)) + A[i][j] = (int) (((i*(j+ONE)) % nk) / nk); + for (i = 0; i < nk; plus(i)) + for (j = 0; j < nj; plus(j)) + B[i][j] = (int) (((i*(j+ONE+ONE)) % nj) / nj); +} + + + + + static +int print_array(int ni, int nj, + int C[ 20 + 0][25 + 0]) +{ + int i, j; + int ONE = 1; + int res = 0; + for (i = 0; i < ni; plus(i)) + for (j = 0; j < nj; plus(j)) { + res ^= C[i][j]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + static +void kernel_gemm(int ni, int nj, int nk, + int alpha, + int beta, + int C[ 20 + 0][25 + 0], + int A[ 20 + 0][30 + 0], + int B[ 30 + 0][25 + 0]) +{ + int i, j, k; + int ONE = 1; + + for (i = 0; i < ni; plus(i)) { + for (j = 0; j < nj; plus(j)) + C[i][j] *= beta; + for (k = 0; k < nk; plus(k)) { + for (j = 0; j < nj; plus(j)) + C[i][j] += alpha * A[i][k] * B[k][j]; + } + } + +} + + +int main() +{ + + int ni = 20; + int nj = 25; + int nk = 30; + + + int alpha; + int beta; + int C[20 + 0][25 + 0]; + int A[20 + 0][30 + 0]; + int B[30 + 0][25 + 0]; + + + init_array (ni, nj, nk, &alpha, &beta, + C, + A, + B); + + + kernel_gemm (ni, nj, nk, + alpha, beta, + C, + A, + B); + + + return + print_array(ni, nj, C); + + +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/blas/gemver.c b/benchmarks/polybench-syn-div/linear-algebra/blas/gemver.c new file mode 100644 index 0000000..de8dd04 --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/blas/gemver.c @@ -0,0 +1,155 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* gemver.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS + #include <stdio.h> +#endif +#define plus(i) i = i + ONE +static +void init_array (int n, + int *alpha, + int *beta, + int A[ 40 + 0][40 + 0], + int u1[ 40 + 0], + int v1[ 40 + 0], + int u2[ 40 + 0], + int v2[ 40 + 0], + int w[ 40 + 0], + int x[ 40 + 0], + int y[ 40 + 0], + int z[ 40 + 0]) +{ + int i, j; + int ONE = 1; + + *alpha = 3; + *beta = 2; + + int fn = (int)n; + + for (i = 0; i < n; plus(i)) + { + u1[i] = i; + u2[i] = ((i+ONE)/(fn*2)); + v1[i] = ((i+ONE)/(fn*4)); + v2[i] = ((i+ONE)/(fn*6)); + y[i] = ((i+ONE)/(fn*8)); + z[i] = ((i+ONE)/(fn*9)); + x[i] = 0; + w[i] = 0; + for (j = 0; j < n; plus(j)) + A[i][j] = (int) (((i*j) % n) / n); + } +} + + + + +static +int print_array(int n, + int w[ 40 + 0]) +{ + int i; + int ONE = 1; + int res = 0; + + for (i = 0; i < n; plus(i)) { + res ^= w[i]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + + + +static +void kernel_gemver(int n, + int alpha, + int beta, + int A[ 40 + 0][40 + 0], + int u1[ 40 + 0], + int v1[ 40 + 0], + int u2[ 40 + 0], + int v2[ 40 + 0], + int w[ 40 + 0], + int x[ 40 + 0], + int y[ 40 + 0], + int z[ 40 + 0]) +{ + int i, j; + int ONE = 1; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) + A[i][j] = A[i][j] + u1[i] * v1[j] + u2[i] * v2[j]; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) + x[i] = x[i] + beta * A[j][i] * y[j]; + + for (i = 0; i < n; plus(i)) + x[i] = x[i] + z[i]; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) + w[i] = w[i] + alpha * A[i][j] * x[j]; + +} + + +int main() +{ + + int n = 40; + + + int alpha; + int beta; + int A[40 + 0][40 + 0]; + int u1[40 + 0]; + int v1[40 + 0]; + int u2[40 + 0]; + int v2[40 + 0]; + int w[40 + 0]; + int x[40 + 0]; + int y[40 + 0]; + int z[40 + 0]; + + + + init_array (n, &alpha, &beta, + A, + u1, + v1, + u2, + v2, + w, + x, + y, + z); + + kernel_gemver (n, alpha, beta, + A, + u1, + v1, + u2, + v2, + w, + x, + y, + z); + + return print_array(n, w); + +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/blas/gesummv.c b/benchmarks/polybench-syn-div/linear-algebra/blas/gesummv.c new file mode 100644 index 0000000..457d6a8 --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/blas/gesummv.c @@ -0,0 +1,116 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* gesummv.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS + #include <stdio.h> +#endif + +#define plus(i) i = i + ONE + + static +void init_array(int n, + int *alpha, + int *beta, + int A[ 30 + 0][30 + 0], + int B[ 30 + 0][30 + 0], + int x[ 30 + 0]) +{ + int i, j; + int ONE = 1; + + *alpha = 3; + *beta = 2; + for (i = 0; i < n; plus(i)) + { + x[i] = (int) ((i % n) / n); + for (j = 0; j < n; plus(j)) { + A[i][j] = (int) (((i*j+ONE) % n) / n); + B[i][j] = (int) (((i*j+ONE+ONE) % n) / n); + } + } +} + + + static +int print_array(int n, + int y[ 30 + 0]) + +{ + int i; + int ONE = 1; + int res = 0; + + for (i = 0; i < n; plus(i)) { + res ^= y[i]; + } +#ifndef SYNTHESIS + printf("finished: %u\n", res); +#endif + return res; +} + + static +void kernel_gesummv(int n, + int alpha, + int beta, + int A[ 30 + 0][30 + 0], + int B[ 30 + 0][30 + 0], + int tmp[ 30 + 0], + int x[ 30 + 0], + int y[ 30 + 0]) +{ + int i, j; + int ONE = 1; + + for (i = 0; i < n; plus(i)) + { + tmp[i] = 0; + y[i] = 0; + for (j = 0; j < n; plus(j)) + { + tmp[i] = A[i][j] * x[j] + tmp[i]; + y[i] = B[i][j] * x[j] + y[i]; + } + y[i] = alpha * tmp[i] + beta * y[i]; + } +} + + +int main() +{ + + int n = 30; + + + int alpha; + int beta; + int A[30 + 0][30 + 0]; + int B[30 + 0][30 + 0]; + int tmp[30 + 0]; + int x[30 + 0]; + int y[30 + 0]; + + init_array (n, &alpha, &beta, + A, + B, + x); + + kernel_gesummv (n, alpha, beta, + A, + B, + tmp, + x, + y); + + + return print_array(n, y); + +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/blas/symm.c b/benchmarks/polybench-syn-div/linear-algebra/blas/symm.c new file mode 100644 index 0000000..6c20b5b --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/blas/symm.c @@ -0,0 +1,114 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* symm.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS + #include <stdio.h> +#endif +#define plus(i) i = i + ONE +static +void init_array(int m, int n, + int *alpha, + int *beta, + int C[ 20 + 0][30 + 0], + int A[ 20 + 0][20 + 0], + int B[ 20 + 0][30 + 0]) +{ + int i, j; + int ONE = 1; + int HUND = 100; + + *alpha = 3; + *beta = 2; + for (i = 0; i < m; plus(i)) + for (j = 0; j < n; plus(j)) { + C[i][j] = (int) (((i+j) % HUND) / m); + B[i][j] = (int) (((n+i-j) % HUND) / m); + } + for (i = 0; i < m; plus(i)) { + for (j = 0; j <=i; plus(j)) + A[i][j] = (int) (((i+j) % HUND) / m); + for (j = i+ONE; j < m; plus(j)) + A[i][j] = -999; + } +} + +static +int print_array(int m, int n, + int C[ 20 + 0][30 + 0]) +{ + int i, j; + int ONE = 1; + int res = 0; + + for (i = 0; i < m; plus(i)) + for (j = 0; j < n; plus(j)) { + res ^= C[i][j]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + +static +void kernel_symm(int m, int n, + int alpha, + int beta, + int C[ 20 + 0][30 + 0], + int A[ 20 + 0][20 + 0], + int B[ 20 + 0][30 + 0]) +{ + int ONE = 1; + int i, j, k; + int temp2; + for (i = 0; i < m; plus(i)) + for (j = 0; j < n; plus(j) ) + { + temp2 = 0; + for (k = 0; k < i; plus(k)) { + C[k][j] += alpha*B[i][j] * A[i][k]; + temp2 += B[k][j] * A[i][k]; + } + C[i][j] = beta * C[i][j] + alpha*B[i][j] * A[i][i] + alpha * temp2; + } + +} + + +int main() +{ + + int m = 20; + int n = 30; + + int alpha; + int beta; + int C[20 + 0][30 + 0]; + int A[20 + 0][20 + 0]; + int B[20 + 0][30 + 0]; + + + init_array (m, n, &alpha, &beta, + C, + A, + B); + + kernel_symm (m, n, + alpha, beta, + C, + A, + B); + + return + print_array(m, n, C); + +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/blas/syr2k.c b/benchmarks/polybench-syn-div/linear-algebra/blas/syr2k.c new file mode 100644 index 0000000..a1c0934 --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/blas/syr2k.c @@ -0,0 +1,123 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* syr2k.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS + #include <stdio.h> +#endif +#define plus(i) i = i + ONE +static +void init_array(int n, int m, + int *alpha, + int *beta, + int C[ 30 + 0][30 + 0], + int A[ 30 + 0][20 + 0], + int B[ 30 + 0][20 + 0]) +{ + int i, j; + int ONE = 1; + + *alpha = 3; + *beta = 2; + for (i = 0; i < n; plus(i)) + for (j = 0; j < m; plus(j)) { + A[i][j] = (int) (((i*j+ONE) % n) / n); + B[i][j] = (int) (((i*j+ONE+ONE) % m) / m); + } + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) { + C[i][j] = (int) (((i*j+4-ONE) % n) / m); + } +} + + + + +static +int print_array(int n, + int C[ 30 + 0][30 + 0]) +{ + int i, j; + int ONE = 1; + int res = 0; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) { + res ^= C[i][j]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + +static +void kernel_syr2k(int n, int m, + int alpha, + int beta, + int C[ 30 + 0][30 + 0], + int A[ 30 + 0][20 + 0], + int B[ 30 + 0][20 + 0]) +{ + int i, j, k; + int ONE = 1; + + for (i = 0; i < n; plus(i)) { + for (j = 0; j <= i; plus(j)) + C[i][j] *= beta; + for (k = 0; k < m; plus(k)) + for (j = 0; j <= i; plus(j)) + { + C[i][j] += A[j][k]*alpha*B[i][k] + B[j][k]*alpha*A[i][k]; + } + } + +} + + +int main() +{ + + int n = 30; + int m = 20; + + + int alpha; + int beta; + int C[30 + 0][30 + 0]; + int A[30 + 0][20 + 0]; + int B[30 + 0][20 + 0]; + + + init_array (n, m, &alpha, &beta, + C, + A, + B); + + + ; + + + kernel_syr2k (n, m, + alpha, beta, + C, + A, + B); + + + ; + ; + + + + return print_array(n, C); + +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/blas/syrk.c b/benchmarks/polybench-syn-div/linear-algebra/blas/syrk.c new file mode 100644 index 0000000..46ae322 --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/blas/syrk.c @@ -0,0 +1,109 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* syrk.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS + #include <stdio.h> +#endif +#define plus(i) i = i + ONE +static +void init_array(int n, int m, + int *alpha, + int *beta, + int C[ 30 + 0][30 + 0], + int A[ 30 + 0][20 + 0]) +{ + int i, j; + int ONE = 1; + + *alpha = 3; + *beta = 2; + for (i = 0; i < n; plus(i)) + for (j = 0; j < m; plus(j)) + A[i][j] = (int) (((i*j+ONE) % n) / n); + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) + C[i][j] = (int) (((i*j+ONE+ONE) % m) / m); +} + + +static +int print_array(int n, + int C[ 30 + 0][30 + 0]) +{ + int i, j; + int ONE = 1; + int res = 0; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) { + res ^= C[i][j]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + + + +static +void kernel_syrk(int n, int m, + int alpha, + int beta, + int C[ 30 + 0][30 + 0], + int A[ 30 + 0][20 + 0]) +{ + int i, j, k; + int ONE = 1; + + for (i = 0; i < n; plus(i)) { + for (j = 0; j <= i; plus(j)) + C[i][j] *= beta; + for (k = 0; k < m; plus(k)) { + for (j = 0; j <= i; plus(j)) + C[i][j] += alpha * A[i][k] * A[j][k]; + } + } + +} + + +int main() +{ + + int n = 30; + int m = 20; + + + int alpha; + int beta; + int C[30 + 0][30 + 0]; + int A[30 + 0][20 + 0]; + + + init_array (n, m, &alpha, &beta, C, A); + + + ; + + + kernel_syrk (n, m, alpha, beta, C, A); + + + ; + ; + + + + return print_array(n, C); + +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/blas/trmm.c b/benchmarks/polybench-syn-div/linear-algebra/blas/trmm.c new file mode 100644 index 0000000..3fdbc45 --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/blas/trmm.c @@ -0,0 +1,99 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* trmm.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS + #include <stdio.h> +#endif +#define plus(i) i = i + ONE + static +void init_array(int m, int n, + int *alpha, + int A[ 20 + 0][20 + 0], + int B[ 20 + 0][30 + 0]) +{ + int i, j; + int ONE = 1; + + *alpha = 3; + for (i = 0; i < m; plus(i)) { + for (j = 0; j < i; plus(j)) { + A[i][j] = (int) (((i+j) % m) / m); + } + A[i][i] = 1; + for (j = 0; j < n; plus(j)) { + B[i][j] = (int)(((n+i-j) % n) / n); + } + } + +} + + + + + static +int print_array(int m, int n, + int B[ 20 + 0][30 + 0]) +{ + int i, j; + int ONE = 1; + int res = 0; + + for (i = 0; i < m; plus(i)) + for (j = 0; j < n; plus(j)) { + res ^= B[i][j]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + + + + static +void kernel_trmm(int m, int n, + int alpha, + int A[ 20 + 0][20 + 0], + int B[ 20 + 0][30 + 0]) +{ + int i, j, k; + int ONE = 1; + for (i = 0; i < m; plus(i)) + for (j = 0; j < n; plus(j)) { + for (k = i+ONE; k < m; plus(k)) + B[i][j] += A[k][i] * B[k][j]; + B[i][j] = alpha * B[i][j]; + } + +} + + +int main() +{ + + int m = 20; + int n = 30; + + + int alpha; + int A[20 + 0][20 + 0]; + int B[20 + 0][30 + 0]; + + + init_array (m, n, &alpha, A, B); + + + kernel_trmm (m, n, alpha, A, B); + + return print_array(m, n, B); + +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/kernels/2mm.c b/benchmarks/polybench-syn-div/linear-algebra/kernels/2mm.c new file mode 100644 index 0000000..0b6677f --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/kernels/2mm.c @@ -0,0 +1,132 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* 2mm.c: this file is part of PolyBench/C */ + + +#ifndef SYNTHESIS + #include <stdio.h> +#endif + +#define plus(i) i = i + ONE +static +void init_array(int ni, int nj, int nk, int nl, + int *alpha, + int *beta, + int A[ 16 + 0][22 + 0], + int B[ 22 + 0][18 + 0], + int C[ 18 + 0][24 + 0], + int D[ 16 + 0][24 + 0]) +{ + int i, j; + int ONE = 1; + + *alpha = 2; + *beta = 2; + for (i = 0; i < ni; plus(i)) + for (j = 0; j < nk; plus(j)) + A[i][j] = (int) (((i*j+ONE) % ni) / ni); + for (i = 0; i < nk; plus(i)) + for (j = 0; j < nj; plus(j)) + B[i][j] = (int) (((i*(j+ONE)) % nj) / nj); + for (i = 0; i < nj; plus(i)) + for (j = 0; j < nl; plus(j)) + C[i][j] = (int) (((i*(j+ONE+ONE+ONE)+ONE) % nl) / nl); + for (i = 0; i < ni; plus(i)) + for (j = 0; j < nl; plus(j)) + D[i][j] = (int) (((i*(j+ONE+ONE)) % nk) / nk); +} + +static +int print_array(int ni, int nl, + int D[ 16 + 0][24 + 0]) +{ + int i, j; + int ONE = 1; + int res = 0; + for (i = 0; i < ni; plus(i)) + for (j = 0; j < nl; plus(j)) { + res ^= D[i][j]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + + + +static +void kernel_2mm(int ni, int nj, int nk, int nl, + int alpha, + int beta, + int tmp[ 16 + 0][18 + 0], + int A[ 16 + 0][22 + 0], + int B[ 22 + 0][18 + 0], + int C[ 18 + 0][24 + 0], + int D[ 16 + 0][24 + 0]) +{ + int ONE = 1; + int i, j, k; + + for (i = 0; i < ni; plus(i)) + for (j = 0; j < nj; plus(j)) + { + tmp[i][j] = 0; + for (k = 0; k < nk; plus(k)) + tmp[i][j] += alpha * A[i][k] * B[k][j]; + } + for (i = 0; i < ni; plus(i)) + for (j = 0; j < nl; plus(j)) + { + D[i][j] *= beta; + for (k = 0; k < nj; plus(k)) + D[i][j] += tmp[i][k] * C[k][j]; + } + +} + + +int main() +{ + + int ni = 16; + int nj = 18; + int nk = 22; + int nl = 24; + + int alpha; + int beta; + int tmp[16 + 0][18 + 0]; + int A[16 + 0][22 + 0]; + int B[22 + 0][18 + 0]; + int C[18 + 0][24 + 0]; + int D[16 + 0][24 + 0]; + + + init_array (ni, nj, nk, nl, &alpha, &beta, + A, + B, + C, + D); + + + kernel_2mm (ni, nj, nk, nl, + alpha, beta, + tmp, + A, + B, + C, + D); + + + return print_array(ni, nl, D); + +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/kernels/3mm.c b/benchmarks/polybench-syn-div/linear-algebra/kernels/3mm.c new file mode 100644 index 0000000..d0b086b --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/kernels/3mm.c @@ -0,0 +1,142 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* 3mm.c: this file is part of PolyBench/C */ + + +#ifndef SYNTHESIS + #include <stdio.h> +#endif + +#define plus(i) i = i + ONE +static +void init_array(int ni, int nj, int nk, int nl, int nm, + int A[ 16 + 0][20 + 0], + int B[ 20 + 0][18 + 0], + int C[ 18 + 0][24 + 0], + int D[ 24 + 0][22 + 0]) +{ + int i, j; + int ONE = 1; + int TWO = 2; + int THREE = 3; + + for (i = 0; i < ni; plus(i)) + for (j = 0; j < nk; plus(j)) + A[i][j] = (int) (((i*j+ONE) % ni) / (5*ni)); + for (i = 0; i < nk; plus(i)) + for (j = 0; j < nj; plus(j)) + B[i][j] = (int) (((i*(j+ONE)+TWO) % nj) / (5*nj)); + for (i = 0; i < nj; plus(i)) + for (j = 0; j < nm; plus(j)) + C[i][j] = (int) (((i*(j+THREE)) % nl) / (5*nl)); + for (i = 0; i < nm; plus(i)) + for (j = 0; j < nl; plus(j)) + D[i][j] = (int) (((i*(j+TWO)+TWO) % nk) / (5*nk)); +} + + +static +int print_array(int ni, int nl, + int G[ 16 + 0][22 + 0]) +{ + int i, j; + int ONE = 1; + int res = 0; + + for (i = 0; i < ni; plus(i)) + for (j = 0; j < nl; plus(j)) { + res ^= G[i][j]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + + + +static +void kernel_3mm(int ni, int nj, int nk, int nl, int nm, + int E[ 16 + 0][18 + 0], + int A[ 16 + 0][20 + 0], + int B[ 20 + 0][18 + 0], + int F[ 18 + 0][22 + 0], + int C[ 18 + 0][24 + 0], + int D[ 24 + 0][22 + 0], + int G[ 16 + 0][22 + 0]) +{ + int ONE = 1; + int i, j, k; + + for (i = 0; i < ni; plus(i)) + for (j = 0; j < nj; plus(j)) + { + E[i][j] = 0; + for (k = 0; k < nk; plus(k)) + E[i][j] += A[i][k] * B[k][j]; + } + + for (i = 0; i < nj; plus(i)) + for (j = 0; j < nl; plus(j)) + { + F[i][j] = 0; + for (k = 0; k < nm; plus(k)) + F[i][j] += C[i][k] * D[k][j]; + } + + for (i = 0; i < ni; plus(i)) + for (j = 0; j < nl; plus(j)) + { + G[i][j] = 0; + for (k = 0; k < nj; plus(k)) + G[i][j] += E[i][k] * F[k][j]; + } + +} + +int main() +{ + + int ni = 16; + int nj = 18; + int nk = 20; + int nl = 22; + int nm = 24; + + + int E[16 + 0][18 + 0]; + int A[16 + 0][20 + 0]; + int B[20 + 0][18 + 0]; + int F[18 + 0][22 + 0]; + int C[18 + 0][24 + 0]; + int D[24 + 0][22 + 0]; + int G[16 + 0][22 + 0]; + + + init_array (ni, nj, nk, nl, nm, + A, + B, + C, + D); + + kernel_3mm (ni, nj, nk, nl, nm, + E, + A, + B, + F, + C, + D, + G); + + + return print_array(ni, nl, G); + +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/kernels/Makefile b/benchmarks/polybench-syn-div/linear-algebra/kernels/Makefile new file mode 100644 index 0000000..4b7f6e1 --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/kernels/Makefile @@ -0,0 +1,3 @@ +TARGETS := 2mm 3mm atas bicg doitgen mvt + +include ../../common.mk diff --git a/benchmarks/polybench-syn-div/linear-algebra/kernels/atas.c b/benchmarks/polybench-syn-div/linear-algebra/kernels/atas.c new file mode 100644 index 0000000..970465b --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/kernels/atas.c @@ -0,0 +1,103 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* atax.c: this file is part of PolyBench/C */ + +#include "../../include/misc.h" + +#ifndef SYNTHESIS + #include <stdio.h> +#endif + +#define plus(i) i = i + ONE +static +void init_array (int m, int n, + int A[ 38 + 0][42 + 0], + int x[ 42 + 0]) +{ + int ONE = 1; + int i, j; + int fn; + fn = (int)n; + + for (i = 0; i < n; plus(i)) + x[i] = ONE + (i / fn); + for (i = 0; i < m; plus(i)) + for (j = 0; j < n; plus(j)) + A[i][j] = (int) (((i+j) % n) / (5*m)); +} + + +static +int print_array(int n, + int y[ 42 + 0]) + +{ + int i; + int ONE = 1; + int res = 0; + + for (i = 0; i < n; plus(i)) { + res ^= y[i]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + +static +void kernel_atax(int m, int n, + int A[ 38 + 0][42 + 0], + int x[ 42 + 0], + int y[ 42 + 0], + int tmp[ 38 + 0]) +{ + int i, j; + int ONE = 1; + + for (i = 0; i < n; plus(i)) + y[i] = 0; + for (i = 0; i < m; plus(i)) + { + tmp[i] = 0; + for (j = 0; j < n; plus(j)) + tmp[i] = tmp[i] + A[i][j] * x[j]; + for (j = 0; j < n; plus(j)) + y[j] = y[j] + A[i][j] * tmp[i]; + } + +} + + +int main() +{ + + int m = 38; + int n = 42; + + + int A[38 + 0][42 + 0]; + int x[42 + 0]; + int y[42 + 0]; + int tmp[38 + 0]; + + init_array (m, n, A, x); + + kernel_atax (m, n, + A, + x, + y, + tmp); + + + return print_array(n, y); + +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/kernels/bicg.c b/benchmarks/polybench-syn-div/linear-algebra/kernels/bicg.c new file mode 100644 index 0000000..4d1f9b6 --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/kernels/bicg.c @@ -0,0 +1,120 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* bicg.c: this file is part of PolyBench/C */ + + +#ifndef SYNTHESIS + #include <stdio.h> +#endif + +#define plus(i) i = i + ONE +static +void init_array (int m, int n, + int A[ 42 + 0][38 + 0], + int r[ 42 + 0], + int p[ 38 + 0]) +{ + int i, j; + int ONE = 1; + + for (i = 0; i < m; plus(i)) + p[i] = ((i % m) / m); + for (i = 0; i < n; plus(i)) { + r[i] = ((i % n) / n); + for (j = 0; j < m; plus(j)) + A[i][j] = (((i*(j+ONE)) % n) / n); + } +} + + + + +static +int print_array(int m, int n, + int s[ 38 + 0], + int q[ 42 + 0]) + +{ + int i; + int ONE = 1; + int res = 0; + + for (i = 0; i < m; plus(i)) { + res ^= s[i]; + } + for (i = 0; i < n; plus(i)) { + res ^= q[i]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + + + +static +void kernel_bicg(int m, int n, + int A[ 42 + 0][38 + 0], + int s[ 38 + 0], + int q[ 42 + 0], + int p[ 38 + 0], + int r[ 42 + 0]) +{ + int i, j; + int ONE = 1; + + for (i = 0; i < m; plus(i)) + s[i] = 0; + for (i = 0; i < n; plus(i)) + { + q[i] = 0; + for (j = 0; j < m; plus(j)) + { + s[j] = s[j] + r[i] * A[i][j]; + q[i] = q[i] + A[i][j] * p[j]; + } + } + +} + + +int main() +{ + + int n = 42; + int m = 38; + + + int A[42 + 0][38 + 0]; + int s[38 + 0]; + int q[42 + 0]; + int p[38 + 0]; + int r[42 + 0]; + + + init_array (m, n, + A, + r, + p); + + kernel_bicg (m, n, + A, + s, + q, + p, + r); + + + return print_array(m, n, s, q); + + +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/kernels/doitgen.c b/benchmarks/polybench-syn-div/linear-algebra/kernels/doitgen.c new file mode 100644 index 0000000..6eaef56 --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/kernels/doitgen.c @@ -0,0 +1,105 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* doitgen.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS + #include <stdio.h> +#endif + +#define plus(i) i = i + ONE +static +void init_array(int nr, int nq, int np, + int A[ 10 + 0][8 + 0][12 + 0], + int C4[ 12 + 0][12 + 0]) +{ + int i, j, k; + int ONE = 1; + + for (i = 0; i < nr; plus(i)) + for (j = 0; j < nq; plus(j)) + for (k = 0; k < np; plus(k)) + A[i][j][k] = (int) (((i*j + k) % np) / np); + for (i = 0; i < np; plus(i)) + for (j = 0; j < np; plus(j)) + C4[i][j] = (int) (((i*j) % np) / np); +} + + +static +int print_array(int nr, int nq, int np, + int A[ 10 + 0][8 + 0][12 + 0]) +{ + int i, j, k; + int ONE = 1; + int res = 0; + + for (i = 0; i < nr; plus(i)) + for (j = 0; j < nq; plus(j)) + for (k = 0; k < np; plus(k)) { + res ^= A[i][j][k]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + + + +void kernel_doitgen(int nr, int nq, int np, + int A[ 10 + 0][8 + 0][12 + 0], + int C4[ 12 + 0][12 + 0], + int sum[ 12 + 0]) +{ + int r, q, p, s; + int ONE = 1; + + for (r = 0; r < nr; plus(r)) + for (q = 0; q < nq; plus(q)) { + for (p = 0; p < np; plus(p)) { + sum[p] = 0; + for (s = 0; s < np; plus(s)) + sum[p] += A[r][q][s] * C4[s][p]; + } + for (p = 0; p < np; plus(p)) + A[r][q][p] = sum[p]; + } + +} + + +int main() +{ + + int nr = 10; + int nq = 8; + int np = 12; + + + int A[10 + 0][8 + 0][12 + 0]; + int sum[12 + 0]; + int C4[12 + 0][12 + 0]; + + + init_array (nr, nq, np, + A, + C4); + + + kernel_doitgen (nr, nq, np, + A, + C4, + sum); + + + + return print_array(nr, nq, np, A); +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/kernels/mvt.c b/benchmarks/polybench-syn-div/linear-algebra/kernels/mvt.c new file mode 100644 index 0000000..4548ca5 --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/kernels/mvt.c @@ -0,0 +1,124 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* mvt.c: this file is part of PolyBench/C */ + +#include "../../include/misc.h" + +#ifndef SYNTHESIS + #include <stdio.h> +#endif + +#define plus(i) i = i + ONE + +static +void init_array(int n, + int x1[ 40 + 0], + int x2[ 40 + 0], + int y_1[ 40 + 0], + int y_2[ 40 + 0], + int A[ 40 + 0][40 + 0]) +{ + int i, j; + int ONE = 1; + int THREE = 3; + + for (i = 0; i < n; plus(i)) + { + x1[i] = (int) ((i % n) / n); + x2[i] = (int) (((i + ONE) % n) / n); + y_1[i] = (int) (((i + THREE) % n) / n); + y_2[i] = (int) (((i + 4) % n) / n); + for (j = 0; j < n; plus(j)) + A[i][j] = (int) (((i*j) % n) / n); + } +} + + + + + static +int print_array(int n, + int x1[ 40 + 0], + int x2[ 40 + 0]) + +{ + int i; + int ONE = 1; + int res = 0; + + for (i = 0; i < n; plus(i)) { + res ^= x1[i]; + } + + for (i = 0; i < n; plus(i)) { + res ^= x2[i]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + + + +static +void kernel_mvt(int n, + int x1[ 40 + 0], + int x2[ 40 + 0], + int y_1[ 40 + 0], + int y_2[ 40 + 0], + int A[ 40 + 0][40 + 0]) +{ + int i, j; + int ONE = 1; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) + x1[i] = x1[i] + A[i][j] * y_1[j]; + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) + x2[i] = x2[i] + A[j][i] * y_2[j]; + +} + + +int main() +{ + + int n = 40; + + + int A[40 + 0][40 + 0]; + int x1[40 + 0]; + int x2[40 + 0]; + int y_1[40 + 0]; + int y_2[40 + 0]; + + + + init_array (n, + x1, + x2, + y_1, + y_2, + A); + + + kernel_mvt (n, + x1, + x2, + y_1, + y_2, + A); + + return print_array(n, x1, x2); + +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/solvers/Makefile b/benchmarks/polybench-syn-div/linear-algebra/solvers/Makefile new file mode 100644 index 0000000..146620b --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/solvers/Makefile @@ -0,0 +1,3 @@ +TARGETS := cholesky durbin lu ludcmp trisolv + +include ../../common.mk diff --git a/benchmarks/polybench-syn-div/linear-algebra/solvers/cholesky.c b/benchmarks/polybench-syn-div/linear-algebra/solvers/cholesky.c new file mode 100644 index 0000000..5f10ab9 --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/solvers/cholesky.c @@ -0,0 +1,129 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* cholesky.c: this file is part of PolyBench/C */ + +#include "../../include/misc.h" + +#ifndef SYNTHESIS +#include <stdio.h> +#endif + +# define SQRT_FUN(x) sqrtf(x) + +#define plus(i) i = i + ONE +static +void init_array(int n, + int A[40][40]) +{ + int i, j; + int ONE = 1; + + for (i = 0; i < n; plus(i)) + { + for (j = 0; j <= i; plus(j)) + A[i][j] = (int)(((-j) % n) / n) + ONE; + for (j = i + ONE; j < n; plus(j)) { + A[i][j] = 0; + } + A[i][i] = 1; + } + + + int r,s,t; + int B[40][40]; + for (r = 0; r < n; ++r) + for (s = 0; s < n; ++s) + B[r][s] = 0; + for (t = 0; t < n; ++t) + for (r = 0; r < n; ++r) + for (s = 0; s < n; ++s) + B[r][s] += A[r][t] * A[s][t]; + for (r = 0; r < n; ++r) + for (s = 0; s < n; ++s) + A[r][s] = B[r][s]; + +} + + + + +static +int check_array(int n, + int A[40][40]) + +{ + int res = 0; + int ONE = 1; + int i, j; + + for (i = 0; i < n; plus(i)) + for (j = 0; j <= i; plus(j)) { + if(A[i][j]!=0) res = 1; + } + #ifndef SYNTHESIS + printf("finished: %u\n", res); + #endif + + return res; +} + + + + +static +void kernel_cholesky(int n, + int A[40][40]) +{ + int i, j, k; + int ONE = 1; + + for (i = 0; i < n; plus(i)) { + + for (j = 0; j < i; plus(j)) { + for (k = 0; k < j; plus(k)) { + A[i][j] -= A[i][k] * A[j][k]; + } + A[i][j] = (A[i][j] / A[j][j]); + } + + for (k = 0; k < i; plus(k)) { + A[i][i] -= A[i][k] * A[i][k]; + } + int sq = 0; int val = 0; int cmp = A[i][i]; + while(sq <= cmp) { + val = val + ONE; + sq = val * val; + } + A[i][i] = val; + } + +} + + +int main() +{ + + int n = 40; + + + int A[40][40]; + + + init_array (n, A); + + + kernel_cholesky (n, A); + + + return check_array(n, A); + + + return 0; +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/solvers/durbin.c b/benchmarks/polybench-syn-div/linear-algebra/solvers/durbin.c new file mode 100644 index 0000000..5646e6e --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/solvers/durbin.c @@ -0,0 +1,98 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* durbin.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS +#include <stdio.h> +#endif + +#define plus(i) i = i + ONE +/* Include polybench common header. */ +static +void init_array (int n, + int r[ 40 + 0]) +{ + int ONE = 1; + int i; + + for (i = 0; i < n; plus(i)) + { + r[i] = (n+ONE-i); + } +} + + + +static +int print_array(int n, + int y[ 40 + 0]) + +{ + int ONE = 1; + int i; + int res = 0; + + for (i = 0; i < n; plus(i)) { + res ^= y[i]; + } + +#ifndef SYNTHESIS + printf("finished: %u\n", res); +#endif + + return res; +} + +static +void kernel_durbin(int n, + int r[ 40 + 0], + int y[ 40 + 0]) +{ + int z[40]; + int alpha; + int beta; + int sum; + + int ONE = 1; + int i,k; + y[0] = -r[0]; + beta = 1; + alpha = -r[0]; + + for (k = 1; k < n; plus(k)) { + beta = (ONE-alpha*alpha)*beta; + sum = 0; + for (i=0; i<k; plus(i)) { + sum += r[k-i-ONE]*y[i]; + } + alpha = - (r[k] + sum / beta); + + for (i=0; i<k; plus(i)) { + z[i] = y[i] + alpha*y[k-i-ONE]; + } + for (i=0; i<k; plus(i)) { + y[i] = z[i]; + } + y[k] = alpha; + } +} + + +int main() +{ + int n = 40; + int r[40 + 0]; + int y[40 + 0]; + + init_array (n, r); + kernel_durbin (n, r, y); + + return print_array(n, y); +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/solvers/lu.c b/benchmarks/polybench-syn-div/linear-algebra/solvers/lu.c new file mode 100644 index 0000000..e0e8bfb --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/solvers/lu.c @@ -0,0 +1,116 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* lu.c: this file is part of PolyBench/C */ + +//#include <stdio.h> +//#include <unistd.h> +//#include <string.h> +//#include <math.h> + +#ifndef SYNTHESIS +#include <stdio.h> +#endif + +#define plus(i) i = i + ONE + +static +void init_array (int n, + int A[40][40]) +{ + int ONE = 1; + int i, j; + + for (i = 0; i < n; plus(i)) + { + for (j = 0; j <= i; plus(j)) + A[i][j] = (((-j) % n) / n) + ONE; + for (j = i+1; j < n; plus(j)) { + A[i][j] = 0; + } + A[i][i] = 1; + } + + + + int r,s,t; + int B[40][40]; // B = (int(*)[40 + 0][40 + 0])polybench_alloc_data ((40 + 0) * (40 + 0), sizeof(int));; + for (r = 0; r < n; plus(r)) + for (s = 0; s < n; plus(s)) + B[r][s] = 0; + for (t = 0; t < n; plus(t)) + for (r = 0; r < n; plus(r)) + for (s = 0; s < n; plus(s)) + B[r][s] += A[r][t] * A[s][t]; + for (r = 0; r < n; plus(r)) + for (s = 0; s < n; plus(s)) + A[r][s] = B[r][s]; + //free((void*)B);; + +} + +static +void kernel_lu(int n, + int A[ 40][40]) +{ + int i, j, k; + int ONE = 1; + + for (i = 0; i < n; plus(i)) { + for (j = 0; j <i; plus(j)) { + for (k = 0; k < j; plus(k)) { + A[i][j] -= A[i][k] * A[k][j]; + } + A[i][j] = (A[i][j] / A[j][j]); + } + for (j = i; j < n; plus(j)) { + for (k = 0; k < i; plus(k)) { + A[i][j] -= A[i][k] * A[k][j]; + } + } + } +} + +static +int check_array(int n, + int A[40][40]) +{ + int res = 0; + int i, j; + int ONE = 1; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) + if(A[i][j] !=0) res = 1; + #ifndef SYNTHESIS + printf("finished: %u\n", res); + #endif + + return res; +} + + +int main() +{ + + int n = 40; + + + int A[40][40]; //A = (int(*)[40 + 0][40 + 0])polybench_alloc_data ((40 + 0) * (40 + 0), sizeof(int));; + + + init_array (n, A); + + kernel_lu (n, A); + + return check_array(n, A); + return 0; + + //free((void*)A);; +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/solvers/ludcmp.c b/benchmarks/polybench-syn-div/linear-algebra/solvers/ludcmp.c new file mode 100644 index 0000000..bd8804c --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/solvers/ludcmp.c @@ -0,0 +1,163 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* ludcmp.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS +#include <stdio.h> +#endif + +#define plus(i) i = i + ONE + + static +void init_array (int n, + int A[ 40 + 0][40 + 0], + int b[ 40 + 0], + int x[ 40 + 0], + int y[ 40 + 0]) +{ + int i, j; + int ONE = 1; + int fn = (int)n; + + for (i = 0; i < n; plus(i)) + { + x[i] = 0; + y[i] = 0; + b[i] = ((i+1) / (fn*2)) + 4; + } + + for (i = 0; i < n; plus(i)) + { + for (j = 0; j <= i; plus(j)) + A[i][j] = (int)(((-j) % n) / n) + 1; + for (j = i+ONE; j < n; plus(j)) { + A[i][j] = 0; + } + A[i][i] = 1; + } + + + + int r,s,t; + int B[40 + 0][40 + 0]; + for (r = 0; r < n; plus(r)) + for (s = 0; s < n; plus(s)) + B[r][s] = 0; + for (t = 0; t < n; plus(t)) + for (r = 0; r < n; plus(r)) + for (s = 0; s < n; plus(s)) + B[r][s] += A[r][t] * A[s][t]; + for (r = 0; r < n; plus(r)) + for (s = 0; s < n; plus(s)) + A[r][s] = B[r][s]; + +} + + + + + static +int check_array(int n, + int x[ 40 + 0]) + +{ + int i; + int ONE = 1; + int res = 0; + + for (i = 0; i < n; plus(i)) { + res ^= x[i]; + } +#ifndef SYNTHESIS + printf("finished: %u\n", res); +#endif + return res; +} + + + + + static +void kernel_ludcmp(int n, + int A[ 40 + 0][40 + 0], + int b[ 40 + 0], + int x[ 40 + 0], + int y[ 40 + 0]) +{ + int i, j, k; + int ONE = 1; + + int w; + + for (i = 0; i < n; plus(i)) { + for (j = 0; j <i; plus(j)) { + w = A[i][j]; + for (k = 0; k < j; plus(k)) { + w -= A[i][k] * A[k][j]; + } + A[i][j] = (w / A[j][j]); + } + for (j = i; j < n; plus(j)) { + w = A[i][j]; + for (k = 0; k < i; plus(k)) { + w -= A[i][k] * A[k][j]; + } + A[i][j] = w; + } + } + + for (i = 0; i < n; plus(i)) { + w = b[i]; + for (j = 0; j < i; plus(j)) + w -= A[i][j] * y[j]; + y[i] = w; + } + + for (i = n-ONE; i >=0; i=i-ONE) { + w = y[i]; + for (j = i+ONE; j < n; plus(j)) + w -= A[i][j] * x[j]; + x[i] = (w / A[i][i]); + } + +} + + +int main() +{ + + int n = 40; + + + int A[40 + 0][40 + 0]; + int b[40 + 0]; + int x[40 + 0]; + int y[40 + 0]; + + + + init_array (n, + A, + b, + x, + y); + + + kernel_ludcmp (n, + A, + b, + x, + y); + + return check_array(n, x); + + + return 0; +} diff --git a/benchmarks/polybench-syn-div/linear-algebra/solvers/trisolv.c b/benchmarks/polybench-syn-div/linear-algebra/solvers/trisolv.c new file mode 100644 index 0000000..f426853 --- /dev/null +++ b/benchmarks/polybench-syn-div/linear-algebra/solvers/trisolv.c @@ -0,0 +1,97 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* trisolv.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS +#include <stdio.h> +#endif + +#define plus(i) i = i + ONE +static +void init_array(int n, + int L[ 40 ][40 ], + int x[ 40 ], + int b[ 40 ]) +{ + int i, j; + int ONE = 1; + + for (i = 0; i < n; plus(i)) + { + x[i] = -999; + b[i] = i ; + for (j = 0; j <= i; plus(j)) + L[i][j] = (int) (((i+n-j+ONE)*(ONE+ONE)) / n); + } +} + + + + +static +int check_array(int n, + int x[ 40]) + +{ + int i; + int res = 0; + int ONE = 1; + for (i = 0; i < n; plus(i)) { + res ^= x[i]; + } + +#ifndef SYNTHESIS + printf("finished: %u\n", res); +#endif + return res; +} + + + + +static +void kernel_trisolv(int n, + int L[ 40 + 0][40 + 0], + int x[ 40 + 0], + int b[ 40 + 0]) +{ + int i, j; + int ONE = 1; + + for (i = 0; i < n; plus(i)) + { + x[i] = b[i]; + for (j = 0; j <i; plus(j)) + x[i] -= L[i][j] * x[j]; + + x[i] = (x[i] / L[i][i]); + + } + +} + + +int main() +{ + + int n = 40; + + + int L[40 + 0][40 + 0]; + int x[40 + 0]; + int b[40 + 0]; + + init_array (n, L, x, b); + kernel_trisolv (n, L, x, b); + + return check_array(n, x); + + return 0; +} diff --git a/benchmarks/polybench-syn-div/medley/Makefile b/benchmarks/polybench-syn-div/medley/Makefile new file mode 100644 index 0000000..01da9de --- /dev/null +++ b/benchmarks/polybench-syn-div/medley/Makefile @@ -0,0 +1,6 @@ +TARGETS := floyd-warshall nussinov + +include ../common.mk + +floyd-warshall.v: floyd-warshall.c + $(VERICERT) $(VERICERT_OPTS) -O0 -finline $< -o $@ diff --git a/benchmarks/polybench-syn-div/medley/floyd-warshall.c b/benchmarks/polybench-syn-div/medley/floyd-warshall.c new file mode 100644 index 0000000..776d95a --- /dev/null +++ b/benchmarks/polybench-syn-div/medley/floyd-warshall.c @@ -0,0 +1,91 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* floyd-warshall.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS + #include <stdio.h> +#endif + +#define plus(i) i = i + ONE +static +void init_array (int n, + int path[ 60 + 0][60 + 0]) +{ + int i, j; + int ONE = 1; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) { + path[i][j] = i*(j % (ONE+6))+ONE; + //if (((i+j)%13 == ZERO || (i+j)%7== ZERO || (i+j)%11 == ZERO ) != 0 ) + if(((((i+j) % (12+ONE)) == (int)0 || ((i+j) % (ONE+6)) == (int)0)!=0 || ((i+j) % (10+ONE)) == (int)0 ) != 0) + path[i][j] = 999; + } +} + + + + +static +int print_array(int n, + int path[ 60 + 0][60 + 0]) + +{ + int i, j; + int res = 0; + int ONE = 1; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) { + res ^= path[i][j]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + + + +static +void kernel_floyd_warshall(int n, + int path[ 60 + 0][60 + 0]) +{ + int i, j, k; + int ONE = 1; + + for (k = 0; k < n; plus(k)) + { + for(i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) + path[i][j] = path[i][j] < path[i][k] + path[k][j] ? + path[i][j] : path[i][k] + path[k][j]; + } + +} + + +int main() +{ + + int n = 60; + + + int path[60 + 0][60 + 0]; + + init_array (n, path); + + kernel_floyd_warshall (n, path); + + return print_array(n, path); + + return 0; +} diff --git a/benchmarks/polybench-syn-div/medley/nussinov.c b/benchmarks/polybench-syn-div/medley/nussinov.c new file mode 100644 index 0000000..e2e06d3 --- /dev/null +++ b/benchmarks/polybench-syn-div/medley/nussinov.c @@ -0,0 +1,111 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* nussinov.c: this file is part of PolyBench/C */ + +typedef int base; + +#ifndef SYNTHESIS + #include <stdio.h> +#endif + +#define plus(i) i = i + ONE +static +void init_array (int n, + base seq[ 60 + 0], + int table[ 60 + 0][60 + 0]) +{ + int i, j; + int ONE = 1; + int FOUR = 4; + + + for (i=0; i <n; plus(i)) { + seq[i] = (base)(((i+ONE) % FOUR)); + } + + for (i=0; i <n; plus(i)) + for (j=0; j <n; plus(j)) + table[i][j] = 0; +} + + + + +static +int print_array(int n, + int table[ 60 + 0][60 + 0]) + +{ + int i, j; + int ONE = 1; + int res = 0; + + for (i = 0; i < n; plus(i)) { + for (j = i; j < n; plus(j)) { + res ^= table[i][j]; + } + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + +static +void kernel_nussinov(int n, base seq[ 60 + 0], + int table[ 60 + 0][60 + 0]) +{ + int i, j, k; + int ZERO = 0; + int ONE = 1; + int THREE = 3; + + for (i = n-ONE; i >= ZERO; i=i-ONE) { + for (j=i+ONE; j<n; plus(j)) { + + if (j-ONE>=ZERO) + table[i][j] = ((table[i][j] >= table[i][j-ONE]) ? table[i][j] : table[i][j-ONE]); + if (i+ONE<n) + table[i][j] = ((table[i][j] >= table[i+ONE][j]) ? table[i][j] : table[i+ONE][j]); + + if ((j-ONE>=ZERO && i+ONE<n) != (int)0) { + + if (i<j-ONE) + table[i][j] = ((table[i][j] >= table[i+ONE][j-ONE]+(((seq[i])+(seq[j])) == THREE ? ONE : ZERO)) ? table[i][j] : table[i+ONE][j-ONE]+(((seq[i])+(seq[j])) == THREE ? ONE : ZERO)); + else + table[i][j] = ((table[i][j] >= table[i+ONE][j-ONE]) ? table[i][j] : table[i+ONE][j-ONE]); + } + + for (k=i+ONE; k<j; plus(k)) { + table[i][j] = ((table[i][j] >= table[i][k] + table[k+ONE][j]) ? table[i][j] : table[i][k] + table[k+ONE][j]); + } + } + } + +} + + +int main() +{ + + int n = 60; + + + base (seq)[60 + 0]; + int (table)[60 + 0][60 + 0]; + + + init_array (n, seq, table); + + kernel_nussinov (n, seq, table); + + return print_array(n, table); + +} diff --git a/benchmarks/polybench-syn-div/poly.csv b/benchmarks/polybench-syn-div/poly.csv new file mode 100644 index 0000000..fe71983 --- /dev/null +++ b/benchmarks/polybench-syn-div/poly.csv @@ -0,0 +1,26 @@ +benchmark,legupcycles,legupfreqMHz,leguplogicutilisation,legupregs,leguprams,legupdsps,legupcomptime,vericertcycles,vericertfreqMHz,vericertlogicutilisation,vericertregs,vericertrams,vericertdsps,vericertcomptime +durbin,15106,188.61,2509,4008,0,8,4.77,19852,199.2,3027,6168,0,8,0.077 +lu,482766,244.62,3116,4593,0,10,4.72,2634766,92.97,54806,106037,0,6,0.097 +ludcmp,470843,249.69,3605,5397,0,15,4.87,2401354,83.52,57145,111408,0,10,0.132 +trisolv,35382,213.9,2412,3749,0,3,4.73,33550,112.59,28101,55109,0,2,0.086 +2mm,60088,226.5,1114,1936,0,7,4.80,427098,116.9,32600,63212,0,18,0.136 +3mm,204195,188.96,4210,4801,0,43,4.88,539430,97.13,45073,89719,0,18,0.147 +atas,126288,193.24,3026,3719,0,10,4.80,92000,130.41,28603,56646,0,6,0.069 +bicg,11907,303.4,308,537,0,6,4.78,121134,122.74,30091,58799,0,8,0.097 +mvt,16806,384.47,372,597,0,4,4.79,139194,119.93,30753,60450,0,6,0.130 +doitgen,57199,252.14,909,1402,0,2,5.05,350302,126.18,19898,38461,0,4,0.105 +symm,64903,284.41,2155,3170,0,10,4.63,248930,113.92,27693,54514,0,14,0.115 +syrk,57395,278.01,598,976,0,2,4.73,309018,87.15,76889,57816,0,8,0.094 +syr2k,125705,240.85,3149,3679,0,6,4.85,478040,78.6,120116,82032,0,12,0.116 +trmm,41432,281.61,610,990,0,4,4.71,147528,105.61,64031,40502,0,4,0.089 +gemm,83676,192.68,1029,1544,0,35,4.79,360772,121.61,31853,62126,0,16,0.104 +gemver,28087,303.49,1854,2380,0,8,4.68,175326,107.27,32615,64118,0,14,0.099 +gesummv,6634,310.46,298,504,0,4,4.77,111094,79.97,113876,72908,0,10,0.101 +covariance,109992,245.16,2098,3096,0,5,4.77,297450,110.57,28729,56660,0,4,0.083 +fdtd-2d,214153,262.61,2736,3801,0,2,4.73,831912,108.23,31333,61421,0,6,0.116 +heat-3d,41059,115.54,3132,2910,0,60,4.92,555930,110.42,33915,67273,0,9,0.181 +jacobi-1d,6914,386.25,1355,1885,0,0,4.72,16606,277.93,1636,3305,0,0,0.071 +jacobi-2d,84609,240.79,2347,3185,0,2,4.81,357100,113.53,30393,59782,0,4,0.079 +seidel-2d,345294,232.4,2128,3337,0,2,4.68,875758,127.99,26948,53133,0,2,0.091 +floyd-warshall,1238764,235.52,1869,2367,0,2,4.71,4762766,109.4,59859,118101,0,2,0.094 +nussinov,216467,273.07,1078,1431,0,2,4.79,837958,90.73,60663,119303,0,0,0.080 diff --git a/benchmarks/polybench-syn-div/quartus_synth.tcl b/benchmarks/polybench-syn-div/quartus_synth.tcl new file mode 100644 index 0000000..6edbf0c --- /dev/null +++ b/benchmarks/polybench-syn-div/quartus_synth.tcl @@ -0,0 +1,35 @@ +# PRiME pre-KAPow kernel flow +# Performs pre-KAPow run steps for instrumenting arbitrary Verilog for power monitoring +# James Davis, 2015 + +load_package flow + +project_new -overwrite syn +set_global_assignment -name FAMILY "Arria 10" +set_global_assignment -name DEVICE 10AX115H4F34E3LG +set_global_assignment -name SYSTEMVERILOG_FILE top.v +set_global_assignment -name TOP_LEVEL_ENTITY main +#set_global_assignment -name SDC_FILE syn.sdc +#set_global_assignment -name auto_resource_sharing on +#set_global_assignment -name enable_state_machine_inference on +#set_global_assignment -name optimization_technique area +#set_global_assignment -name synthesis_effort fast +#set_global_assignment -name AUTO_RAM_RECOGNITION on +#set_global_assignment -name remove_duplicate_registers on +#set_instance_assignment -name RAMSTYLE_ATTRIBUTE LOGIC -to ram + +execute_module -tool map + +execute_module -tool fit + +execute_module -tool sta + +#execute_module -tool eda -args "--simulation --tool=vcs" + +# set_global_assignment -name POWER_OUTPUT_SAF_NAME ${kernel}.asf +# set_global_assignment -name POWER_DEFAULT_INPUT_IO_TOGGLE_RATE "12.5 %" +# set_global_assignment -name POWER_REPORT_SIGNAL_ACTIVITY ON +# set_global_assignment -name POWER_REPORT_POWER_DISSIPATION ON +# execute_module -tool pow + +project_close diff --git a/benchmarks/polybench-syn-div/run-vericert.sh b/benchmarks/polybench-syn-div/run-vericert.sh new file mode 100755 index 0000000..6cf4cd9 --- /dev/null +++ b/benchmarks/polybench-syn-div/run-vericert.sh @@ -0,0 +1,41 @@ +#!/usr/bin/env bash + +rm exec.csv + +top=$(pwd) + #set up +while read benchmark ; do + echo "Running "$benchmark + ./$benchmark.gcc > $benchmark.clog + cresult=$(cat $benchmark.clog | cut -d' ' -f2) + echo "C output: "$cresult + ./$benchmark.iver > $benchmark.tmp + veriresult=$(tail -1 $benchmark.tmp | cut -d' ' -f2) + cycles=$(tail -2 $benchmark.tmp | head -1 | tr -s ' ' | cut -d' ' -f2) + echo "Verilog output: "$veriresult + + #Undefined checks + if test -z $veriresult + then + echo "FAIL: Verilog returned nothing" + #exit 0 + fi + + # Don't care checks + if [ $veriresult == "x" ] + then + echo "FAIL: Verilog returned don't cares" + #exit 0 + fi + + # unequal result check + if [ $cresult -ne $veriresult ] + then + echo "FAIL: Verilog and C output do not match!" + #exit 0 + else + echo "PASS" + fi + name=$(echo $benchmark | awk -v FS="/" '{print $NF}') + echo $name","$cycles >> exec.csv +done < benchmark-list-master diff --git a/benchmarks/polybench-syn-div/script.R b/benchmarks/polybench-syn-div/script.R new file mode 100644 index 0000000..0be16da --- /dev/null +++ b/benchmarks/polybench-syn-div/script.R @@ -0,0 +1,29 @@ +library("psych") + +data = read.csv("poly.csv", header=TRUE) +leguptime = (data$legupcycles/data$legupfreqMHz) +veritime = data$vericertcycles/data$vericertfreqMHz +print(lm(veritime ~ leguptime)) +leguputil = data$leguplogicutilisation/427200*100 +veriutil = data$vericertlogicutilisation/427200*100 +print(lm (veriutil ~ leguputil)) +legupct = data$legupcomptime +verict = data$vericertcomptime +print(lm ( verict ~ legupct )) + +cycleslowdown=data$vericertcycles/data$legupcycles + +print("Cycle count slow down") +print(geometric.mean(cycleslowdown)) +print("Wall clock slow down") +print(geometric.mean(veritime/leguptime)) +print("Area overhead") +print(geometric.mean(veriutil/leguputil)) +print("Compilation time speedup") +print(geometric.mean(legupct/verict)) +print("LegUp RAM use") +print(geometric.mean(data$legupregs)) +print("Vericert RAM use") +print(geometric.mean(data$vericertregs)) +print("Area overhead") +print(geometric.mean(data$vericertregs/data$legupregs)) diff --git a/benchmarks/polybench-syn-div/setup-syn-vericert.sh b/benchmarks/polybench-syn-div/setup-syn-vericert.sh new file mode 100755 index 0000000..22356f7 --- /dev/null +++ b/benchmarks/polybench-syn-div/setup-syn-vericert.sh @@ -0,0 +1,24 @@ +#! /bin/bash + +top=$(pwd) + #set up + basedir=poly-syn + sshhost=$1 + ssh $sshhost "cd ~; rm -r $basedir" + ssh $sshhost "cd ~; mkdir $basedir" + scp quartus_synth.tcl $sshhost:$basedir + scp syn-remote.sh $sshhost:$basedir + rm syn-list + + while read benchmark ; + do + echo "Copying "$benchmark" over" + name=$(echo $benchmark | awk -v FS="/" '{print $NF}') + echo "Name: "$name + benchdir="~/$basedir/$name" + scp $benchmark.v $sshhost:~/$basedir + echo $name >> syn-list + done < benchmark-list-master + + # copy list over + scp syn-list $sshhost:$basedir diff --git a/benchmarks/polybench-syn-div/stencils/Makefile b/benchmarks/polybench-syn-div/stencils/Makefile new file mode 100644 index 0000000..d2e1c9b --- /dev/null +++ b/benchmarks/polybench-syn-div/stencils/Makefile @@ -0,0 +1,6 @@ +TARGETS := adi fdtd-2d heat-3d jacobi-1d jacobi-2d seidel-2d + +include ../common.mk + +adi.v: adi.c + $(VERICERT) $(VERICERT_OPTS) -O0 -finline $< -o $@ diff --git a/benchmarks/polybench-syn-div/stencils/adi.c b/benchmarks/polybench-syn-div/stencils/adi.c new file mode 100644 index 0000000..be2b766 --- /dev/null +++ b/benchmarks/polybench-syn-div/stencils/adi.c @@ -0,0 +1,125 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* adi.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS +#include <stdio.h> +#endif + +static +void init_array (int n, int u[ 20 + 0][20 + 0]) +{ + int i, j; + + for (i = 0; i < n; i++) + for (j = 0; j < n; j++) + { + u[i][j] = (((int)(i + n-j)) / n); + } +} + + + + +static +int print_array(int n, int u[ 20 + 0][20 + 0]) +{ + int i, j; + int res = 0; + + for (i = 0; i < n; i++) + for (j = 0; j < n; j++) { + res ^= u[i][j]; + } +#ifndef SYNTHESIS + printf("finished: %u\n", res); +#endif + + return res; +} +static +void kernel_adi(int tsteps, int n, + int u[ 20 + 0][20 + 0], + int v[ 20 + 0][20 + 0], + int p[ 20 + 0][20 + 0], + int q[ 20 + 0][20 + 0]) +{ + int t, i, j; + int B1, B2; + int mul1, mul2; + int a, b, c, d, e, f; + + B1 = 2; + B2 = 1; + mul1 = ((B1 * n * n) / tsteps); + mul2 = ((B2 * n * n) /tsteps); + + a = -((mul1 / 2)); + b = 1+mul1; + c = a; + d = -((mul2 / 2)); + e = 1+mul2; + f = d; + int ZERO = 0; + + for (t=1; t<=tsteps; t++) { + + for (i=1; i<n-1; i++) { + v[ZERO][i] = 1; + p[i][ZERO] = 0; + q[i][ZERO] = v[ZERO][i]; + for (j=1; j<n-1; j++) { + p[i][j] = -(c / (a*p[i][j-1]+b)); + q[i][j] = -((-d*u[j][i-1]+(1+2*d)*u[j][i] - f*u[j][i+1]-a*q[i][j-1]) / (a*p[i][j-1]+b)); + } + + v[n-1][i] = 1; + for (j=n-2; j>=1; j--) { + v[j][i] = p[i][j] * v[j+1][i] + q[i][j]; + } + } + + for (i=1; i<n-1; i++) { + u[i][ZERO] = 1; + p[i][ZERO] = 0; + q[i][ZERO] = u[i][ZERO]; + for (j=1; j<n-1; j++) { + p[i][j] = -(f / (d*p[i][j-1]+e)); + q[i][j] = ((-a*v[i-1][j]+(1+2*a)*v[i][j] - c*v[i+1][j]-d*q[i][j-1]) / (d*p[i][j-1]+e)); + } + u[i][n-1] = 1; + for (j=n-2; j>=1; j--) { + u[i][j] = p[i][j] * u[i][j+1] + q[i][j]; + } + } + } +} + +int main() +{ + + int n = 20; + int tsteps = 20; + + + int u[20 + 0][20 + 0]; + int v[20 + 0][20 + 0]; + int p[20 + 0][20 + 0]; + int q[20 + 0][20 + 0]; + + + + init_array (n, u); + + kernel_adi (tsteps, n, u, v, p, q); + + return print_array(n, u); + +} diff --git a/benchmarks/polybench-syn-div/stencils/fdtd-2d.c b/benchmarks/polybench-syn-div/stencils/fdtd-2d.c new file mode 100644 index 0000000..2c5cdb2 --- /dev/null +++ b/benchmarks/polybench-syn-div/stencils/fdtd-2d.c @@ -0,0 +1,134 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* fdtd-2d.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS +#include <stdio.h> +#endif + +#define plus(i) i = i + ONE +static +void init_array (int tmax, + int nx, + int ny, + int ex[ 20 + 0][30 + 0], + int ey[ 20 + 0][30 + 0], + int hz[ 20 + 0][30 + 0], + int _fict_[ 20 + 0]) +{ + int i, j; + int ONE = 1; + + for (i = 0; i < tmax; plus(i)) + _fict_[i] = (int) i; + for (i = 0; i < nx; plus(i)) + for (j = 0; j < ny; plus(j)) + { + ex[i][j] = ((i*(j+1)) / nx); + ey[i][j] = ((i*(j+2)) / ny); + hz[i][j] = ((i*(j+3)) / nx); + } + +} + + + + +static +int print_array(int nx, + int ny, + int ex[ 20 + 0][30 + 0], + int ey[ 20 + 0][30 + 0], + int hz[ 20 + 0][30 + 0]) +{ + int i, j; + int res = 0; + int ONE = 1; + + for (i = 0; i < nx; plus(i)) + for (j = 0; j < ny; plus(j)) { + res ^= ex[i][j]; + } + for (i = 0; i < nx; plus(i)) + for (j = 0; j < ny; plus(j)) { + res ^= ey[i][j]; + } + for (i = 0; i < nx; plus(i)) + for (j = 0; j < ny; plus(j)) { + res ^= hz[i][j]; + } + +#ifndef SYNTHESIS + printf("finished: %u\n", res); +#endif + + return res; +} + + +static +void kernel_fdtd_2d(int tmax, + int nx, + int ny, + int ex[ 20 + 0][30 + 0], + int ey[ 20 + 0][30 + 0], + int hz[ 20 + 0][30 + 0], + int _fict_[ 20 + 0]) +{ + int t, i, j; + int ONE = 1; + + for(t = 0; t < tmax; t=t+ONE) + { + for (j = 0; j < ny; plus(j)) + ey[0][j] = _fict_[t]; + for (i = 1; i < nx; plus(i)) + for (j = 0; j < ny; plus(j)) + ey[i][j] = ey[i][j] - ((hz[i][j]-((hz[i-ONE][j])>>1))); + for (i = 0; i < nx; plus(i)) + for (j = 1; j < ny; plus(j)) + ex[i][j] = ex[i][j] - ((hz[i][j]-((hz[i][j-ONE])>>1))); + for (i = 0; i < nx - ONE; plus(i)) + for (j = 0; j < ny - ONE; plus(j)){ + int tmp = (ex[i][j+ONE] - ex[i][j] + + ey[i+ONE][j] - ey[i][j]); + hz[i][j] = hz[i][j] - (tmp >> 1) - (tmp >> 2); + } + } + +} + + +int main() +{ + + int tmax = 20; + int nx = 20; + int ny = 30; + + + int ex[20 + 0][30 + 0]; + int ey[20 + 0][30 + 0]; + int hz[20 + 0][30 + 0]; + int _fict_[20 + 0]; + + init_array (tmax, nx, ny, + ex, + ey, + hz, + _fict_); + kernel_fdtd_2d (tmax, nx, ny, + ex, + ey, + hz, + _fict_); + + return print_array(nx, ny, ex, ey, hz); +} diff --git a/benchmarks/polybench-syn-div/stencils/heat-3d.c b/benchmarks/polybench-syn-div/stencils/heat-3d.c new file mode 100644 index 0000000..f93082e --- /dev/null +++ b/benchmarks/polybench-syn-div/stencils/heat-3d.c @@ -0,0 +1,112 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* heat-3d.c: this file is part of PolyBench/C */ + +#include "../include/misc.h" + +#ifndef SYNTHESIS +#include <stdio.h> +#endif + +#define plus(i) i = i + ONE +static +void init_array (int n, + int A[ 10 + 0][10 + 0][10 + 0], + int B[ 10 + 0][10 + 0][10 + 0]) +{ + int i, j, k; + int ONE = 1; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) + for (k = 0; k < n; plus(k)) + A[i][j][k] = B[i][j][k] = (int) (i + j + (n-k))* (10 / n); +} + + + + +static +int print_array(int n, + int A[ 10 + 0][10 + 0][10 + 0]) + +{ + int i, j, k; + int ONE = 1; + int res = 0; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) + for (k = 0; k < n; plus(k)) { + res ^= A[i][j][k]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + + + +static +void kernel_heat_3d(int tsteps, + int n, + int A[ 10 + 0][10 + 0][10 + 0], + int B[ 10 + 0][10 + 0][10 + 0]) +{ + int t, i, j, k; + int ONE = 1; + int TWO = 2; + + for (t = 1; t <= 5; plus(t)) { + for (i = 1; i < n-ONE; plus(i)) { + for (j = 1; j < n-ONE; plus(j)) { + for (k = 1; k < n-ONE; plus(k)) { + B[i][j][k] = ((A[i+ONE][j][k] - TWO * A[i][j][k] + A[i-ONE][j][k]) >> 4) + + ((A[i][j+ONE][k] - TWO * A[i][j][k] + A[i][j-ONE][k]) >> 4) + + ((A[i][j][k+ONE] - TWO * A[i][j][k] + A[i][j][k-ONE]) >> 4) + + A[i][j][k] + ; + } + } + } + for (i = 1; i < n-ONE; plus(i)) { + for (j = 1; j < n-ONE; plus(j)) { + for (k = 1; k < n-ONE; plus(k)) { + A[i][j][k] = ((B[i+ONE][j][k] - TWO * B[i][j][k] + B[i-ONE][j][k]) >> 4 ) + + ((B[i][j+ONE][k] - TWO * B[i][j][k] + B[i][j-ONE][k]) >> 4 ) + + ((B[i][j][k+ONE] - TWO * B[i][j][k] + B[i][j][k-ONE]) >> 4 ) + + B[i][j][k]; + //; + } + } + } + } +} + + +int main() +{ + + int n = 10; + int tsteps = 20; + + + int A[10 + 0][10 + 0][10 + 0]; + int B[10 + 0][10 + 0][10 + 0]; + + init_array (n, A, B); + + kernel_heat_3d (tsteps, n, A, B); + + return print_array(n, A); + +} diff --git a/benchmarks/polybench-syn-div/stencils/jacobi-1d.c b/benchmarks/polybench-syn-div/stencils/jacobi-1d.c new file mode 100644 index 0000000..993773e --- /dev/null +++ b/benchmarks/polybench-syn-div/stencils/jacobi-1d.c @@ -0,0 +1,101 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* jacobi-1d.c: this file is part of PolyBench/C */ + +#ifndef SYNTHESIS +#include <stdio.h> +#endif + +#define plus(i) i = i + ONE +static +void init_array (int n, + int A[ 30 + 0], + int B[ 30 + 0]) +{ + int i; + int ONE = 1; + int TWO = 2; + int THREE = 3; + + for (i = 0; i < n; plus(i)) + { + A[i] = (((int) i+TWO) / n); + B[i] = (((int) i+THREE) / n); + } +} + + + + +static +int print_array(int n, + int A[ 30 + 0]) + +{ + int i; + int ONE = 1; + int res = 0; + + for (i = 0; i < n; plus(i)) + { + res ^= A[i]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + + + +static +void kernel_jacobi_1d(int tsteps, + int n, + int A[ 30 + 0], + int B[ 30 + 0]) +{ + int t, i; + int ONE = 1; + + for (t = 0; t < tsteps; plus(t)) + { + for (i = 1; i < n - ONE; plus(i)){ + B[i] = (A[i-ONE] + A[i] + A[i + ONE]); + B[i] = B[i] >> 2; + } + for (i = 1; i < n - ONE; plus(i)){ + A[i] = (B[i-ONE] + B[i] + B[i + ONE]); + A[i] = A[i] >> 2; + } + } + +} + + +int main() +{ + + int n = 30; + int tsteps = 20; + + + int A[30 + 0]; + int B[30 + 0]; + + + + init_array (n, A, B); + + kernel_jacobi_1d(tsteps, n, A, B); + + return print_array(n, A); + +} diff --git a/benchmarks/polybench-syn-div/stencils/jacobi-2d.c b/benchmarks/polybench-syn-div/stencils/jacobi-2d.c new file mode 100644 index 0000000..bb6afec --- /dev/null +++ b/benchmarks/polybench-syn-div/stencils/jacobi-2d.c @@ -0,0 +1,108 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* jacobi-2d.c: this file is part of PolyBench/C */ + +#include "../include/misc.h" + +#ifndef SYNTHESIS +#include <stdio.h> +#endif + + +#define plus(i) i = i + ONE +static +void init_array (int n, + int A[ 30 + 0][30 + 0], + int B[ 30 + 0][30 + 0]) +{ + int i, j; + int ONE = 1; + int TWO = 2; + int THREE = 3; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) + { + A[i][j] = (((int) i*(j+TWO) + TWO) / n); + B[i][j] = (((int) i*(j+THREE) + THREE) / n); + } +} + + + + +static +int print_array(int n, + int A[ 30 + 0][30 + 0]) + +{ + int i, j; + int ONE = 1; + int res = 0; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) { + res ^= A[i][j]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + + + +static +void kernel_jacobi_2d(int tsteps, + int n, + int A[ 30 + 0][30 + 0], + int B[ 30 + 0][30 + 0]) +{ + int t, i, j; + int ONE = 1; + int TWO = 2; + + for (t = 0; t < tsteps; plus(t)) + { + for (i = 1; i < n - ONE; plus(i)) + for (j = 1; j < n - ONE; plus(j)){ + B[i][j] = (A[i][j] + A[i][j-ONE] + A[i][ONE+j] + A[ONE+i][j] + A[i-ONE][j]); + B[i][j] = B[i][j] >> TWO; + } + for (i = 1; i < n - ONE; plus(i)) + for (j = 1; j < n - ONE; plus(j)){ + A[i][j] = (B[i][j] + B[i][j-ONE] + B[i][ONE+j] + B[ONE+i][j] + B[i-ONE][j]); + A[i][j] = A[i][j] >> TWO; + } + } + +} + + +int main() +{ + + int n = 30; + int tsteps = 5; + + + int A[30 + 0][30 + 0]; + int B[30 + 0][30 + 0]; + + + + init_array (n, A, B); + + kernel_jacobi_2d(tsteps, n, A, B); + + return print_array(n, A); + +} diff --git a/benchmarks/polybench-syn-div/stencils/seidel-2d.c b/benchmarks/polybench-syn-div/stencils/seidel-2d.c new file mode 100644 index 0000000..4a3b1ac --- /dev/null +++ b/benchmarks/polybench-syn-div/stencils/seidel-2d.c @@ -0,0 +1,92 @@ +/** + * This version is stamped on May 10, 2016 + * + * Contact: + * Louis-Noel Pouchet <pouchet.ohio-state.edu> + * Tomofumi Yuki <tomofumi.yuki.fr> + * + * Web address: http://polybench.sourceforge.net + */ +/* seidel-2d.c: this file is part of PolyBench/C */ + +#include "../include/misc.h" + +#ifndef SYNTHESIS +#include <stdio.h> +#endif + +#define plus(i) i = i + ONE +static +void init_array (int n, + int A[ 40 + 0][40 + 0]) +{ + int i, j; + int ONE = 1; + int TWO = 2; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) + A[i][j] = (((int) i*(j+TWO) + TWO) / n); +} + + + + +static +int print_array(int n, + int A[ 40 + 0][40 + 0]) + +{ + int i, j; + int ONE = 1; + int res = 0; + + for (i = 0; i < n; plus(i)) + for (j = 0; j < n; plus(j)) { + res ^= A[i][j]; + } +#ifndef SYNTHESIS + printf("finished %u\n", res); +#endif + return res; +} + + + + +static +void kernel_seidel_2d(int tsteps, + int n, + int A[ 40 + 0][40 + 0]) +{ + int t, i, j; + int ONE = 1; + int TWO = 2; + int NINE = 9; + + for (t = 0; t <= tsteps - ONE; plus(t)) + for (i = ONE; i<= n - TWO; plus(i)) + for (j = ONE; j <= n - TWO; plus(j)) + A[i][j] = ((A[i-ONE][j-ONE] + A[i-ONE][j] + A[i-ONE][j+ONE] + + A[i][j-ONE] + A[i][j] + A[i][j+ONE] + + A[i+ONE][j-ONE] + A[i+ONE][j] + A[i+ONE][j+ONE]) / NINE); + +} + + +int main() +{ + + int n = 40; + int tsteps = 5; + + + int A[40 + 0][40 + 0]; + + init_array (n, A); + + kernel_seidel_2d (tsteps, n, A); + + return print_array(n, A); + +} diff --git a/benchmarks/polybench-syn-div/syn-remote.sh b/benchmarks/polybench-syn-div/syn-remote.sh new file mode 100755 index 0000000..879db2e --- /dev/null +++ b/benchmarks/polybench-syn-div/syn-remote.sh @@ -0,0 +1,51 @@ +#! /bin/bash + +#setup +while read benchmark ; +do +echo "Setting up "$benchmark +rm -r $benchmark +mkdir $benchmark +cp $benchmark.v $benchmark/top.v + +done < syn-list + +#synthesis + +count=0 +while read benchmark ; + +do +echo "Synthesising "$benchmark +cd $benchmark +quartus_sh -t ../quartus_synth.tcl & +let "count=count+1" +cd .. + +if [ $count -eq 4 ] +then +echo "I am here" +wait +count=0 +fi + +done < syn-list + +if [ $count -lt 4 ] +then +wait +fi + +#extract +while read benchmark ; do + cd $benchmark + echo $(pwd) + freq=$(grep MHz syn.sta.rpt | tail -2 | head -1 | awk '{print $2}') + lut=$(sed -n -e 8p syn.fit.summary | awk '{print $6}' | sed 's/,//g') + regs=$(sed -n -e 9p syn.fit.summary | awk '{print $4}') + bram=$(sed -n -e 13p syn.fit.summary | awk '{print $5}') + dsp=$(sed -n -e 14p syn.fit.summary | awk '{print $5}') + cd .. + echo $benchmark","$freq","$lut","$regs","$bram","$dsp >> results +done < syn-list + diff --git a/benchmarks/polybench-syn/Makefile b/benchmarks/polybench-syn/Makefile new file mode 100644 index 0000000..7095d94 --- /dev/null +++ b/benchmarks/polybench-syn/Makefile @@ -0,0 +1,15 @@ +all: + -$(MAKE) -C stencils + -$(MAKE) -C medley + -$(MAKE) -C linear-algebra/blas + -$(MAKE) -C linear-algebra/kernels + -$(MAKE) -C linear-algebra/solvers + -$(MAKE) -C data-mining + +clean: + -$(MAKE) clean -C stencils + -$(MAKE) clean -C medley + -$(MAKE) clean -C linear-algebra/blas + -$(MAKE) clean -C linear-algebra/kernels + -$(MAKE) clean -C linear-algebra/solvers + -$(MAKE) clean -C data-mining diff --git a/benchmarks/polybench-syn/common.mk b/benchmarks/polybench-syn/common.mk new file mode 100644 index 0000000..88fb059 --- /dev/null +++ b/benchmarks/polybench-syn/common.mk @@ -0,0 +1,41 @@ +VERICERT ?= vericert +VERICERT_OPTS ?= -DSYNTHESIS -O0 -finline + +IVERILOG ?= iverilog +IVERILOG_OPTS ?= + +VERILATOR ?= verilator +VERILATOR_OPTS ?= -Wno-fatal --top main --exe /home/ymherklotz/projects/vericert/scripts/verilator_main.cpp + +TARGETS ?= + +%.v: %.c + $(VERICERT) $(VERICERT_OPTS) $< -o $@ + +%.iver: %.v + $(IVERILOG) -o $@ $(IVERILOG_OPTS) $< + +%.gcc: %.c + $(CC) $(CFLAGS) $< -o $@ + +%.verilator: %.v + $(VERILATOR) $(VERILATOR_OPTS) --Mdir $@ --cc $< + $(MAKE) -C $@ -f Vmain.mk + +%: %.iver %.gcc %.verilator + cp $< $@ + +all: $(TARGETS) + +clean: + rm -f *.iver + rm -f *.v + rm -f *.gcc + rm -f *.clog + rm -f *.tmp + rm -f $(TARGETS) + rm -rf *.verilator + +.PRECIOUS: %.v %.gcc %.iver +.PHONY: all clean +.SUFFIXES: diff --git a/benchmarks/polybench-syn/data-mining/Makefile b/benchmarks/polybench-syn/data-mining/Makefile new file mode 100644 index 0000000..d4817a0 --- /dev/null +++ b/benchmarks/polybench-syn/data-mining/Makefile @@ -0,0 +1,3 @@ +TARGETS := covariance + +include ../common.mk diff --git a/benchmarks/polybench-syn/linear-algebra/blas/Makefile b/benchmarks/polybench-syn/linear-algebra/blas/Makefile new file mode 100644 index 0000000..e1f3b58 --- /dev/null +++ b/benchmarks/polybench-syn/linear-algebra/blas/Makefile @@ -0,0 +1,3 @@ +TARGETS := gemm gemver gesummv symm syr2k syrk trmm + +include ../../common.mk diff --git a/benchmarks/polybench-syn/linear-algebra/blas/trmm.preproc.c b/benchmarks/polybench-syn/linear-algebra/blas/trmm.preproc.c deleted file mode 100644 index 9b8edfe..0000000 --- a/benchmarks/polybench-syn/linear-algebra/blas/trmm.preproc.c +++ /dev/null @@ -1,144 +0,0 @@ -/** - * This version is stamped on May 10, 2016 - * - * Contact: - * Louis-Noel Pouchet <pouchet.ohio-state.edu> - * Tomofumi Yuki <tomofumi.yuki.fr> - * - * Web address: http://polybench.sourceforge.net - */ -/* trmm.c: this file is part of PolyBench/C */ - -#include <stdio.h> -#include <unistd.h> -#include <string.h> -#include <math.h> - -/* Include polybench common header. */ -#include<polybench.h> -# 1 "trmm.c" -# 1 "<built-in>" 1 -# 1 "<built-in>" 3 -# 362 "<built-in>" 3 -# 1 "<command line>" 1 -# 1 "<built-in>" 2 -# 1 "trmm.c" 2 -# 1 "utilities/polybench.h" 1 -# 30 "utilities/polybench.h" -# 1 "/Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/usr/include/stdlib.h" 1 3 4 -# 31 "utilities/polybench.h" 2 -# 231 "utilities/polybench.h" -extern void* polybench_alloc_data(unsigned long long int n, int elt_size); -extern void polybench_free_data(void* ptr); - - - - -extern void polybench_flush_cache(); -extern void polybench_prepare_instruments(); -# 2 "trmm.c" 2 - - -# 1 "./linear-algebra/blas/trmm/trmm.h" 1 -# 5 "trmm.c" 2 - - - -static -void init_array(int m, int n, - int *alpha, - int A[ 20 + 0][20 + 0], - int B[ 20 + 0][30 + 0]) -{ - int i, j; - - *alpha = 1.5; - for (i = 0; i < m; i++) { - for (j = 0; j < i; j++) { - A[i][j] = (int)((i+j) % m)/m; - } - A[i][i] = 1.0; - for (j = 0; j < n; j++) { - B[i][j] = (int)((n+(i-j)) % n)/n; - } - } - -} - - - - -static -void print_array(int m, int n, - int B[ 20 + 0][30 + 0]) -{ - int i, j; - - fprintf(stderr, "==BEGIN DUMP_ARRAYS==\n"); - fprintf(stderr, "begin dump: %s", "B"); - for (i = 0; i < m; i++) - for (j = 0; j < n; j++) { - if ((i * m + j) % 20 == 0) fprintf (stderr, "\n"); - fprintf (stderr, "%d ", B[i][j]); - } - fprintf(stderr, "\nend dump: %s\n", "B"); - fprintf(stderr, "==END DUMP_ARRAYS==\n"); -} - - - - -static -void kernel_trmm(int m, int n, - int alpha, - int A[ 20 + 0][20 + 0], - int B[ 20 + 0][30 + 0]) -{ - int i, j, k; -# 68 "trmm.c" -#pragma scop - for (i = 0; i < m; i++) - for (j = 0; j < n; j++) { - for (k = i+1; k < m; k++) - B[i][j] += A[k][i] * B[k][j]; - B[i][j] = alpha * B[i][j]; - } -#pragma endscop - -} - - -int main(int argc, char** argv) -{ - - int m = 20; - int n = 30; - - - int alpha; - int (*A)[20 + 0][20 + 0]; A = (int(*)[20 + 0][20 + 0])polybench_alloc_data ((20 + 0) * (20 + 0), sizeof(int));; - int (*B)[20 + 0][30 + 0]; B = (int(*)[20 + 0][30 + 0])polybench_alloc_data ((20 + 0) * (30 + 0), sizeof(int));; - - - init_array (m, n, &alpha, *A, *B); - - - ; - - - kernel_trmm (m, n, alpha, *A, *B); - - - ; - ; - - - - if (argc > 42 && ! strcmp(argv[0], "")) print_array(m, n, *B); - - - free((void*)A);; - free((void*)B);; - - return 0; -} diff --git a/benchmarks/polybench-syn/linear-algebra/kernels/Makefile b/benchmarks/polybench-syn/linear-algebra/kernels/Makefile new file mode 100644 index 0000000..4b7f6e1 --- /dev/null +++ b/benchmarks/polybench-syn/linear-algebra/kernels/Makefile @@ -0,0 +1,3 @@ +TARGETS := 2mm 3mm atas bicg doitgen mvt + +include ../../common.mk diff --git a/benchmarks/polybench-syn/linear-algebra/solvers/Makefile b/benchmarks/polybench-syn/linear-algebra/solvers/Makefile new file mode 100644 index 0000000..146620b --- /dev/null +++ b/benchmarks/polybench-syn/linear-algebra/solvers/Makefile @@ -0,0 +1,3 @@ +TARGETS := cholesky durbin lu ludcmp trisolv + +include ../../common.mk diff --git a/benchmarks/polybench-syn/medley/Makefile b/benchmarks/polybench-syn/medley/Makefile new file mode 100644 index 0000000..816a0ce --- /dev/null +++ b/benchmarks/polybench-syn/medley/Makefile @@ -0,0 +1,3 @@ +TARGETS := floyd-warshall nussinov + +include ../common.mk diff --git a/benchmarks/polybench-syn/run-vericert.sh b/benchmarks/polybench-syn/run-vericert.sh index 29f7775..ef6964f 100755 --- a/benchmarks/polybench-syn/run-vericert.sh +++ b/benchmarks/polybench-syn/run-vericert.sh @@ -1,43 +1,42 @@ -#! /bin/bash +#!/usr/bin/env bash + +rm exec.csv top=$(pwd) - #set up +#set up while read benchmark ; do - echo "Running "$benchmark - clang -Wall -Werror -fsanitize=undefined $benchmark.c -o $benchmark.o - ./$benchmark.o > $benchmark.clog + printf "%10s\t" $(echo "$benchmark" | sed -e 's|/| |g') + ./$benchmark.gcc > $benchmark.clog cresult=$(cat $benchmark.clog | cut -d' ' -f2) - echo "C output: "$cresult - { time ../../bin/vericert -DSYNTHESIS -finline --debug-hls $benchmark.c -o $benchmark.v ; } 2> $benchmark.comp - iverilog -o $benchmark.iver -- $benchmark.v - ./$benchmark.iver > $benchmark.tmp + #echo "C output: "$cresult + #./$benchmark.iver > $benchmark.tmp + ./$benchmark.verilator/Vmain > $benchmark.tmp veriresult=$(tail -1 $benchmark.tmp | cut -d' ' -f2) - cycles=$(tail -4 $benchmark.tmp | head -1 | tr -s ' ' | cut -d' ' -f3) - ctime=$(cat $benchmark.comp | head -2 | tail -1 | xargs | cut -d' ' -f2 | cut -d'm' -f2 | sed 's/s//g') - echo "Veri output: "$veriresult - + cycles=$(tail -2 $benchmark.tmp | head -1 | tr -s ' ' | cut -d' ' -f2) + #echo "Verilog output: "$veriresult + #Undefined checks if test -z $veriresult then - echo "FAIL: Verilog returned nothing" - #exit 0 + echo "\e[0;91mFAIL\e[0m: Verilog returned nothing" + #exit 0 fi # Don't care checks if [ $veriresult == "x" ] then - echo "FAIL: Verilog returned don't cares" - #exit 0 + echo "\e[0;91mFAIL\e[0m: Verilog returned don't cares" + #exit 0 fi - - # unequal result check + + # unequal result check if [ $cresult -ne $veriresult ] then - echo "FAIL: Verilog and C output do not match!" - #exit 0 + echo -e "\e[0;91mFAIL\e[0m: Verilog and C output do not match!" + #exit 0 else - echo "PASS" + echo -e "\e[0;92mPASS\e[0m" fi name=$(echo $benchmark | awk -v FS="/" '{print $NF}') - echo $name","$cycles","$ctime >> exec.csv + echo $name","$cycles >> exec.csv done < benchmark-list-master diff --git a/benchmarks/polybench-syn/stencils/Makefile b/benchmarks/polybench-syn/stencils/Makefile new file mode 100644 index 0000000..d2e1c9b --- /dev/null +++ b/benchmarks/polybench-syn/stencils/Makefile @@ -0,0 +1,6 @@ +TARGETS := adi fdtd-2d heat-3d jacobi-1d jacobi-2d seidel-2d + +include ../common.mk + +adi.v: adi.c + $(VERICERT) $(VERICERT_OPTS) -O0 -finline $< -o $@ diff --git a/benchmarks/polybench-syn/stencils/adi.c b/benchmarks/polybench-syn/stencils/adi.c index ec2bf2a..2f4aca3 100644 --- a/benchmarks/polybench-syn/stencils/adi.c +++ b/benchmarks/polybench-syn/stencils/adi.c @@ -15,28 +15,23 @@ #include <stdio.h> #endif -#define plus(i) i = i + ONE - static -void init_array (int n, - int u[ 20 + 0][20 + 0]) +void init_array (int n, int u[ 20 + 0][20 + 0]) { int i, j; for (i = 0; i < n; i++) for (j = 0; j < n; j++) - { - u[i][j] = divider((int)(i + n-j) ,n); - } + { + u[i][j] = divider((int)(i + n-j), n); + } } static -int print_array(int n, - int u[ 20 + 0][20 + 0]) - +int print_array(int n, int u[ 20 + 0][20 + 0]) { int i, j; int res = 0; @@ -53,10 +48,10 @@ int print_array(int n, } static void kernel_adi(int tsteps, int n, - int u[ 20 + 0][20 + 0], - int v[ 20 + 0][20 + 0], - int p[ 20 + 0][20 + 0], - int q[ 20 + 0][20 + 0]) + int u[ 20 + 0][20 + 0], + int v[ 20 + 0][20 + 0], + int p[ 20 + 0][20 + 0], + int q[ 20 + 0][20 + 0]) { int t, i, j; int B1, B2; diff --git a/default.nix b/default.nix index 8308389..eabd3d3 100644 --- a/default.nix +++ b/default.nix @@ -1,35 +1,22 @@ -with import (fetchTarball "https://github.com/NixOS/nixpkgs/archive/269fc4ddb896c1c5994eb4bb8c750ec18cb3db82.tar.gz") {}; +with import (fetchTarball "https://github.com/NixOS/nixpkgs/archive/1a56d76d718afb6c47dd96602c915b6d23f7c45d.tar.gz") {}; let - ncoq = coq_8_12; - ncoqPackages = coqPackages_8_12; - bbv = ncoqPackages.callPackage - ( { coq, stdenv, fetchFromGitHub }: - stdenv.mkDerivation { - name = "coq${coq.coq-version}-bbv"; - - src = fetchFromGitHub { - owner = "mit-plv"; - repo = "bbv"; - rev = "5099237c52d2910f79a1a3ca9ae4dfa80129bf86"; - sha256 = "0qnha333h7dc8105prdxvmkgy6l8swvyf6kz9v5s5dk4dvr5nra8"; - }; - - buildInputs = with coq.ocamlPackages; [ ocaml camlp5 ]; - propagatedBuildInputs = [ coq ]; - enableParallelBuilding = true; - - installPhase = '' - make -f Makefile.coq.all install COQLIB='$(out)/lib/coq/${coq.coq-version}/' - ''; - } ) { }; + ncoq = coq_8_13; + ncoqPackages = coqPackages_8_13; in stdenv.mkDerivation { name = "vericert"; src = ./.; buildInputs = [ ncoq dune_2 gcc - ocaml ocamlPackages.findlib ocamlPackages.menhir - ocamlPackages.ocamlgraph + ncoq.ocaml ncoq.ocamlPackages.findlib ncoq.ocamlPackages.menhir + ncoq.ocamlPackages.ocamlgraph ncoq.ocamlPackages.merlin + ncoq.ocamlPackages.menhirLib + + ncoqPackages.serapi + python3 python3Packages.docutils python3Packages.pygments + python3Packages.dominate + python3Packages.pelican + python3Packages.alectryon ]; enableParallelBuilding = true; diff --git a/docs b/docs -Subproject a596c0c469d7c61b5ed8dfaf8805a926024a3a7 +Subproject 36abd86820f7521fcebb3b173acbcb6409b148b diff --git a/driver/VericertDriver.ml b/driver/VericertDriver.ml index 4c1e2f9..467ae37 100644 --- a/driver/VericertDriver.ml +++ b/driver/VericertDriver.ml @@ -239,7 +239,8 @@ Processing options: -finline Perform inlining of functions [on] -finline-functions-called-once Integrate functions only required by their single caller [on] - -fif-conversion Perform if-conversion (generation of conditional moves) [on] + -fif-conversion Perform if-conversion (generation of conditional moves) [off] + -fram Generate Verilog that is fit for ram inference [on] Code generation options: (use -fno-<opt> to turn off -f<opt>) -ffpu Use FP registers for some integer operations [on] -fsmall-data <n> Set maximal size <n> for allocation in small data area @@ -439,6 +440,7 @@ let cmdline_actions = @ f_opt "sse" option_ffpu (* backward compatibility *) @ f_opt "schedule" option_hls_schedule @ f_opt "if-conv" option_fif_conv + @ f_opt "ram" option_fram @ [ (* Catch options that are not handled *) Prefix "-", Self (fun s -> diff --git a/ip/altera.v b/ip/altera.v new file mode 100644 index 0000000..3839cbe --- /dev/null +++ b/ip/altera.v @@ -0,0 +1,2 @@ +module ALTERA_MF_MEMORY_INITIALIZATION; +endmodule diff --git a/lib/CompCert b/lib/CompCert -Subproject 48a9dcbdc968bcf05b4eec17b8c7fd471fb8024 +Subproject 1daf96cdca4d828c333cea5c9a314ef86134298 diff --git a/scripts/convert.sh b/scripts/convert.sh new file mode 100755 index 0000000..c2ef311 --- /dev/null +++ b/scripts/convert.sh @@ -0,0 +1,14 @@ +file=$1 +benchmark=$(echo $1 | sed 's:.*/\([^/]\+\)/encode_report.xml:\1:') + +lut_flip_flop=$(sed -n "s/.*XILINX_LUT_FLIP_FLOP_PAIRS_USED.*\"\([0-9.]*\)\".*/\1/p" $file) +slice=$(sed -n "s/.*XILINX_SLICE\".*\"\([0-9.]*\)\".*/\1/p" $file) +regs=$(sed -n "s/.*XILINX_SLICE_REGISTERS.*\"\([0-9.]*\)\".*/\1/p" $file) +luts=$(sed -n "s/.*XILINX_SLICE_LUTS.*\"\([0-9.]*\)\".*/\1/p" $file) +ramfifo=$(sed -n "s/.*XILINX_BLOCK_RAMFIFO.*\"\([0-9.]*\)\".*/\1/p" $file) +iopin=$(sed -n "s/.*XILINX_IOPIN.*\"\([0-9.]*\)\".*/\1/p" $file) +dsps=$(sed -n "s/.*XILINX_DSPS.*\"\([0-9.]*\)\".*/\1/p" $file) +power=$(sed -n "s/.*XILINX_POWER.*\"\([0-9.]*\)\".*/\1/p" $file) +delay=$(sed -n "s/.*XILINX_DESIGN_DELAY.*\"\([0-9.]*\)\".*/\1/p" $file) + +echo $benchmark,$lut_flip_flop,$slice,$regs,$luts,$ramfifo,$iopin,$dsps,$power,$delay >>synth.csv diff --git a/scripts/docker/Dockerfile b/scripts/docker/Dockerfile new file mode 100644 index 0000000..c66df6d --- /dev/null +++ b/scripts/docker/Dockerfile @@ -0,0 +1,19 @@ +FROM nixos/nix + +RUN nix-channel --add https://nixos.org/channels/nixpkgs-unstable nixpkgs +RUN nix-channel --update + +RUN nix-env -i yosys git tmux vim gcc iverilog + +ADD legup_polybench_syn.tar.gz /data/legup-polybench-syn +ADD legup_polybench_syn_div.tar.gz /data/legup-polybench-syn-div +ADD data.tar.gz /data + +RUN git clone --recursive https://github.com/ymherklotz/vericert + +WORKDIR /vericert +RUN git checkout oopsla21 +RUN nix-shell --run "make -j7" +RUN nix-shell --run "make install" + +RUN echo "export PATH=/vericert/bin:$PATH" >>/root/.bashrc diff --git a/scripts/docker/artifact.org b/scripts/docker/artifact.org new file mode 100644 index 0000000..fa0a936 --- /dev/null +++ b/scripts/docker/artifact.org @@ -0,0 +1,333 @@ +#+title: Vericert OOPSLA 2021 Artifact +#+options: toc:nil num:nil author:nil date:nil +#+latex_class: scrartcl + +This artifact should support the claims made in the paper "Formal Verification of High-Level Synthesis". In the paper, our tool Vericert was referred to as using the temporary name "HLSCert". The claims that can be verified by the paper are the following: + +- The mechanised proof of correctness of the translation from C into Verilog is provided and can be checked and rerun. +- All 27 PolyBench benchmarks can be recompiled using Vericert. +- The cycle counts of Vericert on the benchmarks can be checked and compared against LegUp 4.0. +- If Vivado is downloaded separately, then the whole performance section can be checked, including all the graphs that appear in the paper. + +** Artifact availability + +The artifact is available on Github, specifically on the ~oopsla21~ branch: + +https://github.com/ymherklotz/vericert + +#+latex: \noindent +This release is also archived on Zenodo permanently: + +http://doi.org/10.5281/zenodo.5093839 + +#+latex: \noindent +However, for the purposes of this artifact review, a Docker image has been set up: + +https://hub.docker.com/repository/docker/ymherklotz/vericert + +** Claims that are not supported by the artifact + +Unfortunately, we could not include our version of LegUp 4.0 in the artifact due to license restrictions. In addition to that, LegUp was recently bought by Microchip and renamed to SmartHLS[fn:1], which means that the most recent versions of LegUp are closed source and cannot be downloaded anymore. The original open source version of LegUp 4.0 is not currently available either at the moment. The LegUp team have advised us that this is due to server issues in Toronto.[fn:2] We have not heard back from them about whether it is ok for us to share our copy of LegUp 4.0 for artifact evaluation purposes, so we have not done so. + +Instead, we have included the net lists that LegUp generated from the benchmarks in the artifact, with all the optimisation levels that were tried, however, it does mean that these cannot be verified again and that other optimisation options cannot be tried. + +In addition to that, the Vivado synthesis tool by Xilinx[fn:3] is also commercial (but free to download), and therefore cannot be bundled into the artifact either. This synthesis tool was used to get accurate timing information about how the design would run on an FPGA, and also give the area that the design would take up on the FPGA. To be able to reproduce these results, it would therefore need Vivado to be set up so that the scripts can run. + +* Kick the tyres + +First, the docker image needs to be downloaded and run, which contains the git repository: + +#+begin_src shell +docker pull ymherklotz/vericert:1.0 +docker run -it ymherklotz/vericert:1.0 sh +#+end_src + +Then, one just has to go into the directory which contains the git repository (~/vericert~) and open a ~nix-shell~, which will load a shell with all the correct dependencies loaded: + +#+begin_src shell +cd /vericert +nix-shell +#+end_src + +Then, all commands can be run in this shell, as well as ~vericert~, which has already been compiled and can be found in the ~/vericert/bin~ directory. For a quick test that it is working, a few very simple examples in the ~/vericert/test~ directory can be run by using the following inside of the ~/vericert~ directory: + +#+begin_src shell +cd /vericert +make test +#+end_src + +If this finishes without errors, it means that Vericert is working correctly. + +Finally, to check that the benchmarks work correctly as well, we can quickly compile and run one as well: + +#+begin_src shell +cd /vericert/benchmarks/polybench-syn +make +./stencils/jacobi-1d +#+end_src + +This simulates the hardware design generated for the jacobi-1d benchmark in PolyBench/C, and should print the return value: 1, as well as the cycle count: 19996 as follows: + +#+begin_src shell +cycles: 19996 +finished: 1 +#+end_src + +* Step-by-Step instructions + +This section describes the detailed instructions to get the results for the different sections of the paper, first describing the structure of the proof and how to execute Vericert manually, to finally running Vericert on the benchmarks and get the cycle counts for the Vericert designs as well as the precompiled LegUp designs. + +** Directory structure of Vericert + +The main directory structure of Vericert is the following: + +- ~/src~ :: Contains all the Coq and OCaml source files used for Vericert. The whole proof of correctness is therefore in this directory. +- ~/lib~ :: This directory contains CompCert, on which Vericert is built upon. Vericert tries to separate CompCert and uses it only as a library, redefining a different top-level. +- ~/benchmarks~ :: Contains the PolyBench/C benchmarks used as an evaluation in the paper, which are stored under ~polybench-syn~ for the benchmarks without dividers, and ~polybench-syn-div~ for the benchmarks with dividers. +- ~/docs~ :: Contains a website and an ~org-mode~ file with some light documentation of the tool. +- ~/example~ :: Contains some interesting observations that were made during the development, which are not directly relevant to Vericert. +- ~/include~ :: Contains the divider implementation which can be imported and used in C files to get the better performance out of Vericert, instead of using native division. +- ~/ip~ :: Contains hardware divider implementations which will be used in the future instead of the software implementation that is currently used in ~/include~. +- ~/scripts~ :: Contains some miscellaneous scripts and the ~Dockerfile~ which has been added for this artifcat. +- ~/test~ :: Contains some very light test cases which are some minimal examples for working constructs. + +** Description of the proof + +The proof is mostly located in ~/src/hls~, which contains the proof of correctness of the 3AC to HTL transformation, as well as the transformation from HTL to Verilog. First, we will describe where each section of the paper is implemented, then a description of all the files in the src directory will be included. + +*** Implementation of paper sections + +When mentioning Coq source files, they will always be relative to the ~/vericert/src~ directory in the docker image. + +**** Section 2 + +- Figure 2 :: This example is not included in the repository or docker image, however, if the small C example in Figure 2a is copied into a file ~main.v~, it can be compiled using the following: + +#+begin_src shell +vericert -o main.v -O0 -drtl -dhtl main.c +#+end_src + +Where ~-O0~ means it will not apply any CompCert optimisations, ~-drtl~ means it will print the internal 3AC (also known as RTL) representation and ~-dhtl~ outputs the HTL representation. After running that command, Figure 2b should be the exact same as the ~main.rtl.7~ file that was generated, and Figure 2c should be the same as ~main.v~, with some slight modifications to some variable names and formatting. + +- Figure 3 :: After running the above command, Figure 3 will be a visual representation of ~main. + +- Section 2.2.2 :: The abstract RAM description and is used in HTL can be found in ~hls/HTL.v:139~. This also corresponds to Figure 7. This abstract description is then implemented as a concrete Verilog implementation shown in ~hls/Veriloggen.v:45~. The proof that the Verilog implementation is correct according to the HTL specification of it can be found in Lemma ~ram_exec_match~, ~hls/Veriloggenproof.v:284~. + +- Section 2.2.3 :: This proof is for Theorem ~shrx_shrx_alt_equiv~, ~common/Integer~\-~Extra.v:661~. + +**** Section 3 + +This Section is mainly implemented in ~hls/Verilog.v~. + +- Module execution rule :: The updated negative edge execution rule can be found in ~hls/Verilog.v:582~ which is called ~step_module~, and has a ~mis_stepp~ and ~mis_stepp_negedge~ for the steps of the positive and negative edge triggered always blocks. + +- Figure 5 :: This is implemented as all the other possible steps in one Verilog step, shown in ~hls/Verilog.v:581~. The Figure just uses some nicer notation for the inference rules. + +- Figure 6 :: Our dependenty typed arrays used for the memory model are implemented in ~hls/Array.v~, and is then integrated in the Verilog semantics properly using the ~arr_associations~ type, defined in ~hls/Verilog.v:60~, which is a blocking and nonblocking array where each element is an optional, as shown in Figure 6. + +**** Section 5 + +- Theorem 1 :: This is proven as Theorem ~transf_c_program_correct~ in ~Compiler.v~\-~:415~. + +- Lemma 1 :: This is proven as part of Theorem ~cstrategy_semantic_preservation~ in ~Compiler.v:334~, which also proves the backward simulation at the same time. + +- Lemma 2 :: The specification of the translation from 3AC to HTL is shown in Theorem ~transl_module_correct~ in ~hls/HTLgenspec.v:608~ and is called ~tr_module~ instead of ~spec_htl~ as in the paper, and ~tr_htl~ is called ~transl_~\-~module~ instead. + +- Section 4.1.2, ~match_states~ :: The ~match_states~ property to match two states in 3AC and HTL up is defined in ~hls/HTLgenproof.v:112~. + +- Lemma 3 :: Proven as Theorem ~transl_step_correct~ in ~hls/HTLgenproof.v:2856~ and describes the simulation diagram shown in the paper. + +- Section 4.2.1 :: The specification of the store is located in ~hls/Memorygen.v:2096~ and is called ~alt_store~. + +- Section 4.2.2, ~match_states~ :: The definition of matching states is defined in ~hls~\-~/Memory~\-~gen.v:314~, where ~ARRS_SIZE~ corresponds to the property of equally sized arrays at each step and ~DISABLE_RAM~ corresponds to the property that the RAM is always disabled by default. + +- Lemma 4 :: There is a small typo in the paper, and this Lemma should describe the forward simulation of the insertion of the RAM. This is proven in Theorem ~transf_program_correct~ in ~hls/Memorygen.v:3196~, and the simulation diagram for this translation is proven in Theorem ~transf_step_correct~ in ~hls/Memorygen.v:3000~. + +- Lemma 5 :: This is proven in Theorem ~transf_program_correct~ in ~hls/Veriloggen~\-~proof.v:537~. The assumption that the HTL module and Verilog module are related by ~transl_program~ (~tr_verilog~ in the paper) is given in the hypothesis ~TRANSL~ in ~hls/Veriloggenproof.v:343~. + +- Lemma 6 :: The determinism of the Verilog semantics is proven in ~semantics_deter~\-~minate~ in ~hls/Verilog.v:810~. + +- Table 1 :: These values were calculated by hand to separate specification, implementation and proof code. The raw results can be found in the last table in the ~/data/data/results.org~ file, or in the ~/data/data/code-count.csv~. + +*** Description of files + +- ~/src/Compiler.v~ :: The very top-level of the proof is located here and it contains the main proof of the compiler, which is the proof that the ~transf_hls~ function is correct, which takes C and outputs Verilog. The main proof of correctness is in the Theorem called ~transf_c_program_correct~, which says that if the ~transf_hls~ function succeeded, that the backward simulation should hold between C and Verilog. +- ~/src/common~ :: This directory contains some common library extensions and proofs that are used in other parts of Vericert. This includes the proof of correctness of Section 2.2.3, which is located in ~/src/common/IntegerExtra.v~ under the Theorem ~shrx_shrx_alt_equiv~. +- ~/src/hls/Verilog.v~ :: This file contains the whole Verilog semantics, together with the proof that the Verilog semantics are deterministic. This implements Section 3 from the paper. +- ~src/hls/Veriloggen.v~ :: This file contains the generation of Verilog from HTL. +- ~src/hls/Veriloggenproof.v~ :: This file contains the correctness proof of the generation of Verilog from HTL. +- ~/src/hls/HTL.v~ :: This file contains the definition of the HTL intermediate language, together with its semantics. +- ~/src/hls/HTLgen.v~ :: This file contains the generation of HTL from 3AC, which is the first step in the HLS transformation. +- ~/src/hls/HTLgenspec.v~ :: This file contains the high-level specification of the translation from 3AC into HTL, together with a proof of correctness of the specification. +- ~/src/hls/HTLgenproof.v~ :: This file contains the proof of correctness of the HTL generation from 3AC, where the main parts of the proof are the generation of Verilog operations, as well as the change in the memory model (load and store instructions). +- ~/src/hls/Memorygen.v~ :: This file contains the definition and proof of the transformation which replaces naïve loads and stores into a proper RAM, which is described in Section 2.2.2. +- ~/src/hls/ValueInt.v~ :: Contains our definition of values that are used in the Verilog semantics, and differ from the values used by CompCert, as they don't have a pointer type anymore. +- ~/src/hls/Array.v~ :: Contains our definition of the memory model, which is a dependently typed array, which encodes its length. This is much more concrete than CompCert's abstract memory model, and closer to how it is actually modelled in hardware. +- ~/src/hls/AssocMap.v~ :: Definition of association maps, which is the type that is used for $\Gamma$ and $\Delta$ in Section 3. + +** How to manually compile using Vericert + +To compile arbitrary C files, the following command can be used: + +#+begin_src shell +vericert main.c -o main.v +#+end_src + +Which will generate a Verilog file with a corresponding test bench. The Verilog file can then be simulated by using the Icarus Verilog simulator: + +#+begin_src shell +iverilog main.v -o main +./main +#+end_src + +This should print out the return value from the main function in addition to the number of cycles that it took to execute the hardware design. + +** Getting cycle counts for Vericert + +There are two benchmark sets for which the results are given in the paper: + +- ~/vericert/benchmarks/polybench-syn~ :: Contains the PolyBench/C benchmark without any dividers, and instead the dividers are replaced by calls to ~sdivider~ and ~smodulo~ in ~/vericert/include/hls.h~. +- ~/vericert/benchmarks/polybench-syn-div~ :: Contains the PolyBench/C benchmark with dividers. + +To get the cycle counts for Vericert from the benchmarks, the benchmarks can be compiled using the following: + +#+begin_src shell +cd /vericert/benchmarks/polybench-syn +#+end_src + +or + +#+begin_src shell +cd /vericert/benchmarks/polybench-syn-div +#+end_src + +depending on which benchmark should be run, and then running: + +#+begin_src shell +make +#+end_src + +This will generate all the binaries for the simulation and execution of the C code. The cycle counts of the hardware can then be gotten by running: + +#+begin_src shell +./run-vericert.sh +#+end_src + +This can take a while to complete, as simulation of hardware is quite slow. After around 30 minutes, there should be a ~exec.csv~ file which contains the cycle counts for each of the 27 benchmarks. + +** Getting the cycle counts for LegUp + +Unfortunately, the benchmarks cannot be compiled from C to Verilog using LegUp, as it could not be included in the artifact, and does not seem to be freely available anymore. + +However, our compiled Verilog designs from LegUp have been included for all the optimisation options that were tested for in the paper in Section 5. + +To get the cycle counts, it suffices to go into an arbitrary directory, and run the following script, where the command line arguments select which set of cycle counts to generate: + +#+begin_src shell +/vericert/scripts/run-legup.sh [syn|syn-div] \ + [opt|no_opt|no_chain|no_opt_no_chain] +#+end_src + +For example, to run the LegUp benchmarks with no LLVM optimisations and no operation chaining, on the PolyBench/C benchmark with no dividers, one can run the following command: + +#+begin_src shell +/vericert/scripts/run-legup.sh syn no_opt_no_chain +#+end_src + +This will take some 30 minutes to run as well, and will generate an ~exec_legup.csv~ file, with the name of the benchmark and it's cycle count. + +** Comparing the results + +To compare the results to the results presented in the paper, the main comparison that is supported by this artifact is to compare the cycle counts to the ones used to generate the graphs in the evaluation section of the paper. + +The ~/data/data~ directory contains all the raw data which was used to generate the graphs in Section 5. This data can therefore be used to examine the cycle counts used to draw the graphs. This raw data can be examined better in ~/data/data/results.org~, which includes the tables in a nicer format. + +The ~legup-*~ csv files contain the raw size, timing and cycle count for the various LegUp configurations on the different benchmarks. ~vericert-*~ is the equivalent but for Vericert. Then, to draw the graphs, the actual csv files that are used are: + +- ~rel-size-*~ :: This contains the relative size of each run (denoted by slice in the csv files) compared to fully optimised LegUp. This is obtained by taking the slice value of the tool being considered (LegUp with some optimisation turned off, or Vericert), and dividing that by the number of slices present in fully optimised LegUp. + +\[\frac{\text{slice}_t}{\text{slice}_{\text{legup\_opt}}}\] + +- ~rel-time-*~ :: This performs the same computation as for the size comparison, comparing to LegUp with all optimisations turned on, but instead compares the following values: cycles $\times$ delay: + +\[\frac{\text{cycles}_t \times \text{delay}_t}{\text{cycles}_{\text{legup\_opt}} \times \text{delay}_{\text{legup\_opt}}}\] + +Where $t$ is the tool being considered. + +*** Compiling the graph + +A tex file is included in the ~/data/data~ directory, which unfortunately can only be compiled outside of the docker file, but will recreate the graphs from the paper using the csv files in the directory. This can be achieved using the following commands: + +#+begin_src shell +docker create ymherklotz/vericert:v1.0 # returns container ID +docker cp $container_id:/data/data . +docker rm $container_id +cd data +pdflatex graphs +#+end_src + +** Running with Vivado + +Finally, for the adventurous that downloaded Vivado, there are some short instructions for running it on single examples. Running synthesis on a benchmark will normally take around 20 minutes to an hour depending on the benchmark, so it might take a long time to complete. + +First, create a new directory and copy the synthesis script into it, as well as the Verilog file that should be synthesisd. For example, once ~make~ was run in the benchmarks folder, one of the benchmarks can be selected for Vericert, such as ~jacobi-1d~: + +#+begin_src shell +mkdir synthesis +cd synthesis +cp /vericert/scripts/synth.tcl . +cp /vericert/benchmarks/polybench-syn/stencils/jacobi-1d.v main.v +#+end_src + +Then Vivado can be run in batch mode in that directory to generate the report: + +#+begin_src shell +vivado -mode batch -source synth.tcl +#+end_src + +Once this completes, the important results of the synthesis should be available in ~encode_report.xml~, where each field will also be present in the relevant CSV file, which is this case is ~/data/data/vericert-nodiv.csv~. + +** Rebuilding the Docker image + +The docker image can be completely rebuilt from scratch as well, by using the Dockerfile that is located in the Vericert repository at ~/vericert/scripts/docker/Dockerfile~, which also contains this document. + +To rebuild the docker image, one first needs to download the LegUp results for the benchmarks without divider[fn:4] and with divider[fn:5], as well as the csv folder with all the raw results[fn:6]. The tar files should be placed into the same directory as the ~Dockerfile~. Then, in the ~docker~ directory, the following will build the docker image, which might take around 20 minutes: + +#+begin_src shell +docker build . +#+end_src + +Then, using the hash it can be run in the same way as the docker container that was linked to this artifact: + +#+begin_src shell +docker run -it <hash> sh +#+end_src + +** Building from git without Docker. + +The only dependency that is require is nix[fn:7]. Once that is installed, we can clone the Github repository and checkout the ~oopsla21~ branch: + +#+begin_src shell +git clone https://github.com/ymherklotz/vericert +cd vericert +git checkout oopsla21 +#+end_src + +Then, it can be compiled and installed using: + +#+begin_src shell +nix-shell --run "make -j7" +nix-shell --run "make install" +nix-shell --run "./bin/vericert ./test/add.c -o add.v" +#+end_src + +* Footnotes + + +[fn:7] https://nixos.org/download.html +[fn:6] https://imperialcollegelondon.box.com/s/nqoaquk7j5mj70db16s6bdbhg44zjn52 +[fn:5] https://imperialcollegelondon.box.com/s/94clcbjowla3987opf3icjz087ozoi1o +[fn:4] https://imperialcollegelondon.box.com/s/ril1utuk2n88fhoq3375oxiqcgw42b8a +[fn:3] https://www.xilinx.com/support/download.html +[fn:2] https://legup.eecg.utoronto.ca +[fn:1] https://www.microsemi.com/product-directory/fpga-design-tools/5590-hls#software-download diff --git a/scripts/docker/artifact.pdf b/scripts/docker/artifact.pdf Binary files differnew file mode 100644 index 0000000..05ec4fd --- /dev/null +++ b/scripts/docker/artifact.pdf diff --git a/scripts/run-legup.sh b/scripts/run-legup.sh new file mode 100644 index 0000000..3b6f60f --- /dev/null +++ b/scripts/run-legup.sh @@ -0,0 +1,17 @@ +#!/usr/bin/env bash + +top=$(pwd) +vericert=/vericert +rm $top/exec_legup.csv +legup_dir=/data/legup-polybench-$1/legup/legup_$2 + +echo benchmark,cycles >$top/exec_legup.csv + +while read benchmark ; do + echo -n "compiling $(basename "$benchmark"): " + cd $legup_dir/$benchmark + iverilog -o run -s main_tb $vericert/ip/* legup.v + cycles=$(./run | sed -n 3p | sed -E -e 's/[^0-9]+([0-9]+)/\1/') + echo "$(basename "$benchmark"),$cycles" >>$top/exec_legup.csv + echo $cycles cycles +done < benchmark-list-master diff --git a/scripts/run-vivado.sh b/scripts/run-vivado.sh new file mode 100755 index 0000000..117054d --- /dev/null +++ b/scripts/run-vivado.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +benchmark=./$1/$2 +echo $benchmark + + cp ./synth.tcl $benchmark/. 2>/dev/null + cd $benchmark || exit 1 + vivado -mode batch -source synth.tcl >vivado.log 2>&1 diff --git a/scripts/synth.tcl b/scripts/synth.tcl new file mode 100644 index 0000000..e5151e8 --- /dev/null +++ b/scripts/synth.tcl @@ -0,0 +1,109 @@ +proc dump_statistics { } { + set util_rpt [report_utilization -return_string] + set LUTFFPairs 0 + set SliceRegisters 0 + set Slice 0 + set SliceLUTs 0 + set SliceLUTs1 0 + set BRAMFIFO36 0 + set BRAMFIFO18 0 + set BRAMFIFO36_star 0 + set BRAMFIFO18_star 0 + set BRAM18 0 + set BRAMFIFO 0 + set BIOB 0 + set DSPs 0 + set TotPower 0 + set design_slack 0 + set design_req 0 + set design_delay 0 + regexp -- {\s*LUT Flip Flop Pairs\s*\|\s*([^[:blank:]]+)} $util_rpt ignore LUTFFPairs + regexp -- {\s*Slice Registers\s*\|\s*([^[:blank:]]+)} $util_rpt ignore SliceRegisters + regexp -- {\s*Slice\s*\|\s*([^[:blank:]]+)} $util_rpt ignore Slice + regexp -- {\s*Slice LUTs\s*\|\s*([^[:blank:]]+)} $util_rpt ignore SliceLUTs + regexp -- {\s*Slice LUTs\*\s*\|\s*([^[:blank:]]+)} $util_rpt ignore SliceLUTs1 + if { [expr {$LUTFFPairs == 0}] } { + set LUTFFPairs $SliceLUTs1 + puts $SliceLUTs1 + } + if { [expr {$SliceLUTs == 0}] } { + set SliceLUTs $SliceLUTs1 + } + regexp -- {\s*RAMB36/FIFO36\s*\|\s*([^[:blank:]]+)} $util_rpt ignore BRAMFIFO36 + regexp -- {\s*RAMB18/FIFO18\s*\|\s*([^[:blank:]]+)} $util_rpt ignore BRAMFIFO18 + regexp -- {\s*RAMB36/FIFO\*\s*\|\s*([^[:blank:]]+)} $util_rpt ignore BRAMFIFO36_star + regexp -- {\s*RAMB18/FIFO\*\s*\|\s*([^[:blank:]]+)} $util_rpt ignore BRAMFIFO18_star + regexp -- {\s*RAMB18\s*\|\s*([^[:blank:]]+)} $util_rpt ignore BRAM18 + set BRAMFIFO [expr {(2 *$BRAMFIFO36) + $BRAMFIFO18 + (2*$BRAMFIFO36_star) + $BRAMFIFO18_star + $BRAM18}] + regexp -- {\s*Bonded IOB\s*\|\s*([^[:blank:]]+)} $util_rpt ignore BIOB + regexp -- {\s*DSPs\s*\|\s*([^[:blank:]]+)} $util_rpt ignore DSPs + set power_rpt [report_power -return_string] + regexp -- {\s*Total On-Chip Power \(W\)\s*\|\s*([^[:blank:]]+)} $power_rpt ignore TotPower + set Timing_Paths [get_timing_paths -max_paths 1 -nworst 1 -setup] + if { [expr {$Timing_Paths == ""}] } { + set design_slack 0 + set design_req 0 + } else { + set design_slack [get_property SLACK $Timing_Paths] + set design_req [get_property REQUIREMENT $Timing_Paths] + } + if { [expr {$design_slack == ""}] } { + set design_slack 0 + } + if { [expr {$design_req == ""}] } { + set design_req 0 + } + set design_delay [expr {$design_req - $design_slack}] + file delete -force encode_report.xml + set ofile_report [open encode_report.xml w] + puts $ofile_report "<?xml version=\"1.0\"?>" + puts $ofile_report "<document>" + puts $ofile_report " <application>" + puts $ofile_report " <section stringID=\"XILINX_SYNTHESIS_SUMMARY\">" + puts $ofile_report " <item stringID=\"XILINX_LUT_FLIP_FLOP_PAIRS_USED\" value=\"$LUTFFPairs\"/>" + puts $ofile_report " <item stringID=\"XILINX_SLICE\" value=\"$Slice\"/>" + puts $ofile_report " <item stringID=\"XILINX_SLICE_REGISTERS\" value=\"$SliceRegisters\"/>" + puts $ofile_report " <item stringID=\"XILINX_SLICE_LUTS\" value=\"$SliceLUTs\"/>" + puts $ofile_report " <item stringID=\"XILINX_BLOCK_RAMFIFO\" value=\"$BRAMFIFO\"/>" + puts $ofile_report " <item stringID=\"XILINX_IOPIN\" value=\"$BIOB\"/>" + puts $ofile_report " <item stringID=\"XILINX_DSPS\" value=\"$DSPs\"/>" + puts $ofile_report " <item stringID=\"XILINX_POWER\" value=\"$TotPower\"/>" + puts $ofile_report " <item stringID=\"XILINX_DESIGN_DELAY\" value=\"$design_delay\"/>" + puts $ofile_report " </section>" + puts $ofile_report " </application>" + puts $ofile_report "</document>" + close $ofile_report +}; #END PROC +set outputDir . +create_project -in_memory -part xc7z020clg484-1 -force +read_verilog main.v +synth_design -mode out_of_context -no_iobuf -top main -part xc7z020clg484-1 +write_checkpoint -force $outputDir/post_synth.dcp +report_timing_summary -file $outputDir/post_synth_timing_summary.rpt +report_utilization -file $outputDir/post_synth_util.rpt +create_clock -name clk -period 10.000 [get_ports clk] +dump_statistics +opt_design +dump_statistics +report_utilization -file $outputDir/post_opt_design_util.rpt +place_design -directive Explore +report_clock_utilization -file $outputDir/clock_util.rpt +# Optionally run optimization if there are timing violations after placement +if {[get_property SLACK [get_timing_paths -max_paths 1 -nworst 1 -setup]] < 0.5} { + puts "Found setup timing violations => running physical optimization" + phys_opt_design +} +write_checkpoint -force $outputDir/post_place.dcp +report_utilization -file $outputDir/post_place_util.rpt +report_timing_summary -file $outputDir/post_place_timing_summary.rpt +dump_statistics +route_design -directive Explore +write_checkpoint -force $outputDir/post_route.dcp +report_route_status -file $outputDir/post_route_status.rpt +report_timing_summary -file $outputDir/post_route_timing_summary.rpt +report_power -file $outputDir/post_route_power.rpt +report_drc -file $outputDir/post_imp_drc.rpt +report_utilization -file $outputDir/post_route_util.rpt +dump_statistics +close_design +close_project diff --git a/scripts/verilator_main.cpp b/scripts/verilator_main.cpp new file mode 100644 index 0000000..94b6a33 --- /dev/null +++ b/scripts/verilator_main.cpp @@ -0,0 +1,35 @@ +#include <stdlib.h> +#include <stdio.h> +#include "Vmain.h" +#include "verilated.h" + +int main(int argc, char **argv) { + // Initialize Verilators variables + Verilated::commandArgs(argc, argv); + + // Create an instance of our module under test + Vmain *tb = new Vmain; + + tb->clk = 0; + tb->start = 0; + tb->reset = 0; + tb->eval(); tb->clk = 1; tb->eval(); tb->clk = 0; tb->eval(); + tb->reset = 1; + tb->eval(); tb->clk = 1; tb->eval(); tb->clk = 0; tb->eval(); + tb->reset = 0; + tb->eval(); tb->clk = 1; tb->eval(); tb->clk = 0; tb->eval(); + + size_t cycles = 1; + + // Tick the clock until we are done + while(!tb->finish) { + tb->clk = 1; + tb->eval(); + tb->clk = 0; + tb->eval(); + cycles++; + } + + printf("cycles: %lu\nfinished: %u\n", cycles, (unsigned)tb->return_val); + exit(EXIT_SUCCESS); +} diff --git a/src/Compiler.v b/src/Compiler.v index e9d76dc..ff0938e 100644 --- a/src/Compiler.v +++ b/src/Compiler.v @@ -65,11 +65,13 @@ Require vericert.hls.HTLgen. Require vericert.hls.RTLBlock. Require vericert.hls.RTLBlockgen. Require vericert.hls.RTLPargen. +Require vericert.hls.RTLParFUgen. Require vericert.hls.HTLPargen. Require vericert.hls.Pipeline. Require vericert.hls.IfConversion. -Require vericert.hls.PipelineOp. +(*Require vericert.hls.PipelineOp.*) Require vericert.HLSOpts. +Require vericert.hls.Memorygen. Require Import vericert.hls.HTLgenproof. @@ -81,7 +83,7 @@ We then need to declare the external OCaml functions used to print out intermedi |*) Parameter print_RTL: Z -> RTL.program -> unit. -Parameter print_HTL: HTL.program -> unit. +Parameter print_HTL: Z -> HTL.program -> unit. Parameter print_RTLBlock: Z -> RTLBlock.program -> unit. Parameter print_RTLPar: Z -> RTLPar.program -> unit. @@ -192,7 +194,9 @@ Definition transf_backend (r : RTL.program) : res Verilog.program := @@@ time "Unused globals" Unusedglob.transform_program @@ print (print_RTL 7) @@@ HTLgen.transl_program - @@ print print_HTL + @@ print (print_HTL 0) + @@ total_if HLSOpts.optim_ram Memorygen.transf_program + @@ print (print_HTL 1) @@ Veriloggen.transl_program. (*| @@ -214,6 +218,8 @@ Definition transf_hls (p : Csyntax.program) : res Verilog.program := .. coq:: none |*) +(* This is an unverified version of transf_hls with some experimental additions such as scheduling +that aren't completed yet. *) Definition transf_hls_temp (p : Csyntax.program) : res Verilog.program := OK p @@@ SimplExpr.transl_program @@ -237,15 +243,14 @@ Definition transf_hls_temp (p : Csyntax.program) : res Verilog.program := @@@ time "Unused globals" Unusedglob.transform_program @@ print (print_RTL 7) @@@ RTLBlockgen.transl_program - @@ print (print_RTLBlock 1) + @@ print (print_RTLBlock 0) @@ total_if HLSOpts.optim_if_conversion IfConversion.transf_program - @@ print (print_RTLBlock 2) + @@ print (print_RTLBlock 1) @@@ RTLPargen.transl_program - @@ print (print_RTLPar 1) - @@ PipelineOp.transf_program - @@ print (print_RTLPar 2) + @@ print (print_RTLPar 0) + @@@ RTLParFUgen.transl_program @@@ HTLPargen.transl_program - @@ print print_HTL + @@ print (print_HTL 0) @@ Veriloggen.transl_program. (*| @@ -272,6 +277,7 @@ Definition CompCert's_passes := ::: mkpass (match_if Compopts.optim_redundancy Deadcodeproof.match_prog) ::: mkpass Unusedglobproof.match_prog ::: (@mkpass _ _ HTLgenproof.match_prog (HTLgenproof.TransfHTLLink HTLgen.transl_program)) + ::: mkpass (match_if HLSOpts.optim_ram Memorygen.match_prog) ::: mkpass Veriloggenproof.match_prog ::: pass_nil _. @@ -309,7 +315,8 @@ Proof. destruct (partial_if Compopts.optim_redundancy Deadcode.transf_program p11) as [p12|e] eqn:P12; simpl in T; try discriminate. destruct (Unusedglob.transform_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. destruct (HTLgen.transl_program p13) as [p14|e] eqn:P14; simpl in T; try discriminate. - set (p15 := Veriloggen.transl_program p14) in *. + set (p15 := total_if HLSOpts.optim_ram Memorygen.transf_program p14) in *. + set (p16 := Veriloggen.transl_program p15) in *. unfold match_prog; simpl. exists p1; split. apply SimplExprproof.transf_program_match; auto. exists p2; split. apply SimplLocalsproof.match_transf_program; auto. @@ -325,7 +332,8 @@ Proof. exists p12; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match. exists p13; split. apply Unusedglobproof.transf_program_match; auto. exists p14; split. apply HTLgenproof.transf_program_match; auto. - exists p15; split. apply Veriloggenproof.transf_program_match; auto. + exists p15; split. apply total_if_match. apply Memorygen.transf_program_match; auto. + exists p16; split. apply Veriloggenproof.transf_program_match; auto. inv T. reflexivity. Qed. @@ -343,7 +351,7 @@ Ltac DestructM := destruct H as (p & M & MM); clear H end. repeat DestructM. subst tp. - assert (F: forward_simulation (Cstrategy.semantics p) (Verilog.semantics p15)). + assert (F: forward_simulation (Cstrategy.semantics p) (Verilog.semantics p16)). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -373,6 +381,8 @@ Ltac DestructM := eapply Unusedglobproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply HTLgenproof.transf_program_correct. eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Memorygen.transf_program_correct; eassumption. eapply Veriloggenproof.transf_program_correct; eassumption. } split. auto. diff --git a/src/HLSOpts.v b/src/HLSOpts.v index 173300d..efa7ed0 100644 --- a/src/HLSOpts.v +++ b/src/HLSOpts.v @@ -17,3 +17,5 @@ *) Parameter optim_if_conversion: unit -> bool. + +Parameter optim_ram: unit -> bool. diff --git a/src/SoftwarePipelining/LICENSE b/src/SoftwarePipelining/LICENSE new file mode 100644 index 0000000..e275fa0 --- /dev/null +++ b/src/SoftwarePipelining/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2008,2009,2010 Jean-Baptiste Tristan and INRIA + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/src/VericertClflags.ml b/src/VericertClflags.ml index 930b613..ab3c949 100644 --- a/src/VericertClflags.ml +++ b/src/VericertClflags.ml @@ -8,3 +8,4 @@ let option_drtlblock = ref false let option_drtlpar = ref false let option_hls_schedule = ref false let option_fif_conv = ref false +let option_fram = ref true diff --git a/src/common/Monad.v b/src/common/Monad.v index 5e8385e..fcbe527 100644 --- a/src/common/Monad.v +++ b/src/common/Monad.v @@ -40,10 +40,10 @@ Module MonadExtra(M : Monad). Notation "'do' X <- A ; B" := (bind A (fun X => B)) - (at level 200, X ident, A at level 100, B at level 200). + (at level 200, X name, A at level 100, B at level 200). Notation "'do' ( X , Y ) <- A ; B" := (bind2 A (fun X Y => B)) - (at level 200, X ident, Y ident, A at level 100, B at level 200). + (at level 200, X name, Y name, A at level 100, B at level 200). End MonadNotation. Import MonadNotation. diff --git a/src/common/Vericertlib.v b/src/common/Vericertlib.v index b58ebd4..389a74f 100644 --- a/src/common/Vericertlib.v +++ b/src/common/Vericertlib.v @@ -34,7 +34,7 @@ Require Import vericert.common.Show. (* Depend on CompCert for the basic library, as they declare and prove some useful theorems. *) -Local Open Scope Z_scope. +#[local] Open Scope Z_scope. (* This tactic due to Clement Pit-Claudel with some minor additions by JDP to allow the result to be named: https://pit-claudel.fr/clement/MSc/#org96a1b5f *) @@ -190,8 +190,8 @@ Ltac liapp := Ltac crush := simplify; try discriminate; try congruence; try lia; liapp; try assumption; try (solve [auto]). -Global Opaque Nat.div. -Global Opaque Z.mul. +#[global] Opaque Nat.div. +#[global] Opaque Z.mul. (* Definition const (A B : Type) (a : A) (b : B) : A := a. @@ -231,7 +231,7 @@ Definition join {A : Type} (a : option (option A)) : option A := Module Notation. Notation "'do' X <- A ; B" := (bind A (fun X => B)) - (at level 200, X ident, A at level 100, B at level 200). + (at level 200, X name, A at level 100, B at level 200). End Notation. End Option. diff --git a/src/extraction/Extraction.v b/src/extraction/Extraction.v index 5c1dac5..bca8fb5 100644 --- a/src/extraction/Extraction.v +++ b/src/extraction/Extraction.v @@ -25,7 +25,9 @@ From vericert Require RTLBlockInstr HTLgen Pipeline - HLSOpts. + HLSOpts + Predicate +. From Coq Require DecidableClass. @@ -134,6 +136,8 @@ Extract Constant Compopts.debug => Extract Constant HLSOpts.optim_if_conversion => "fun _ -> !VericertClflags.option_fif_conv". +Extract Constant HLSOpts.optim_ram => + "fun _ -> !VericertClflags.option_fram". (* Compiler *) Extract Constant Compiler.print_Clight => "PrintClight.print_if". @@ -143,6 +147,7 @@ Extract Constant Compiler.print_RTL => "PrintRTL.print_if". Extract Constant Compiler.print_RTLBlock => "PrintRTLBlock.print_if". Extract Constant Compiler.print_RTLPar => "PrintRTLPar.print_if". Extract Constant Compiler.print_HTL => "PrintHTL.print_if". +Extract Constant Compiler.print_RTLPar => "PrintRTLPar.print_if". Extract Constant Compiler.print_LTL => "PrintLTL.print_if". Extract Constant Compiler.print_Mach => "PrintMach.print_if". Extract Constant Compiler.print => "fun (f: 'a -> unit) (x: 'a) -> f x; x". @@ -190,7 +195,8 @@ Separate Extraction RTLBlockgen.transl_program RTLBlockInstr.successors_instr HTLgen.tbl_to_case_expr Pipeline.pipeline - RTLBlockInstr.sat_pred_temp + Predicate.sat_pred_simple + Verilog.stmnt_to_list Compiler.transf_c_program Compiler.transf_cminor_program Cexec.do_initial_state Cexec.do_step Cexec.at_final_state diff --git a/src/hls/Abstr.v b/src/hls/Abstr.v new file mode 100644 index 0000000..2ab79cf --- /dev/null +++ b/src/hls/Abstr.v @@ -0,0 +1,1443 @@ +(* + * Vericert: Verified high-level synthesis. + * Copyright (C) 2021 Yann Herklotz <yann@yannherklotz.com> + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see <https://www.gnu.org/licenses/>. + *) + +Require Import Coq.Logic.Decidable. + +Require Import compcert.backend.Registers. +Require Import compcert.common.AST. +Require Import compcert.common.Globalenvs. +Require Import compcert.common.Memory. +Require Import compcert.common.Values. +Require Import compcert.lib.Floats. +Require Import compcert.lib.Integers. +Require Import compcert.lib.Maps. +Require compcert.verilog.Op. + +Require Import vericert.common.Vericertlib. +Require Import vericert.hls.RTLBlock. +Require Import vericert.hls.RTLPar. +Require Import vericert.hls.RTLBlockInstr. +Require Import vericert.hls.HashTree. +Require Import vericert.hls.Predicate. + +#[local] Open Scope positive. +#[local] Open Scope pred_op. + +(*| +Schedule Oracle +=============== + +This oracle determines if a schedule was valid by performing symbolic execution on the input and +output and showing that these behave the same. This acts on each basic block separately, as the +rest of the functions should be equivalent. +|*) + +Definition reg := positive. + +Inductive resource : Set := +| Reg : reg -> resource +| Pred : reg -> resource +| Mem : resource. + +(*| +The following defines quite a few equality comparisons automatically, however, these can be +optimised heavily if written manually, as their proofs are not needed. +|*) + +Lemma resource_eq : forall (r1 r2 : resource), {r1 = r2} + {r1 <> r2}. +Proof. + decide equality; apply Pos.eq_dec. +Defined. + +Lemma comparison_eq: forall (x y : comparison), {x = y} + {x <> y}. +Proof. + decide equality. +Defined. + +Lemma condition_eq: forall (x y : Op.condition), {x = y} + {x <> y}. +Proof. + generalize comparison_eq; intro. + generalize Int.eq_dec; intro. + generalize Int64.eq_dec; intro. + decide equality. +Defined. + +Lemma addressing_eq : forall (x y : Op.addressing), {x = y} + {x <> y}. +Proof. + generalize Int.eq_dec; intro. + generalize AST.ident_eq; intro. + generalize Z.eq_dec; intro. + generalize Ptrofs.eq_dec; intro. + decide equality. +Defined. + +Lemma typ_eq : forall (x y : AST.typ), {x = y} + {x <> y}. +Proof. + decide equality. +Defined. + +Lemma operation_eq: forall (x y : Op.operation), {x = y} + {x <> y}. +Proof. + generalize Int.eq_dec; intro. + generalize Int64.eq_dec; intro. + generalize Float.eq_dec; intro. + generalize Float32.eq_dec; intro. + generalize AST.ident_eq; intro. + generalize condition_eq; intro. + generalize addressing_eq; intro. + generalize typ_eq; intro. + decide equality. +Defined. + +Lemma memory_chunk_eq : forall (x y : AST.memory_chunk), {x = y} + {x <> y}. +Proof. + decide equality. +Defined. + +Lemma list_typ_eq: forall (x y : list AST.typ), {x = y} + {x <> y}. +Proof. + generalize typ_eq; intro. + decide equality. +Defined. + +Lemma option_typ_eq : forall (x y : option AST.typ), {x = y} + {x <> y}. +Proof. + generalize typ_eq; intro. + decide equality. +Defined. + +Lemma signature_eq: forall (x y : AST.signature), {x = y} + {x <> y}. +Proof. + repeat decide equality. +Defined. + +Lemma list_operation_eq : forall (x y : list Op.operation), {x = y} + {x <> y}. +Proof. + generalize operation_eq; intro. + decide equality. +Defined. + +Lemma list_reg_eq : forall (x y : list reg), {x = y} + {x <> y}. +Proof. + generalize Pos.eq_dec; intros. + decide equality. +Defined. + +Lemma sig_eq : forall (x y : AST.signature), {x = y} + {x <> y}. +Proof. + repeat decide equality. +Defined. + +Lemma instr_eq: forall (x y : instr), {x = y} + {x <> y}. +Proof. + generalize Pos.eq_dec; intro. + generalize typ_eq; intro. + generalize Int.eq_dec; intro. + generalize memory_chunk_eq; intro. + generalize addressing_eq; intro. + generalize operation_eq; intro. + generalize condition_eq; intro. + generalize signature_eq; intro. + generalize list_operation_eq; intro. + generalize list_reg_eq; intro. + generalize AST.ident_eq; intro. + repeat decide equality. +Defined. + +Lemma cf_instr_eq: forall (x y : cf_instr), {x = y} + {x <> y}. +Proof. + generalize Pos.eq_dec; intro. + generalize typ_eq; intro. + generalize Int.eq_dec; intro. + generalize Int64.eq_dec; intro. + generalize Float.eq_dec; intro. + generalize Float32.eq_dec; intro. + generalize Ptrofs.eq_dec; intro. + generalize memory_chunk_eq; intro. + generalize addressing_eq; intro. + generalize operation_eq; intro. + generalize condition_eq; intro. + generalize signature_eq; intro. + generalize list_operation_eq; intro. + generalize list_reg_eq; intro. + generalize AST.ident_eq; intro. + repeat decide equality. +Defined. + +(*| +We then create equality lemmas for a resource and a module to index resources uniquely. The +indexing is done by setting Mem to 1, whereas all other infinitely many registers will all be +shifted right by 1. This means that they will never overlap. +|*) + +Module R_indexed. + Definition t := resource. + Definition index (rs: resource) : positive := + match rs with + | Reg r => xO (xO r) + | Pred r => xI (xI r) + | Mem => 1%positive + end. + + Lemma index_inj: forall (x y: t), index x = index y -> x = y. + Proof. destruct x; destruct y; crush. Qed. + + Definition eq := resource_eq. +End R_indexed. + +(*| +We can then create expressions that mimic the expressions defined in RTLBlock and RTLPar, which use +expressions instead of registers as their inputs and outputs. This means that we can accumulate all +the results of the operations as general expressions that will be present in those registers. + +- Ebase: the starting value of the register. +- Eop: Some arithmetic operation on a number of registers. +- Eload: A load from a memory location into a register. +- Estore: A store from a register to a memory location. + +Then, to make recursion over expressions easier, expression_list is also defined in the datatype, as +that enables mutual recursive definitions over the datatypes. +|*) + +Inductive expression : Type := +| Ebase : resource -> expression +| Eop : Op.operation -> expression_list -> expression +| Eload : AST.memory_chunk -> Op.addressing -> expression_list -> expression -> expression +| Estore : expression -> AST.memory_chunk -> Op.addressing -> expression_list -> expression -> expression +| Esetpred : Op.condition -> expression_list -> expression +with expression_list : Type := +| Enil : expression_list +| Econs : expression -> expression_list -> expression_list +. + +(*Inductive pred_expr : Type := +| PEsingleton : option pred_op -> expression -> pred_expr +| PEcons : option pred_op -> expression -> pred_expr -> pred_expr.*) + +Module NonEmpty. + +Inductive non_empty (A: Type) := +| singleton : A -> non_empty A +| cons : A -> non_empty A -> non_empty A +. + +Arguments singleton [A]. +Arguments cons [A]. + +Declare Scope non_empty_scope. +Delimit Scope non_empty_scope with non_empty. + +Module NonEmptyNotation. +Infix "::|" := cons (at level 60, right associativity) : non_empty_scope. +End NonEmptyNotation. +Import NonEmptyNotation. + +#[local] Open Scope non_empty_scope. + +Fixpoint map {A B} (f: A -> B) (l: non_empty A): non_empty B := + match l with + | singleton a => singleton (f a) + | a ::| b => f a ::| map f b + end. + +Fixpoint to_list {A} (l: non_empty A): list A := + match l with + | singleton a => a::nil + | a ::| b => a :: to_list b + end. + +Fixpoint app {A} (l1 l2: non_empty A) := + match l1 with + | singleton a => a ::| l2 + | a ::| b => a ::| app b l2 + end. + +Fixpoint non_empty_prod {A B} (l: non_empty A) (l': non_empty B) := + match l with + | singleton a => map (fun x => (a, x)) l' + | a ::| b => app (map (fun x => (a, x)) l') (non_empty_prod b l') + end. + +Fixpoint of_list {A} (l: list A): option (non_empty A) := + match l with + | a::b => + match of_list b with + | Some b' => Some (a ::| b') + | _ => None + end + | nil => None + end. + +Fixpoint replace {A} (f: A -> A -> bool) (a b: A) (l: non_empty A) := + match l with + | a' ::| l' => if f a a' then b ::| replace f a b l' else a' ::| replace f a b l' + | singleton a' => if f a a' then singleton b else singleton a' + end. + +Inductive In {A: Type} (x: A) : non_empty A -> Prop := +| In_cons : forall a b, x = a \/ In x b -> In x (a ::| b) +| In_single : In x (singleton x). + +Lemma in_dec: + forall A (a: A) (l: non_empty A), + (forall a b: A, {a = b} + {a <> b}) -> + {In a l} + {~ In a l}. +Proof. + induction l; intros. + { specialize (X a a0). inv X. + left. constructor. + right. unfold not. intros. apply H. inv H0. auto. } + { pose proof X as X2. + specialize (X a a0). inv X. + left. constructor; tauto. + apply IHl in X2. inv X2. + left. constructor; tauto. + right. unfold not in *; intros. apply H0. inv H1. now inv H3. } +Qed. + +End NonEmpty. + +Module NE := NonEmpty. +Import NE.NonEmptyNotation. + +#[local] Open Scope non_empty_scope. + +Definition predicated A := NE.non_empty (pred_op * A). + +Definition pred_expr := predicated expression. + +(*| +Using IMap we can create a map from resources to any other type, as resources can be uniquely +identified as positive numbers. +|*) + +Module Rtree := ITree(R_indexed). + +Definition forest : Type := Rtree.t pred_expr. + +Definition get_forest v (f: forest) := + match Rtree.get v f with + | None => NE.singleton (T, (Ebase v)) + | Some v' => v' + end. + +Declare Scope forest. + +Notation "a # b" := (get_forest b a) (at level 1) : forest. +Notation "a # b <- c" := (Rtree.set b c a) (at level 1, b at next level) : forest. + +#[local] Open Scope forest. + +Definition maybe {A: Type} (vo: A) (pr: predset) p (v: A) := + match p with + | Some p' => if eval_predf pr p' then v else vo + | None => v + end. + +Definition get_pr i := match i with mk_instr_state a b c => b end. + +Definition get_m i := match i with mk_instr_state a b c => c end. + +Definition eval_predf_opt pr p := + match p with Some p' => eval_predf pr p' | None => true end. + +(*| +Finally we want to define the semantics of execution for the expressions with symbolic values, so +the result of executing the expressions will be an expressions. +|*) + +Section SEMANTICS. + +Context {A : Type}. + +Record ctx : Type := mk_ctx { + ctx_is: instr_state; + ctx_sp: val; + ctx_ge: Genv.t A unit; +}. + +Definition ctx_rs ctx := is_rs (ctx_is ctx). +Definition ctx_ps ctx := is_ps (ctx_is ctx). +Definition ctx_mem ctx := is_mem (ctx_is ctx). + +Inductive sem_value : ctx -> expression -> val -> Prop := +| Sbase_reg: + forall r ctx, + sem_value ctx (Ebase (Reg r)) ((ctx_rs ctx) !! r) +| Sop: + forall ctx op args v lv, + sem_val_list ctx args lv -> + Op.eval_operation (ctx_ge ctx) (ctx_sp ctx) op lv (ctx_mem ctx) = Some v -> + sem_value ctx (Eop op args) v +| Sload : + forall ctx mexp addr chunk args a v m' lv, + sem_mem ctx mexp m' -> + sem_val_list ctx args lv -> + Op.eval_addressing (ctx_ge ctx) (ctx_sp ctx) addr lv = Some a -> + Memory.Mem.loadv chunk m' a = Some v -> + sem_value ctx (Eload chunk addr args mexp) v +with sem_pred : ctx -> expression -> bool -> Prop := +| Spred: + forall ctx args c lv v, + sem_val_list ctx args lv -> + Op.eval_condition c lv (ctx_mem ctx) = Some v -> + sem_pred ctx (Esetpred c args) v +| Sbase_pred: + forall ctx p, + sem_pred ctx (Ebase (Pred p)) ((ctx_ps ctx) !! p) +with sem_mem : ctx -> expression -> Memory.mem -> Prop := +| Sstore : + forall ctx mexp vexp chunk addr args lv v a m' m'', + sem_mem ctx mexp m' -> + sem_value ctx vexp v -> + sem_val_list ctx args lv -> + Op.eval_addressing (ctx_ge ctx) (ctx_sp ctx) addr lv = Some a -> + Memory.Mem.storev chunk m' a v = Some m'' -> + sem_mem ctx (Estore vexp chunk addr args mexp) m'' +| Sbase_mem : + forall ctx, + sem_mem ctx (Ebase Mem) (ctx_mem ctx) +with sem_val_list : ctx -> expression_list -> list val -> Prop := +| Snil : + forall ctx, + sem_val_list ctx Enil nil +| Scons : + forall ctx e v l lv, + sem_value ctx e v -> + sem_val_list ctx l lv -> + sem_val_list ctx (Econs e l) (v :: lv) +. + +Inductive sem_pred_expr {B: Type} (sem: ctx -> expression -> B -> Prop): + ctx -> pred_expr -> B -> Prop := +| sem_pred_expr_cons_true : + forall ctx e pr p' v, + eval_predf (ctx_ps ctx) pr = true -> + sem ctx e v -> + sem_pred_expr sem ctx ((pr, e) ::| p') v +| sem_pred_expr_cons_false : + forall ctx e pr p' v, + eval_predf (ctx_ps ctx) pr = false -> + sem_pred_expr sem ctx p' v -> + sem_pred_expr sem ctx ((pr, e) ::| p') v +| sem_pred_expr_single : + forall ctx e pr v, + eval_predf (ctx_ps ctx) pr = true -> + sem ctx e v -> + sem_pred_expr sem ctx (NE.singleton (pr, e)) v +. + +Definition collapse_pe (p: pred_expr) : option expression := + match p with + | NE.singleton (T, p) => Some p + | _ => None + end. + +Inductive sem_predset : ctx -> forest -> predset -> Prop := +| Spredset: + forall ctx f rs', + (forall x, sem_pred_expr sem_pred ctx (f # (Pred x)) (rs' !! x)) -> + sem_predset ctx f rs'. + +Inductive sem_regset : ctx -> forest -> regset -> Prop := +| Sregset: + forall ctx f rs', + (forall x, sem_pred_expr sem_value ctx (f # (Reg x)) (rs' !! x)) -> + sem_regset ctx f rs'. + +Inductive sem : ctx -> forest -> instr_state -> Prop := +| Sem: + forall ctx rs' m' f pr', + sem_regset ctx f rs' -> + sem_predset ctx f pr' -> + sem_pred_expr sem_mem ctx (f # Mem) m' -> + sem ctx f (mk_instr_state rs' pr' m'). + +End SEMANTICS. + +Fixpoint beq_expression (e1 e2: expression) {struct e1}: bool := + match e1, e2 with + | Ebase r1, Ebase r2 => if resource_eq r1 r2 then true else false + | Eop op1 el1, Eop op2 el2 => + if operation_eq op1 op2 then + beq_expression_list el1 el2 else false + | Eload chk1 addr1 el1 e1, Eload chk2 addr2 el2 e2 => + if memory_chunk_eq chk1 chk2 + then if addressing_eq addr1 addr2 + then if beq_expression_list el1 el2 + then beq_expression e1 e2 else false else false else false + | Estore e1 chk1 addr1 el1 m1, Estore e2 chk2 addr2 el2 m2 => + if memory_chunk_eq chk1 chk2 + then if addressing_eq addr1 addr2 + then if beq_expression_list el1 el2 + then if beq_expression m1 m2 + then beq_expression e1 e2 else false else false else false else false + | Esetpred c1 el1, Esetpred c2 el2 => + if condition_eq c1 c2 + then beq_expression_list el1 el2 else false + | _, _ => false + end +with beq_expression_list (el1 el2: expression_list) {struct el1} : bool := + match el1, el2 with + | Enil, Enil => true + | Econs e1 t1, Econs e2 t2 => beq_expression e1 e2 && beq_expression_list t1 t2 + | _, _ => false + end +. + +Scheme expression_ind2 := Induction for expression Sort Prop + with expression_list_ind2 := Induction for expression_list Sort Prop. + +Lemma beq_expression_correct: + forall e1 e2, beq_expression e1 e2 = true -> e1 = e2. +Proof. + intro e1; + apply expression_ind2 with + (P := fun (e1 : expression) => + forall e2, beq_expression e1 e2 = true -> e1 = e2) + (P0 := fun (e1 : expression_list) => + forall e2, beq_expression_list e1 e2 = true -> e1 = e2); simplify; + try solve [repeat match goal with + | [ H : context[match ?x with _ => _ end] |- _ ] => destruct x eqn:? + | [ H : context[if ?x then _ else _] |- _ ] => destruct x eqn:? + end; subst; f_equal; crush; eauto using Peqb_true_eq]. +Qed. + +Lemma beq_expression_refl: forall e, beq_expression e e = true. +Proof. + intros. + induction e using expression_ind2 with (P0 := fun el => beq_expression_list el el = true); + crush; repeat (destruct_match; crush); []. + crush. rewrite IHe. rewrite IHe0. auto. +Qed. + +Lemma beq_expression_list_refl: forall e, beq_expression_list e e = true. +Proof. induction e; auto. simplify. rewrite beq_expression_refl. auto. Qed. + +Lemma beq_expression_correct2: + forall e1 e2, beq_expression e1 e2 = false -> e1 <> e2. +Proof. + induction e1 using expression_ind2 + with (P0 := fun el1 => forall el2, beq_expression_list el1 el2 = false -> el1 <> el2). + - intros. simplify. repeat (destruct_match; crush). + - intros. simplify. repeat (destruct_match; crush). subst. apply IHe1 in H. + unfold not in *. intros. apply H. inv H0. auto. + - intros. simplify. repeat (destruct_match; crush); subst. + unfold not in *; intros. inv H0. rewrite beq_expression_refl in H. discriminate. + unfold not in *; intros. inv H. rewrite beq_expression_list_refl in Heqb. discriminate. + - simplify. repeat (destruct_match; crush); subst; + unfold not in *; intros. + inv H0. rewrite beq_expression_refl in H; crush. + inv H. rewrite beq_expression_refl in Heqb0; crush. + inv H. rewrite beq_expression_list_refl in Heqb; crush. + - simplify. repeat (destruct_match; crush); subst. + unfold not in *; intros. inv H0. rewrite beq_expression_list_refl in H; crush. + - simplify. repeat (destruct_match; crush); subst. + - simplify. repeat (destruct_match; crush); subst. + apply andb_false_iff in H. inv H. unfold not in *; intros. + inv H. rewrite beq_expression_refl in H0; discriminate. + unfold not in *; intros. inv H. rewrite beq_expression_list_refl in H0; discriminate. +Qed. + +Lemma expression_dec: forall e1 e2: expression, {e1 = e2} + {e1 <> e2}. +Proof. + intros. + destruct (beq_expression e1 e2) eqn:?. apply beq_expression_correct in Heqb. auto. + apply beq_expression_correct2 in Heqb. auto. +Defined. + +Definition pred_expr_item_eq (pe1 pe2: pred_op * expression) : bool := + @equiv_dec _ SATSetoid _ (fst pe1) (fst pe2) && beq_expression (snd pe1) (snd pe2). + +Lemma pred_expr_dec: forall (pe1 pe2: pred_op * expression), + {pred_expr_item_eq pe1 pe2 = true} + {pred_expr_item_eq pe1 pe2 = false}. +Proof. + intros; destruct (pred_expr_item_eq pe1 pe2) eqn:?; unfold not; [tauto | now right]. +Qed. + +Lemma pred_expr_dec2: forall (pe1 pe2: pred_op * expression), + {pred_expr_item_eq pe1 pe2 = true} + {~ pred_expr_item_eq pe1 pe2 = true}. +Proof. + intros; destruct (pred_expr_item_eq pe1 pe2) eqn:?; unfold not; [tauto | now right]. +Qed. + +Module HashExpr <: Hashable. + Definition t := expression. + Definition eq_dec := expression_dec. +End HashExpr. + +Module HT := HashTree(HashExpr). +Import HT. + +Definition combine_option {A} (a b: option A) : option A := + match a, b with + | Some a', _ => Some a' + | _, Some b' => Some b' + | _, _ => None + end. + +Fixpoint norm_expression (max: predicate) (pe: pred_expr) (h: hash_tree) + : (PTree.t pred_op) * hash_tree := + match pe with + | NE.singleton (p, e) => + let (p', h') := hash_value max e h in + (PTree.set p' p (PTree.empty _), h') + | (p, e) ::| pr => + let (p', h') := hash_value max e h in + let (p'', h'') := norm_expression max pr h' in + match p'' ! p' with + | Some pr_op => + (PTree.set p' (pr_op ∨ p) p'', h'') + | None => + (PTree.set p' p p'', h'') + end + end. + +Definition mk_pred_stmnt' e p_e := ¬ p_e ∨ Plit (true, e). + +Definition mk_pred_stmnt t := PTree.fold (fun x a b => mk_pred_stmnt' a b ∧ x) t T. + +Definition mk_pred_stmnt_l (t: list (predicate * pred_op)) := fold_left (fun x a => uncurry mk_pred_stmnt' a ∧ x) t T. + +Definition encode_expression max pe h := + let (tree, h) := norm_expression max pe h in + (mk_pred_stmnt tree, h). + +(*Fixpoint encode_expression_ne (max: predicate) (pe: pred_expr_ne) (h: hash_tree) + : (PTree.t pred_op) * hash_tree := + match pe with + | NE.singleton (p, e) => + let (p', h') := hash_value max e h in + (Por (Pnot p) (Pvar p'), h') + | (p, e) ::| pr => + let (p', h') := hash_value max e h in + let (p'', h'') := encode_expression_ne max pr h' in + (Pand (Por (Pnot p) (Pvar p')) p'', h'') + end.*) + +Fixpoint max_pred_expr (pe: pred_expr) : positive := + match pe with + | NE.singleton (p, e) => max_predicate p + | (p, e) ::| pe' => Pos.max (max_predicate p) (max_pred_expr pe') + end. + +Definition empty : forest := Rtree.empty _. + +Definition ge_preserved {A B C D: Type} (ge: Genv.t A B) (tge: Genv.t C D) : Prop := + (forall sp op vl m, Op.eval_operation ge sp op vl m = + Op.eval_operation tge sp op vl m) + /\ (forall sp addr vl, Op.eval_addressing ge sp addr vl = + Op.eval_addressing tge sp addr vl). + +Lemma ge_preserved_same: + forall A B ge, @ge_preserved A B A B ge ge. +Proof. unfold ge_preserved; auto. Qed. +#[local] Hint Resolve ge_preserved_same : core. + +Inductive match_states : instr_state -> instr_state -> Prop := +| match_states_intro: + forall ps ps' rs rs' m m', + (forall x, rs !! x = rs' !! x) -> + (forall x, ps !! x = ps' !! x) -> + m = m' -> + match_states (mk_instr_state rs ps m) (mk_instr_state rs' ps' m'). + +Lemma match_states_refl x : match_states x x. +Proof. destruct x; constructor; crush. Qed. + +Lemma match_states_commut x y : match_states x y -> match_states y x. +Proof. inversion 1; constructor; crush. Qed. + +Lemma match_states_trans x y z : + match_states x y -> match_states y z -> match_states x z. +Proof. repeat inversion 1; constructor; crush. Qed. + +#[global] +Instance match_states_Equivalence : Equivalence match_states := + { Equivalence_Reflexive := match_states_refl ; + Equivalence_Symmetric := match_states_commut ; + Equivalence_Transitive := match_states_trans ; }. + +Inductive similar {A B} : @ctx A -> @ctx B -> Prop := +| similar_intro : + forall ist ist' sp ge tge, + ge_preserved ge tge -> + match_states ist ist' -> + similar (mk_ctx ist sp ge) (mk_ctx ist' sp tge). + +Definition beq_pred_expr_once (pe1 pe2: pred_expr) : bool := + match pe1, pe2 with + (*| PEsingleton None e1, PEsingleton None e2 => beq_expression e1 e2 + | PEsingleton (Some p1) e1, PEsingleton (Some p2) e2 => + if beq_expression e1 e2 + then match sat_pred_simple bound (Por (Pand p1 (Pnot p2)) (Pand p2 (Pnot p1))) with + | Some None => true + | _ => false + end + else false + | PEsingleton (Some p) e1, PEsingleton None e2 + | PEsingleton None e1, PEsingleton (Some p) e2 => + if beq_expression e1 e2 + then match sat_pred_simple bound (Pnot p) with + | Some None => true + | _ => false + end + else false*) + | pe1, pe2 => + let max := Pos.max (max_pred_expr pe1) (max_pred_expr pe2) in + let (p1, h) := encode_expression max pe1 (PTree.empty _) in + let (p2, h') := encode_expression max pe2 h in + equiv_check p1 p2 + end. + +Definition forall_ptree {A:Type} (f:positive->A->bool) (m:Maps.PTree.t A) : bool := + Maps.PTree.fold (fun (res: bool) (i: positive) (x: A) => res && f i x) m true. + +Ltac boolInv := + match goal with + | [ H: _ && _ = true |- _ ] => + destruct (andb_prop _ _ H); clear H; boolInv + | [ H: proj_sumbool _ = true |- _ ] => + generalize (proj_sumbool_true _ H); clear H; + let EQ := fresh in (intro EQ; try subst; boolInv) + | _ => + idtac + end. + +Remark ptree_forall: + forall (A: Type) (f: positive -> A -> bool) (m: Maps.PTree.t A), + Maps.PTree.fold (fun (res: bool) (i: positive) (x: A) => res && f i x) m true = true -> + forall i x, Maps.PTree.get i m = Some x -> f i x = true. +Proof. + intros. + set (f' := fun (res: bool) (i: positive) (x: A) => res && f i x). + set (P := fun (m: Maps.PTree.t A) (res: bool) => + res = true -> Maps.PTree.get i m = Some x -> f i x = true). + assert (P m true). + rewrite <- H. fold f'. apply Maps.PTree_Properties.fold_rec. + unfold P; intros. rewrite <- H1 in H4. auto. + red; intros. now rewrite Maps.PTree.gempty in H2. + unfold P; intros. unfold f' in H4. boolInv. + rewrite Maps.PTree.gsspec in H5. destruct (peq i k). + subst. inv H5. auto. + apply H3; auto. + red in H1. auto. +Qed. + +Lemma forall_ptree_true: + forall (A: Type) (f: positive -> A -> bool) (m: Maps.PTree.t A), + forall_ptree f m = true -> + forall i x, Maps.PTree.get i m = Some x -> f i x = true. +Proof. + apply ptree_forall. +Qed. + +Definition tree_equiv_check_el (np2: PTree.t pred_op) (n: positive) (p: pred_op): bool := + match np2 ! n with + | Some p' => equiv_check p p' + | None => equiv_check p ⟂ + end. + +Definition tree_equiv_check_None_el (np2: PTree.t pred_op) (n: positive) (p: pred_op): bool := + match np2 ! n with + | Some p' => true + | None => equiv_check p ⟂ + end. + +Variant sem_pred_tree {A B: Type} (sem: ctx -> expression -> B -> Prop): + @ctx A -> PTree.t expression -> PTree.t pred_op -> B -> Prop := +| sem_pred_tree_intro : + forall ctx expr e pr v et pt, + eval_predf (ctx_ps ctx) pr = true -> + sem ctx expr v -> + pt ! e = Some pr -> + et ! e = Some expr -> + sem_pred_tree sem ctx et pt v. + +Variant predicated_mutexcl {A: Type} : predicated A -> Prop := +| predicated_mutexcl_intros : forall pe, + (forall x y, NE.In x pe -> NE.In y pe -> x <> y -> fst x ⇒ ¬ fst y) -> + predicated_mutexcl pe. + +Lemma hash_value_in : + forall max e et h h0, + hash_value max e et = (h, h0) -> + h0 ! h = Some e. +Proof. + intros. unfold hash_value in *. destruct_match; + match goal with + | H: (_, _) = (_, _) |- _ => inv H + end. + - now apply find_tree_Some in Heqo. + - apply PTree.gss. +Qed. + +Lemma norm_expr_constant : + forall x m h t h' e p, + norm_expression m x h = (t, h') -> + h ! e = Some p -> + h' ! e = Some p. +Proof. Admitted. + +Lemma predicated_cons : + forall A (a:pred_op * A) x, + predicated_mutexcl (a ::| x) -> + predicated_mutexcl x. +Proof. + intros. + inv H. constructor; intros. + apply H0; auto; constructor; tauto. +Qed. + +Lemma norm_expr_mutexcl : + forall m pe h t h' e e' p p', + norm_expression m pe h = (t, h') -> + predicated_mutexcl pe -> + t ! e = Some p -> + t ! e' = Some p' -> + e <> e' -> + p ⇒ ¬ p'. +Proof. Abort. + +Lemma norm_expression_sem_pred : + forall A B sem ctx pe v, + sem_pred_expr sem ctx pe v -> + forall pt et et' max, + predicated_mutexcl pe -> + max_pred_expr pe <= max -> + norm_expression max pe et = (pt, et') -> + @sem_pred_tree A B sem ctx et' pt v. +Proof. + induction 1; crush; repeat (destruct_match; []); try destruct_match; + match goal with + | H: (_, _) = (_, _) |- _ => inv H + end. + { econstructor. 3: { apply PTree.gss. } + 2: { eassumption. } + { unfold eval_predf in *. simplify. rewrite H. auto with bool. } + { apply hash_value_in in Heqp. eapply norm_expr_constant in Heqp0; eauto. } + } + { econstructor; eauto. apply PTree.gss. + apply hash_value_in in Heqp. + eapply norm_expr_constant in Heqp0; eauto. + } + { assert (sem_pred_tree sem0 ctx0 et' t v). + eapply IHsem_pred_expr. + eapply predicated_cons; eauto. + instantiate (1 := max). lia. + eassumption. + inv H3. + destruct (Pos.eq_dec e0 h); subst. rewrite H6 in Heqo. simplify. + econstructor; try apply PTree.gss; eauto. + unfold eval_predf in *. simplify. auto with bool. + econstructor; eauto. now rewrite PTree.gso. + } + { assert (X: sem_pred_tree sem0 ctx0 et' t v). + eapply IHsem_pred_expr. + eapply predicated_cons; eauto. + instantiate (1 := max). lia. + eassumption. + inv X. + destruct (Pos.eq_dec e0 h); crush. + econstructor; eauto. now rewrite PTree.gso. + } + { econstructor; eauto. apply PTree.gss. + eapply hash_value_in; eassumption. + } +Qed. + +Lemma norm_expression_sem_pred2 : + forall A B sem ctx v pt et et', + @sem_pred_tree A B sem ctx et' pt v -> + forall pe, + predicated_mutexcl pe -> + norm_expression (max_pred_expr pe) pe et = (pt, et') -> + sem_pred_expr sem ctx pe v. +Proof. Admitted. + +Definition beq_pred_expr (pe1 pe2: pred_expr) : bool := + let max := Pos.max (max_pred_expr pe1) (max_pred_expr pe2) in + let (np1, h) := norm_expression max pe1 (PTree.empty _) in + let (np2, h') := norm_expression max pe2 h in + forall_ptree (tree_equiv_check_el np2) np1 + && forall_ptree (tree_equiv_check_None_el np1) np2. + +Definition check := Rtree.beq beq_pred_expr. + +Compute (check (empty # (Reg 2) <- + ((((Pand (Plit (true, 4)) (¬ (Plit (true, 4))))), (Ebase (Reg 9))) ::| + (NE.singleton (((Plit (true, 2))), (Ebase (Reg 3)))))) + (empty # (Reg 2) <- (NE.singleton (((Por (Plit (true, 2)) (Pand (Plit (true, 3)) (¬ (Plit (true, 3)))))), + (Ebase (Reg 3)))))). + +Lemma inj_asgn_eg : forall a b, (a =? b)%nat = (a =? a)%nat -> a = b. +Proof. + intros. destruct (Nat.eq_dec a b); subst. + auto. apply Nat.eqb_neq in n. + rewrite n in H. rewrite Nat.eqb_refl in H. discriminate. +Qed. + +Lemma inj_asgn : + forall a b, (forall (f: nat -> bool), f a = f b) -> a = b. +Proof. intros. apply inj_asgn_eg. eauto. Qed. + +Lemma inj_asgn_false: + forall n1 n2 , ~ (forall c: nat -> bool, c n1 = negb (c n2)). +Proof. + unfold not; intros. specialize (H (fun x => true)). + simplify. discriminate. +Qed. + +Lemma negb_inj: + forall a b, + negb a = negb b -> a = b. +Proof. destruct a, b; crush. Qed. + +Lemma sat_predicate_Plit_inj : + forall p1 p2, + Plit p1 == Plit p2 -> p1 = p2. +Proof. + simplify. destruct p1, p2. + destruct b, b0. assert (p = p0). + { apply Pos2Nat.inj. eapply inj_asgn. eauto. } solve [subst; auto]. + exfalso; eapply inj_asgn_false; eauto. + exfalso; eapply inj_asgn_false; eauto. + assert (p = p0). apply Pos2Nat.inj. eapply inj_asgn. intros. specialize (H f). + apply negb_inj in H. auto. rewrite H0; auto. +Qed. + +Definition ind_preds t := + forall e1 e2 p1 p2 c, + e1 <> e2 -> + t ! e1 = Some p1 -> + t ! e2 = Some p2 -> + sat_predicate p1 c = true -> + sat_predicate p2 c = false. + +Definition ind_preds_l t := + forall (e1: predicate) e2 p1 p2 c, + e1 <> e2 -> + In (e1, p1) t -> + In (e2, p2) t -> + sat_predicate p1 c = true -> + sat_predicate p2 c = false. + +(*Lemma pred_equivalence_Some' : + forall ta tb e pe pe', + list_norepet (map fst ta) -> + list_norepet (map fst tb) -> + In (e, pe) ta -> + In (e, pe') tb -> + fold_right (fun p a => mk_pred_stmnt' (fst p) (snd p) ∧ a) T ta == + fold_right (fun p a => mk_pred_stmnt' (fst p) (snd p) ∧ a) T tb -> + pe == pe'. +Proof. + induction ta as [|hd tl Hta]; try solve [crush]. + - intros * NRP1 NRP2 IN1 IN2 FOLD. inv NRP1. inv IN1. + simpl in FOLD. + +Lemma pred_equivalence_Some : + forall (ta tb: PTree.t pred_op) e pe pe', + ta ! e = Some pe -> + tb ! e = Some pe' -> + mk_pred_stmnt ta == mk_pred_stmnt tb -> + pe == pe'. +Proof. + intros * SMEA SMEB EQ. unfold mk_pred_stmnt in *. + repeat rewrite PTree.fold_spec in EQ. + +Lemma pred_equivalence_None : + forall (ta tb: PTree.t pred_op) e pe, + (mk_pred_stmnt ta) == (mk_pred_stmnt tb) -> + ta ! e = Some pe -> + tb ! e = None -> + equiv pe ⟂. +Abort. + +Lemma pred_equivalence : + forall (ta tb: PTree.t pred_op) e pe, + equiv (mk_pred_stmnt ta) (mk_pred_stmnt tb) -> + ta ! e = Some pe -> + equiv pe ⟂ \/ (exists pe', tb ! e = Some pe' /\ equiv pe pe'). +Proof. + intros * EQ SME. destruct (tb ! e) eqn:HTB. + { right. econstructor. split; eauto. eapply pred_equivalence_Some; eauto. } + { left. eapply pred_equivalence_None; eauto. } +Qed.*) + +Section CORRECT. + + Definition fd := @fundef RTLBlock.bb. + Definition tfd := @fundef RTLPar.bb. + + Context (ictx: @ctx fd) (octx: @ctx tfd) (HSIM: similar ictx octx). + + Lemma sem_value_mem_det: + forall e v v' m m', + (sem_value ictx e v -> sem_value octx e v' -> v = v') + /\ (sem_mem ictx e m -> sem_mem octx e m' -> m = m'). + Proof using HSIM. + induction e using expression_ind2 + with (P0 := fun p => forall v v', + sem_val_list ictx p v -> sem_val_list octx p v' -> v = v'); + inv HSIM; match goal with H: context [match_states] |- _ => inv H end; repeat progress simplify; + try solve [match goal with + | H: sem_value _ _ _, H2: sem_value _ _ _ |- _ => inv H; inv H2; auto + | H: sem_mem _ _ _, H2: sem_mem _ _ _ |- _ => inv H; inv H2; auto + | H: sem_val_list _ _ _, H2: sem_val_list _ _ _ |- _ => inv H; inv H2; auto + end]. + - repeat match goal with + | H: sem_value _ _ _ |- _ => inv H + | H: sem_val_list {| ctx_ge := ge; |} ?e ?l1, + H2: sem_val_list {| ctx_ge := tge |} ?e ?l2, + IH: forall _ _, sem_val_list _ _ _ -> sem_val_list _ _ _ -> _ = _ |- _ => + assert (X: l1 = l2) by (apply IH; auto) + | H: ge_preserved _ _ |- _ => inv H + | |- context [ctx_rs] => unfold ctx_rs; cbn + | H: context [ctx_mem] |- _ => unfold ctx_mem in H; cbn + end; crush. + - repeat match goal with H: sem_value _ _ _ |- _ => inv H end; simplify; + assert (lv0 = lv) by (apply IHe; eauto); subst; + match goal with H: ge_preserved _ _ |- _ => inv H end; + match goal with H: context [Op.eval_addressing _ _ _ _ = Op.eval_addressing _ _ _ _] |- _ + => rewrite H in * end; + assert (a0 = a1) by crush; + assert (m'2 = m'1) by (apply IHe0; eauto); crush. + - inv H0; inv H3. simplify. + assert (lv = lv0) by ( apply IHe2; eauto). subst. + assert (a1 = a0). { inv H. rewrite H3 in *. crush. } + assert (v0 = v1). { apply IHe1; auto. } + assert (m'1 = m'2). { apply IHe3; auto. } crush. + - inv H0. inv H3. f_equal. apply IHe; auto. + apply IHe0; auto. + Qed. + + Lemma sem_value_mem_corr: + forall e v m, + (sem_value ictx e v -> sem_value octx e v) + /\ (sem_mem ictx e m -> sem_mem octx e m). + Proof using HSIM. + induction e using expression_ind2 + with (P0 := fun p => forall v, + sem_val_list ictx p v -> sem_val_list octx p v); + inv HSIM; match goal with H: context [match_states] |- _ => inv H end; repeat progress simplify. + - inv H0. unfold ctx_rs, ctx_ps, ctx_mem in *; cbn. rewrite H1. constructor. + - inv H0. unfold ctx_rs, ctx_ps, ctx_mem in *; cbn. constructor. + - inv H0. apply IHe in H6. econstructor; try eassumption. + unfold ctx_rs, ctx_ps, ctx_mem in *; cbn in *. inv H. crush. + - inv H0. + - inv H0. eapply IHe in H10. eapply IHe0 in H8; auto. + econstructor; try eassumption. + unfold ctx_rs, ctx_ps, ctx_mem in *; cbn in *. inv H; crush. + - inv H0. + - inv H0. + - inv H0. eapply IHe1 in H11; auto. eapply IHe2 in H12; auto. eapply IHe3 in H9; auto. + econstructor; try eassumption. + unfold ctx_rs, ctx_ps, ctx_mem in *; cbn in *. inv H; crush. + - inv H0. + - inv H0. + - inv H0. econstructor. + - inv H0. eapply IHe in H6; auto. eapply IHe0 in H8. + econstructor; eassumption. + Qed. + + Lemma sem_value_det: + forall e v v', + sem_value ictx e v -> sem_value octx e v' -> v = v'. + Proof using HSIM. + intros. eapply sem_value_mem_det; eauto; apply Mem.empty. + Qed. + + Lemma sem_value_corr: + forall e v, + sem_value ictx e v -> sem_value octx e v. + Proof using HSIM. + intros. eapply sem_value_mem_corr; eauto; apply Mem.empty. + Qed. + + Lemma sem_mem_det: + forall e v v', + sem_mem ictx e v -> sem_mem octx e v' -> v = v'. + Proof using HSIM. + intros. eapply sem_value_mem_det; eauto; apply (Vint (Int.repr 0%Z)). + Qed. + + Lemma sem_mem_corr: + forall e v, + sem_mem ictx e v -> sem_mem octx e v. + Proof using HSIM. + intros. eapply sem_value_mem_corr; eauto; apply (Vint (Int.repr 0%Z)). + Qed. + + Lemma sem_val_list_det: + forall e l l', + sem_val_list ictx e l -> sem_val_list octx e l' -> l = l'. + Proof using HSIM. + induction e; simplify. + - inv H; inv H0; auto. + - inv H; inv H0. f_equal. eapply sem_value_det; eauto; try apply Mem.empty. + apply IHe; eauto. + Qed. + + Lemma sem_val_list_corr: + forall e l, + sem_val_list ictx e l -> sem_val_list octx e l. + Proof using HSIM. + induction e; simplify. + - inv H; constructor. + - inv H. apply sem_value_corr in H3; auto; try apply Mem.empty; + apply IHe in H5; constructor; assumption. + Qed. + + Lemma sem_pred_det: + forall e v v', + sem_pred ictx e v -> sem_pred octx e v' -> v = v'. + Proof using HSIM. + try solve [inversion 1]; pose proof sem_value_det; pose proof sem_val_list_det; inv HSIM; + match goal with H: match_states _ _ |- _ => inv H end; simplify. + inv H2; inv H5; auto. assert (lv = lv0) by (eapply H0; eauto). subst. unfold ctx_mem in *. + crush. + Qed. + + Lemma sem_pred_corr: + forall e v, + sem_pred ictx e v -> sem_pred octx e v. + Proof using HSIM. + try solve [inversion 1]; pose proof sem_value_corr; pose proof sem_val_list_corr; inv HSIM; + match goal with H: match_states _ _ |- _ => inv H end; simplify. + inv H2; auto. apply H0 in H5. econstructor; eauto. + unfold ctx_ps; cbn. rewrite H4. constructor. + Qed. + + #[local] Opaque PTree.set. + + Lemma exists_norm_expr : + forall x pe expr m t h h', + NE.In (pe, expr) x -> + norm_expression m x h = (t, h') -> + exists e pe', t ! e = Some pe' /\ pe ⇒ pe' /\ h' ! e = Some expr. + Proof. Admitted. + +(* Lemma exists_norm_expr3 : + forall e x pe expr m t h h', + t ! e = None -> + norm_expression m x h = (t, h') -> + ~ NE.In (pe, expr) x. + Proof. + Abort.*) + + Lemma norm_expr_implies : + forall x m h t h' e expr p, + norm_expression m x h = (t, h') -> + h' ! e = Some expr -> + t ! e = Some p -> + exists p', NE.In (p', expr) x /\ p' ⇒ p. + Proof. Admitted. + + Lemma norm_expr_In : + forall A B sem ctx x pe expr v, + @sem_pred_expr A B sem ctx x v -> + NE.In (pe, expr) x -> + eval_predf (ctx_ps ctx) pe = true -> + sem ctx expr v. + Proof. Admitted. + + Lemma norm_expr_forall_impl : + forall m x h t h' e1 e2 p1 p2, + predicated_mutexcl x -> + norm_expression m x h = (t, h') -> + t ! e1 = Some p1 -> t ! e2 = Some p2 -> e1 <> e2 -> + p1 ⇒ ¬ p2. + Admitted. + + Lemma norm_expr_replace : + forall A B sem ctx x pe expr v, + @sem_pred_expr A B sem ctx x v -> + eval_predf (ctx_ps ctx) pe = false -> + @sem_pred_expr A B sem ctx (NE.replace pred_expr_item_eq (pe, expr) (⟂, expr) x) v. + Proof using. + induction x; simplify; destruct_match; auto; destruct a; + unfold pred_expr_item_eq in Heqb; simplify; + try (destruct (equiv_dec pe p) eqn:?; [|discriminate]; []). + - rewrite e0 in H0; inv H; crush. + - apply beq_expression_correct in H2; subst; + pose proof H0; rewrite e0 in H2; + apply sem_pred_expr_cons_false; auto; inv H; crush. + - inv H; constructor; auto; now apply sem_pred_expr_cons_false. + Qed. + + Section SEM_PRED. + + Context (B: Type). + Context (isem: @ctx fd -> expression -> B -> Prop). + Context (osem: @ctx tfd -> expression -> B -> Prop). + Context (SEMSIM: forall e v v', isem ictx e v -> osem octx e v' -> v = v'). + + Ltac simplify' l := intros; unfold_constants; cbn -[l] in *; + repeat (nicify_hypotheses; nicify_goals; kill_bools; substpp); + cbn -[l] in *. + + Lemma check_correct_sem_value: + forall x x' v v' t t' h h', + beq_pred_expr x x' = true -> + predicated_mutexcl x -> predicated_mutexcl x' -> + norm_expression (Pos.max (max_pred_expr x) (max_pred_expr x')) x (PTree.empty _) = (t, h) -> + norm_expression (Pos.max (max_pred_expr x) (max_pred_expr x')) x' h = (t', h') -> + sem_pred_tree isem ictx h t v -> + sem_pred_tree osem octx h' t' v' -> + v = v'. + Proof using HSIM SEMSIM. + intros. inv H4. inv H5. + destruct (Pos.eq_dec e e0); subst. + { eapply norm_expr_constant in H3; [|eassumption]. + assert (expr = expr0) by (setoid_rewrite H3 in H12; crush); subst. + eapply SEMSIM; eauto. } + { destruct (t ! e0) eqn:?. + { assert (p == pr0). + { unfold beq_pred_expr in H. repeat (destruct_match; []). inv H2. + rewrite Heqp1 in H3. inv H3. + simplify. + eapply forall_ptree_true in H2. 2: { eapply Heqo. } + unfold tree_equiv_check_el in H2. rewrite H11 in H2. + now apply equiv_check_correct in H2. } + pose proof H0. eapply norm_expr_forall_impl in H0; [| | | |eassumption]; try eassumption. + unfold "⇒" in H0. unfold eval_predf in *. apply H0 in H6. + rewrite negate_correct in H6. apply negb_true_iff in H6. + inv HSIM. match goal with H: match_states _ _ |- _ => inv H end. + unfold ctx_ps, ctx_mem, ctx_rs in *. simplify. + pose proof eval_predf_pr_equiv pr0 ps ps' H17. unfold eval_predf in *. + rewrite H5 in H6. crush. + } + { unfold beq_pred_expr in H. repeat (destruct_match; []). inv H2. + rewrite Heqp0 in H3. inv H3. simplify. + eapply forall_ptree_true in H3. 2: { eapply H11. } + unfold tree_equiv_check_None_el in H3. + rewrite Heqo in H3. apply equiv_check_correct in H3. rewrite H3 in H4. + unfold eval_predf in H4. crush. } } + Qed. + + Lemma check_correct_sem_value2: + forall x x' v v', + beq_pred_expr x x' = true -> + predicated_mutexcl x -> + predicated_mutexcl x' -> + sem_pred_expr isem ictx x v -> + sem_pred_expr osem octx x' v' -> + v = v'. + Proof. + intros. pose proof H. + unfold beq_pred_expr in H. intros. repeat (destruct_match; try discriminate; []). + eapply check_correct_sem_value; try eassumption. + eapply norm_expression_sem_pred; eauto. lia. + eapply norm_expression_sem_pred; eauto. lia. + Qed. + + Lemma check_correct_sem_value3: + forall x x' v v', + beq_pred_expr x x' = true -> + sem_pred_expr isem ictx x v -> + sem_pred_expr osem octx x' v' -> + v = v'. + Proof. + induction x. + - intros * BEQ SEM1 SEM2. + unfold beq_pred_expr in *. intros. repeat (destruct_match; try discriminate; []); subst. + rename Heqp into HNORM1. + rename Heqp0 into HNORM2. + inv SEM1. rename H0 into HEVAL. rename H2 into ISEM. + pose HNORM1 as X. + eapply exists_norm_expr in X; [|constructor]. + simplify' norm_expression. + rename H0 into HT1. + rename H1 into HH1. + rename H into HFORALL1. + rename H2 into HFORALL2. + destruct (t0 ! x) eqn:DSTR. +(* { eapply forall_ptree_true in HT1; eauto. unfold tree_equiv_check_el in *. rewrite DSTR in HT1. + apply equiv_check_dec in HT1. + eapply exists_norm_expr2 in DSTR; try solve [eapply norm_expr_constant; eassumption | eassumption]. + eapply norm_expr_In in DSTR; try eassumption. eauto. + inv HSIM; simplify. now setoid_rewrite <- HT1. + } + { + eapply forall_ptree_true in HT1; [|eassumption]. + unfold tree_equiv_check_el in *. rewrite DSTR in HT1. apply equiv_check_dec in HT1. + now setoid_rewrite HT1 in HEVAL. + } + - intros. unfold beq_pred_expr in H. intros. repeat (destruct_match; try discriminate; []); subst. + destruct a. + inv H0. + { pose Heqp as X. eapply exists_norm_expr in X; [|constructor; tauto]. simplify' norm_expression. + eapply forall_ptree_true in H0; [|eassumption]. + destruct (t0 ! x0) eqn:DSTR. + { + unfold tree_equiv_check_el in H0. rewrite DSTR in H0. apply equiv_check_dec in H0. + eapply exists_norm_expr2 in DSTR; try solve [eapply norm_expr_constant; eassumption | eassumption]. + eapply norm_expr_In in DSTR; try eassumption; eauto. + rewrite <- H0. inv HSIM; eauto. + } + { + unfold tree_equiv_check_el in *. rewrite DSTR in H0. apply equiv_check_dec in H0. + now rewrite H0 in H7. + } + } + { (* This is the inductive argument, which says that if the element is in the list, then + taking it out will result in two equivalent lists, otherwise just taking the current element + results in equivalent lists. *) + simplify' norm_expression. eapply exists_norm_expr in Heqp; [|constructor]; eauto. + simplify' norm_expression. + eapply forall_ptree_true in H0; [|eassumption]. + unfold tree_equiv_check_el in H0. + destruct (t0 ! x0) eqn:DSTR. + { + apply equiv_check_dec in H0. + eapply exists_norm_expr2 in DSTR; try solve [eapply norm_expr_constant; eassumption | eassumption]. + } + } + Admitted.*) Abort. + + End SEM_PRED. + + Section SEM_PRED_CORR. + + Context (B: Type). + Context (isem: @ctx fd -> expression -> B -> Prop). + Context (osem: @ctx tfd -> expression -> B -> Prop). + Context (SEMCORR: forall e v, isem ictx e v -> osem octx e v). + + Lemma sem_pred_tree_corr: + forall x x' v t t' h h', + beq_pred_expr x x' = true -> + predicated_mutexcl x -> predicated_mutexcl x' -> + norm_expression (Pos.max (max_pred_expr x) (max_pred_expr x')) x (PTree.empty _) = (t, h) -> + norm_expression (Pos.max (max_pred_expr x) (max_pred_expr x')) x' h = (t', h') -> + sem_pred_tree isem ictx h t v -> + sem_pred_tree osem octx h' t' v. + Proof using SEMCORR. Admitted. + + End SEM_PRED_CORR. + + Lemma check_correct: forall (fa fb : forest) i i', + check fa fb = true -> + sem ictx fa i -> + sem octx fb i' -> + match_states i i'. + Proof using HSIM. + intros. + unfold check, get_forest in *; intros; + pose proof beq_expression_correct. + pose proof (Rtree.beq_sound beq_pred_expr fa fb H). + inv H0; inv H1. + constructor; simplify. + { admit. } + { inv H0; inv H4. + repeat match goal with + | H: forall _ : reg, _ |- _ => specialize (H x) + | H: forall _ : Rtree.elt, _ |- _ => specialize (H (Reg x)) + end. + repeat (destruct_match; try contradiction). + unfold "#" in *. rewrite Heqo in H0. + rewrite Heqo0 in H1. admit. + unfold "#" in H1. rewrite Heqo0 in H1. + unfold "#" in H0. rewrite Heqo in H0. admit. + } +Admitted. + + Lemma check_correct2: + forall (fa fb : forest) i, + check fa fb = true -> + sem ictx fa i -> + exists i', sem octx fb i' /\ match_states i i'. + Proof. Admitted. + +End CORRECT. + +Lemma get_empty: + forall r, empty#r = NE.singleton (T, Ebase r). +Proof. + intros; unfold get_forest; + destruct_match; auto; [ ]; + match goal with + [ H : context[Rtree.get _ empty] |- _ ] => rewrite Rtree.gempty in H + end; discriminate. +Qed. + +Fixpoint beq2 {A B : Type} (beqA : A -> B -> bool) (m1 : PTree.t A) (m2 : PTree.t B) {struct m1} : bool := + match m1, m2 with + | PTree.Leaf, _ => PTree.bempty m2 + | _, PTree.Leaf => PTree.bempty m1 + | PTree.Node l1 o1 r1, PTree.Node l2 o2 r2 => + match o1, o2 with + | None, None => true + | Some y1, Some y2 => beqA y1 y2 + | _, _ => false + end + && beq2 beqA l1 l2 && beq2 beqA r1 r2 + end. + +Lemma beq2_correct: + forall A B beqA m1 m2, + @beq2 A B beqA m1 m2 = true <-> + (forall (x: PTree.elt), + match PTree.get x m1, PTree.get x m2 with + | None, None => True + | Some y1, Some y2 => beqA y1 y2 = true + | _, _ => False + end). +Proof. + induction m1; intros. + - simpl. rewrite PTree.bempty_correct. split; intros. + rewrite PTree.gleaf. rewrite H. auto. + generalize (H x). rewrite PTree.gleaf. destruct (PTree.get x m2); tauto. + - destruct m2. + + unfold beq2. rewrite PTree.bempty_correct. split; intros. + rewrite H. rewrite PTree.gleaf. auto. + generalize (H x). rewrite PTree.gleaf. + destruct (PTree.get x (PTree.Node m1_1 o m1_2)); tauto. + + simpl. split; intros. + * destruct (andb_prop _ _ H). destruct (andb_prop _ _ H0). + rewrite IHm1_1 in H3. rewrite IHm1_2 in H1. + destruct x; simpl. apply H1. apply H3. + destruct o; destruct o0; auto || congruence. + * apply andb_true_intro. split. apply andb_true_intro. split. + generalize (H xH); simpl. destruct o; destruct o0; tauto. + apply IHm1_1. intros; apply (H (xO x)). + apply IHm1_2. intros; apply (H (xI x)). +Qed. + +Lemma map1: + forall w dst dst', + dst <> dst' -> + (empty # dst <- w) # dst' = NE.singleton (T, Ebase dst'). +Proof. intros; unfold get_forest; rewrite Rtree.gso; auto; apply get_empty. Qed. + +Lemma genmap1: + forall (f : forest) w dst dst', + dst <> dst' -> + (f # dst <- w) # dst' = f # dst'. +Proof. intros; unfold get_forest; rewrite Rtree.gso; auto. Qed. + +Lemma map2: + forall (v : pred_expr) x rs, + (rs # x <- v) # x = v. +Proof. intros; unfold get_forest; rewrite Rtree.gss; trivial. Qed. + +Lemma tri1: + forall x y, + Reg x <> Reg y -> x <> y. +Proof. crush. Qed. diff --git a/src/hls/Array.v b/src/hls/Array.v index dec1335..0f5ae02 100644 --- a/src/hls/Array.v +++ b/src/hls/Array.v @@ -51,7 +51,7 @@ Lemma list_set_spec1 {A : Type} : Proof. induction l; intros; destruct i; crush; firstorder. intuition. Qed. -Hint Resolve list_set_spec1 : array. +#[export] Hint Resolve list_set_spec1 : array. Lemma list_set_spec2 {A : Type} : forall l i (x : A) d, @@ -59,7 +59,7 @@ Lemma list_set_spec2 {A : Type} : Proof. induction l; intros; destruct i; crush; firstorder. intuition. Qed. -Hint Resolve list_set_spec2 : array. +#[export] Hint Resolve list_set_spec2 : array. Lemma list_set_spec3 {A : Type} : forall l i1 i2 (x : A), @@ -68,7 +68,7 @@ Lemma list_set_spec3 {A : Type} : Proof. induction l; intros; destruct i1; destruct i2; crush; firstorder. Qed. -Hint Resolve list_set_spec3 : array. +#[export] Hint Resolve list_set_spec3 : array. Lemma array_set_wf {A : Type} : forall l ln i (x : A), @@ -95,7 +95,7 @@ Proof. unfold array_set. crush. eauto with array. Qed. -Hint Resolve array_set_spec1 : array. +#[export] Hint Resolve array_set_spec1 : array. Lemma array_set_spec2 {A : Type} : forall a i (x : A) d, @@ -107,7 +107,7 @@ Proof. unfold array_set. crush. eauto with array. Qed. -Hint Resolve array_set_spec2 : array. +#[export] Hint Resolve array_set_spec2 : array. Lemma array_set_len {A : Type} : forall a i (x : A), diff --git a/src/hls/AssocMap.v b/src/hls/AssocMap.v index 1d1b77f..8dbc6b2 100644 --- a/src/hls/AssocMap.v +++ b/src/hls/AssocMap.v @@ -29,9 +29,8 @@ Module AssocMap := Maps.PTree. Module AssocMapExt. Import AssocMap. - Hint Resolve elements_correct elements_complete - elements_keys_norepet : assocmap. - Hint Resolve gso gss : assocmap. + #[export] Hint Resolve elements_correct elements_complete elements_keys_norepet : assocmap. + #[export] Hint Resolve gso gss : assocmap. Section Operations. @@ -55,7 +54,6 @@ Module AssocMapExt. forall am, merge (empty A) am = am. Proof. auto. Qed. - Hint Resolve merge_base_1 : assocmap. Lemma merge_base_2 : forall am, @@ -65,7 +63,6 @@ Module AssocMapExt. destruct am; trivial. destruct o; trivial. Qed. - Hint Resolve merge_base_2 : assocmap. Lemma merge_add_assoc : forall r am am' v, @@ -74,7 +71,6 @@ Module AssocMapExt. induction r; intros; destruct am; destruct am'; try (destruct o); simpl; try rewrite IHr; try reflexivity. Qed. - Hint Resolve merge_add_assoc : assocmap. Lemma merge_correct_1 : forall am bm k v, @@ -84,7 +80,6 @@ Module AssocMapExt. induction am; intros; destruct k; destruct bm; try (destruct o); simpl; try rewrite gempty in H; try discriminate; try assumption; auto. Qed. - Hint Resolve merge_correct_1 : assocmap. Lemma merge_correct_2 : forall am bm k v, @@ -95,7 +90,16 @@ Module AssocMapExt. induction am; intros; destruct k; destruct bm; try (destruct o); simpl; try rewrite gempty in H; try discriminate; try assumption; auto. Qed. - Hint Resolve merge_correct_2 : assocmap. + + Lemma merge_correct_3 : + forall am bm k, + get k am = None -> + get k bm = None -> + get k (merge am bm) = None. + Proof. + induction am; intros; destruct k; destruct bm; try (destruct o); simpl; + try rewrite gempty in H; try discriminate; try assumption; auto. + Qed. Definition merge_fold (am bm : t A) : t A := fold_right (fun p a => set (fst p) (snd p) a) bm (elements am). @@ -119,7 +123,6 @@ Module AssocMapExt. apply IHl. contradiction. contradiction. simpl. rewrite gso; try assumption. apply IHl. assumption. inversion H0. subst. assumption. Qed. - Hint Resolve add_assoc : assocmap. Lemma not_in_assoc : forall k v l bm, @@ -134,7 +137,6 @@ Module AssocMapExt. simpl in *; apply Decidable.not_or in H; destruct H. contradiction. rewrite AssocMap.gso; auto. Qed. - Hint Resolve not_in_assoc : assocmap. Lemma elements_iff : forall am k, @@ -147,14 +149,22 @@ Module AssocMapExt. exists (snd x). apply elements_complete. assert (x = (fst x, snd x)) by apply surjective_pairing. rewrite H in H0; assumption. Qed. - Hint Resolve elements_iff : assocmap. + + #[local] Hint Resolve merge_base_1 : core. + #[local] Hint Resolve merge_base_2 : core. + #[local] Hint Resolve merge_add_assoc : core. + #[local] Hint Resolve merge_correct_1 : core. + #[local] Hint Resolve merge_correct_2 : core. + #[local] Hint Resolve merge_correct_3 : core. + #[local] Hint Resolve add_assoc : core. + #[local] Hint Resolve not_in_assoc : core. + #[local] Hint Resolve elements_iff : core. Lemma elements_correct' : forall am k, ~ (exists v, get k am = Some v) <-> ~ List.In k (List.map (@fst _ A) (elements am)). - Proof. auto using not_iff_compat with assocmap. Qed. - Hint Resolve elements_correct' : assocmap. + Proof. auto using not_iff_compat. Qed. Lemma elements_correct_none : forall am k, @@ -164,31 +174,46 @@ Module AssocMapExt. intros. apply elements_correct'. unfold not. intros. destruct H0. rewrite H in H0. discriminate. Qed. - Hint Resolve elements_correct_none : assocmap. Lemma merge_fold_add : forall k v am bm, am ! k = Some v -> (merge_fold am bm) ! k = Some v. Proof. unfold merge_fold; auto with assocmap. Qed. - Hint Resolve merge_fold_add : assocmap. + + #[local] Hint Resolve elements_correct' : core. + #[local] Hint Resolve elements_correct_none : core. + #[local] Hint Resolve merge_fold_add : core. Lemma merge_fold_not_in : forall k v am bm, get k am = None -> get k bm = Some v -> get k (merge_fold am bm) = Some v. - Proof. intros. apply not_in_assoc; auto with assocmap. Qed. - Hint Resolve merge_fold_not_in : assocmap. + Proof. intros. apply not_in_assoc; auto. Qed. Lemma merge_fold_base : forall am, merge_fold (empty A) am = am. Proof. auto. Qed. - Hint Resolve merge_fold_base : assocmap. End Operations. + #[export] Hint Resolve merge_base_1 : assocmap. + #[export] Hint Resolve merge_base_2 : assocmap. + #[export] Hint Resolve merge_add_assoc : assocmap. + #[export] Hint Resolve merge_correct_1 : assocmap. + #[export] Hint Resolve merge_correct_2 : assocmap. + #[export] Hint Resolve merge_correct_3 : assocmap. + #[export] Hint Resolve add_assoc : assocmap. + #[export] Hint Resolve not_in_assoc : assocmap. + #[export] Hint Resolve elements_iff : assocmap. + #[export] Hint Resolve elements_correct' : assocmap. + #[export] Hint Resolve merge_fold_not_in : assocmap. + #[export] Hint Resolve merge_fold_base : assocmap. + #[export] Hint Resolve elements_correct_none : assocmap. + #[export] Hint Resolve merge_fold_add : assocmap. + End AssocMapExt. Import AssocMapExt. diff --git a/src/hls/FunctionalUnits.v b/src/hls/FunctionalUnits.v index 392b1ae..9504bb1 100644 --- a/src/hls/FunctionalUnits.v +++ b/src/hls/FunctionalUnits.v @@ -21,23 +21,165 @@ Require Import compcert.lib.Maps. Require Import vericert.common.Vericertlib. -Definition funct_node := positive. +#[local] Open Scope positive. + +Record divider (signed: bool) : Type := + mk_divider { + div_stages: positive; + div_size: positive; + div_numer: reg; + div_denom: reg; + div_quot: reg; + div_rem: reg; + div_ordering: (div_numer < div_denom + /\ div_denom < div_quot + /\ div_quot < div_rem) + }. + +Arguments div_stages [signed]. +Arguments div_size [signed]. +Arguments div_numer [signed]. +Arguments div_denom [signed]. +Arguments div_quot [signed]. +Arguments div_rem [signed]. + +Record ram := mk_ram { + ram_size: nat; + ram_mem: reg; + ram_en: reg; + ram_u_en: reg; + ram_addr: reg; + ram_wr_en: reg; + ram_d_in: reg; + ram_d_out: reg; + ram_ordering: (ram_addr < ram_en + /\ ram_en < ram_d_in + /\ ram_d_in < ram_d_out + /\ ram_d_out < ram_wr_en + /\ ram_wr_en < ram_u_en) +}. Inductive funct_unit: Type := -| SignedDiv (size: positive) (numer denom quot rem: reg): funct_unit -| UnsignedDiv (size: positive) (numer denom quot rem: reg): funct_unit. +| SignedDiv: divider true -> funct_unit +| UnsignedDiv: divider false -> funct_unit +| Ram: ram -> funct_unit. -Record funct_units := mk_avail_funct_units { - avail_sdiv: option funct_node; - avail_udiv: option funct_node; - avail_units: PTree.t funct_unit; - }. +Definition funct_units := PTree.t funct_unit. + +Record arch := mk_arch { + arch_div: list positive; + arch_sdiv: list positive; + arch_ram: list positive; +}. -Definition initial_funct_units := - mk_avail_funct_units None None (PTree.empty funct_unit). +Record resources := mk_resources { + res_funct_units: funct_units; + res_arch: arch; +}. + +Definition index_div {b:bool} r (d: divider b) := + match r with + | 1 => div_numer d + | 2 => div_denom d + | 3 => div_quot d + | _ => div_rem d + end. + +Definition index_ram r (d: ram) := + match r with + | 1 => ram_mem d + | 2 => ram_en d + | 3 => ram_u_en d + | 4 => ram_addr d + | 5 => ram_wr_en d + | 6 => ram_d_in d + | _ => ram_d_out d + end. + +Definition index_res u r res := + match PTree.get u res with + | Some (SignedDiv d) => Some (index_div r d) + | Some (UnsignedDiv d) => Some (index_div r d) + | Some (Ram d) => Some (index_ram r d) + | None => None + end. + +Definition get_ram n res: option (positive * ram) := + match nth_error (arch_ram (res_arch res)) n with + | Some ri => + match PTree.get ri (res_funct_units res) with + | Some (Ram r) => Some (ri, r) + | _ => None + end + | None => None + end. + +Definition get_div n res := + match nth_error (arch_div (res_arch res)) n with + | Some ri => + match PTree.get ri (res_funct_units res) with + | Some (UnsignedDiv d) => Some (ri, d) + | _ => None + end + | None => None + end. + +Definition get_sdiv n res := + match nth_error (arch_sdiv (res_arch res)) n with + | Some ri => + match PTree.get ri (res_funct_units res) with + | Some (SignedDiv d) => Some (ri, d) + | _ => None + end + | None => None + end. + +Definition set_res fu res := + let max := ((fold_left Pos.max ((arch_sdiv (res_arch res)) + ++ (arch_div (res_arch res)) + ++ (arch_ram (res_arch res))) 1) + 1)%positive in + let nt := PTree.set max fu (res_funct_units res) in + match fu with + | UnsignedDiv _ => mk_resources nt (mk_arch (max :: arch_div (res_arch res)) + (arch_sdiv (res_arch res)) + (arch_ram (res_arch res))) + | SignedDiv _ => mk_resources nt (mk_arch (arch_div (res_arch res)) + (max :: arch_sdiv (res_arch res)) + (arch_ram (res_arch res))) + | Ram _ => mk_resources nt (mk_arch (arch_div (res_arch res)) + (arch_sdiv (res_arch res)) + (max :: arch_ram (res_arch res))) + end. + +Definition initial_funct_units: funct_units := PTree.empty _. + +Definition initial_arch := mk_arch nil nil nil. + +Definition initial_resources := + mk_resources initial_funct_units initial_arch. Definition funct_unit_stages (f: funct_unit) : positive := match f with - | SignedDiv s _ _ _ _ => s - | UnsignedDiv s _ _ _ _ => s + | SignedDiv d => div_stages d + | UnsignedDiv d => div_stages d + | _ => 1 end. + +Definition max_reg_ram r := + fold_right Pos.max 1 (ram_mem r::ram_en r::ram_u_en r::ram_addr r + ::ram_wr_en r::ram_d_in r::ram_d_out r::nil). + +Definition max_reg_divider {b: bool} (d: divider b) := + fold_right Pos.max 1 (div_numer d::div_denom d::div_quot d::div_rem d::nil). + +Definition max_reg_fu fu := + match fu with + | SignedDiv d | UnsignedDiv d => max_reg_divider d + | Ram r => max_reg_ram r + end. + +Definition max_reg_funct_units r := + PTree.fold (fun m _ a => Pos.max m (max_reg_fu a)) r 1. + +Definition max_reg_resources r := + max_reg_funct_units r.(res_funct_units). diff --git a/src/hls/HTL.v b/src/hls/HTL.v index d91a340..f4552a5 100644 --- a/src/hls/HTL.v +++ b/src/hls/HTL.v @@ -18,20 +18,23 @@ *) Require Import Coq.FSets.FMapPositive. +Require Import Coq.micromega.Lia. Require compcert.common.Events. Require compcert.common.Globalenvs. Require compcert.common.Smallstep. Require compcert.common.Values. -Require compcert.lib.Integers. +Require Import compcert.lib.Integers. Require Import compcert.lib.Maps. Require Import vericert.common.Vericertlib. Require Import vericert.hls.Array. -Require Import vericert.hls.AssocMap. Require Import vericert.hls.FunctionalUnits. -Require Import vericert.hls.ValueInt. Require vericert.hls.Verilog. +Require Import AssocMap. +Require Import ValueInt. + +Local Open Scope positive. (*| The purpose of the hardware transfer language (HTL) is to create a more @@ -52,7 +55,9 @@ Definition controllogic := PTree.t Verilog.stmnt. Definition map_well_formed {A : Type} (m : PTree.t A) : Prop := forall p0 : positive, In p0 (map fst (Maps.PTree.elements m)) -> - Z.pos p0 <= Integers.Int.max_unsigned. + (Z.pos p0 <= Integers.Int.max_unsigned)%Z. + +Definition module_ordering a b c d e f g := a < b < c /\ c < d < e /\ e < f < g. Record module: Type := mkmodule { @@ -68,10 +73,13 @@ Record module: Type := mod_start : reg; mod_reset : reg; mod_clk : reg; - mod_funct_units: funct_units; mod_scldecls : AssocMap.t (option Verilog.io * Verilog.scl_decl); mod_arrdecls : AssocMap.t (option Verilog.io * Verilog.arr_decl); - mod_wf : (map_well_formed mod_controllogic /\ map_well_formed mod_datapath); + mod_ram : option ram; + mod_wf : map_well_formed mod_controllogic /\ map_well_formed mod_datapath; + mod_ordering_wf : module_ordering mod_st mod_finish mod_return mod_stk mod_start mod_reset mod_clk; + mod_ram_wf : forall r', mod_ram = Some r' -> mod_clk < ram_addr r'; + mod_params_wf : Forall (Pos.gt mod_st) mod_params; }. Definition fundef := AST.fundef module. @@ -115,12 +123,47 @@ Inductive state : Type := (m : module) (args : list value), state. +Inductive exec_ram: + Verilog.reg_associations -> Verilog.arr_associations -> option ram -> + Verilog.reg_associations -> Verilog.arr_associations -> Prop := +| exec_ram_Some_idle: + forall ra ar r, + Int.eq (Verilog.assoc_blocking ra)#(ram_en r, 32) + (Verilog.assoc_blocking ra)#(ram_u_en r, 32) = true -> + exec_ram ra ar (Some r) ra ar +| exec_ram_Some_write: + forall ra ar r d_in addr en wr_en u_en, + Int.eq en u_en = false -> + Int.eq wr_en (ZToValue 0) = false -> + (Verilog.assoc_blocking ra)#(ram_en r, 32) = en -> + (Verilog.assoc_blocking ra)!(ram_u_en r) = Some u_en -> + (Verilog.assoc_blocking ra)!(ram_wr_en r) = Some wr_en -> + (Verilog.assoc_blocking ra)!(ram_d_in r) = Some d_in -> + (Verilog.assoc_blocking ra)!(ram_addr r) = Some addr -> + exec_ram ra ar (Some r) (Verilog.nonblock_reg (ram_en r) ra u_en) + (Verilog.nonblock_arr (ram_mem r) (valueToNat addr) ar d_in) +| exec_ram_Some_read: + forall ra ar r addr v_d_out en u_en, + Int.eq en u_en = false -> + (Verilog.assoc_blocking ra)#(ram_en r, 32) = en -> + (Verilog.assoc_blocking ra)!(ram_u_en r) = Some u_en -> + (Verilog.assoc_blocking ra)!(ram_wr_en r) = Some (ZToValue 0) -> + (Verilog.assoc_blocking ra)!(ram_addr r) = Some addr -> + Verilog.arr_assocmap_lookup (Verilog.assoc_blocking ar) + (ram_mem r) (valueToNat addr) = Some v_d_out -> + exec_ram ra ar (Some r) (Verilog.nonblock_reg (ram_en r) + (Verilog.nonblock_reg (ram_d_out r) ra v_d_out) u_en) ar +| exec_ram_None: + forall r a, + exec_ram r a None r a. + Inductive step : genv -> state -> Events.trace -> state -> Prop := | step_module : forall g m st sf ctrl data asr asa basr1 basa1 nasr1 nasa1 basr2 basa2 nasr2 nasa2 + basr3 basa3 nasr3 nasa3 asr' asa' f pstval, asr!(mod_reset m) = Some (ZToValue 0) -> @@ -141,10 +184,16 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := data (Verilog.mkassociations basr2 nasr2) (Verilog.mkassociations basa2 nasa2) -> - asr' = Verilog.merge_regs nasr2 basr2 -> - asa' = Verilog.merge_arrs nasa2 basa2 -> + exec_ram + (Verilog.mkassociations (Verilog.merge_regs nasr2 basr2) empty_assocmap) + (Verilog.mkassociations (Verilog.merge_arrs nasa2 basa2) (empty_stack m)) + (mod_ram m) + (Verilog.mkassociations basr3 nasr3) + (Verilog.mkassociations basa3 nasa3) -> + asr' = Verilog.merge_regs nasr3 basr3 -> + asa' = Verilog.merge_arrs nasa3 basa3 -> asr'!(m.(mod_st)) = Some (posToValue pstval) -> - Z.pos pstval <= Integers.Int.max_unsigned -> + (Z.pos pstval <= Integers.Int.max_unsigned)%Z -> step g (State sf m st asr asa) Events.E0 (State sf m pstval asr' asa') | step_finish : forall g m st asr asa retval sf, @@ -165,7 +214,7 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := mst = mod_st m -> step g (Returnstate (Stackframe r m pc asr asa :: sf) i) Events.E0 (State sf m pc ((asr # mst <- (posToValue pc)) # r <- i) asa). -Hint Constructors step : htl. +#[export] Hint Constructors step : htl. Inductive initial_state (p: program): state -> Prop := | initial_state_intro: forall b m0 m, @@ -183,3 +232,110 @@ Inductive final_state : state -> Integers.int -> Prop := Definition semantics (m : program) := Smallstep.Semantics step (initial_state m) final_state (Globalenvs.Genv.globalenv m). + +Definition max_pc_function (m: module) := + List.fold_left Pos.max (List.map fst (PTree.elements m.(mod_controllogic))) 1. + +Definition max_list := fold_right Pos.max 1. + +Definition max_stmnt_tree t := + PTree.fold (fun i _ st => Pos.max (Verilog.max_reg_stmnt st) i) t 1. + +Definition max_reg_ram r := + match r with + | None => 1 + | Some ram => Pos.max (ram_mem ram) + (Pos.max (ram_en ram) + (Pos.max (ram_addr ram) + (Pos.max (ram_addr ram) + (Pos.max (ram_wr_en ram) + (Pos.max (ram_d_in ram) + (Pos.max (ram_d_out ram) (ram_u_en ram))))))) + end. + +Definition max_reg_module m := + Pos.max (max_list (mod_params m)) + (Pos.max (max_stmnt_tree (mod_datapath m)) + (Pos.max (max_stmnt_tree (mod_controllogic m)) + (Pos.max (mod_st m) + (Pos.max (mod_stk m) + (Pos.max (mod_finish m) + (Pos.max (mod_return m) + (Pos.max (mod_start m) + (Pos.max (mod_reset m) + (Pos.max (mod_clk m) (max_reg_ram (mod_ram m))))))))))). + +Lemma max_fold_lt : + forall m l n, m <= n -> m <= (fold_left Pos.max l n). +Proof. induction l; crush; apply IHl; lia. Qed. + +Lemma max_fold_lt2 : + forall (l: list (positive * Verilog.stmnt)) v n, + v <= n -> + v <= fold_left (fun a p => Pos.max (Verilog.max_reg_stmnt (snd p)) a) l n. +Proof. induction l; crush; apply IHl; lia. Qed. + +Lemma max_fold_lt3 : + forall (l: list (positive * Verilog.stmnt)) v v', + v <= v' -> + fold_left (fun a0 p => Pos.max (Verilog.max_reg_stmnt (snd p)) a0) l v + <= fold_left (fun a0 p => Pos.max (Verilog.max_reg_stmnt (snd p)) a0) l v'. +Proof. induction l; crush; apply IHl; lia. Qed. + +Lemma max_fold_lt4 : + forall (l: list (positive * Verilog.stmnt)) (a: positive * Verilog.stmnt), + fold_left (fun a0 p => Pos.max (Verilog.max_reg_stmnt (snd p)) a0) l 1 + <= fold_left (fun a0 p => Pos.max (Verilog.max_reg_stmnt (snd p)) a0) l + (Pos.max (Verilog.max_reg_stmnt (snd a)) 1). +Proof. intros; apply max_fold_lt3; lia. Qed. + +Lemma max_reg_stmnt_lt_stmnt_tree': + forall l (i: positive) v, + In (i, v) l -> + list_norepet (map fst l) -> + Verilog.max_reg_stmnt v <= fold_left (fun a p => Pos.max (Verilog.max_reg_stmnt (snd p)) a) l 1. +Proof. + induction l; crush. inv H; inv H0; simplify. apply max_fold_lt2. lia. + transitivity (fold_left (fun (a : positive) (p : positive * Verilog.stmnt) => + Pos.max (Verilog.max_reg_stmnt (snd p)) a) l 1). + eapply IHl; eauto. apply max_fold_lt4. +Qed. + +Lemma max_reg_stmnt_le_stmnt_tree : + forall d i v, + d ! i = Some v -> + Verilog.max_reg_stmnt v <= max_stmnt_tree d. +Proof. + intros. unfold max_stmnt_tree. rewrite PTree.fold_spec. + apply PTree.elements_correct in H. + eapply max_reg_stmnt_lt_stmnt_tree'; eauto. + apply PTree.elements_keys_norepet. +Qed. + +Lemma max_reg_stmnt_lt_stmnt_tree : + forall d i v, + d ! i = Some v -> + Verilog.max_reg_stmnt v < max_stmnt_tree d + 1. +Proof. intros. apply max_reg_stmnt_le_stmnt_tree in H; lia. Qed. + +Lemma max_stmnt_lt_module : + forall m d i, + (mod_controllogic m) ! i = Some d \/ (mod_datapath m) ! i = Some d -> + Verilog.max_reg_stmnt d < max_reg_module m + 1. +Proof. + inversion 1 as [ Hv | Hv ]; unfold max_reg_module; + apply max_reg_stmnt_le_stmnt_tree in Hv; lia. +Qed. + +Lemma max_list_correct l st : st > max_list l -> Forall (Pos.gt st) l. +Proof. induction l; crush; constructor; [|apply IHl]; lia. Qed. + +Definition max_list_dec (l: list reg) (st: reg) : {Forall (Pos.gt st) l} + {True}. + refine ( + match bool_dec (max_list l <? st) true with + | left _ => left _ + | _ => _ + end + ); auto. + apply max_list_correct. apply Pos.ltb_lt in e. lia. +Qed. diff --git a/src/hls/HTLPargen.v b/src/hls/HTLPargen.v index 629f53e..b66a704 100644 --- a/src/hls/HTLPargen.v +++ b/src/hls/HTLPargen.v @@ -1,6 +1,6 @@ (* * Vericert: Verified high-level synthesis. - * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com> + * Copyright (C) 2021 Yann Herklotz <yann@yannherklotz.com> * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -29,16 +29,18 @@ Require Import vericert.common.Vericertlib. Require Import vericert.hls.AssocMap. Require Import vericert.hls.FunctionalUnits. Require Import vericert.hls.HTL. +Require Import vericert.hls.Predicate. Require Import vericert.hls.RTLBlockInstr. -Require Import vericert.hls.RTLPar. +Require Import vericert.hls.RTLParFU. +Require Import vericert.hls.FunctionalUnits. Require Import vericert.hls.ValueInt. Require Import vericert.hls.Verilog. -Hint Resolve AssocMap.gempty : htlh. -Hint Resolve AssocMap.gso : htlh. -Hint Resolve AssocMap.gss : htlh. -Hint Resolve Ple_refl : htlh. -Hint Resolve Ple_succ : htlh. +#[local] Hint Resolve AssocMap.gempty : htlh. +#[local] Hint Resolve AssocMap.gso : htlh. +#[local] Hint Resolve AssocMap.gss : htlh. +#[local] Hint Resolve Ple_refl : htlh. +#[local] Hint Resolve Ple_succ : htlh. Definition assignment : Type := expr -> expr -> stmnt. @@ -50,7 +52,6 @@ Record state: Type := mkstate { st_arrdecls: AssocMap.t (option io * arr_decl); st_datapath: datapath; st_controllogic: controllogic; - st_funct_units: funct_units; }. Definition init_state (st : reg) : state := @@ -60,8 +61,7 @@ Definition init_state (st : reg) : state := (AssocMap.empty (option io * scl_decl)) (AssocMap.empty (option io * arr_decl)) (AssocMap.empty stmnt) - (AssocMap.empty stmnt) - initial_funct_units. + (AssocMap.empty stmnt). Module HTLState <: State. @@ -77,10 +77,10 @@ Module HTLState <: State. s1.(st_controllogic)!n = None \/ s2.(st_controllogic)!n = s1.(st_controllogic)!n) -> st_incr s1 s2. - Hint Constructors st_incr : htlh. + #[local] Hint Constructors st_incr : htlh. Definition st_prop := st_incr. - Hint Unfold st_prop : htlh. + #[local] Hint Unfold st_prop : htlh. Lemma st_refl : forall s, st_prop s s. Proof. auto with htlh. Qed. @@ -131,9 +131,8 @@ Lemma declare_reg_state_incr : (AssocMap.set r (i, VScalar sz) s.(st_scldecls)) s.(st_arrdecls) s.(st_datapath) - s.(st_controllogic) - s.(st_funct_units)). -Proof. auto with htlh. Qed. + s.(st_controllogic)). +Proof. Admitted. Definition declare_reg (i : option io) (r : reg) (sz : nat) : mon unit := fun s => OK tt (mkstate @@ -143,8 +142,7 @@ Definition declare_reg (i : option io) (r : reg) (sz : nat) : mon unit := (AssocMap.set r (i, VScalar sz) s.(st_scldecls)) s.(st_arrdecls) s.(st_datapath) - s.(st_controllogic) - s.(st_funct_units)) + s.(st_controllogic)) (declare_reg_state_incr i s r sz). Lemma add_instr_state_incr : @@ -158,8 +156,7 @@ Lemma add_instr_state_incr : s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n st s.(st_datapath)) - (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic)) - s.(st_funct_units)). + (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic))). Proof. constructor; intros; try (simpl; destruct (peq n n0); subst); @@ -177,8 +174,7 @@ Definition add_instr (n : node) (n' : node) (st : stmnt) : mon unit := s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n st s.(st_datapath)) - (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic)) - s.(st_funct_units)) + (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic))) (add_instr_state_incr s n n' st TRANS) | _ => Error (Errors.msg "HTL.add_instr") end. @@ -194,8 +190,7 @@ Lemma add_instr_skip_state_incr : s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n st s.(st_datapath)) - (AssocMap.set n Vskip s.(st_controllogic)) - s.(st_funct_units)). + (AssocMap.set n Vskip s.(st_controllogic))). Proof. constructor; intros; try (simpl; destruct (peq n n0); subst); @@ -213,8 +208,7 @@ Definition add_instr_skip (n : node) (st : stmnt) : mon unit := s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n st s.(st_datapath)) - (AssocMap.set n Vskip s.(st_controllogic)) - s.(st_funct_units)) + (AssocMap.set n Vskip s.(st_controllogic))) (add_instr_skip_state_incr s n st TRANS) | _ => Error (Errors.msg "HTL.add_instr_skip") end. @@ -230,8 +224,7 @@ Lemma add_node_skip_state_incr : s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n Vskip s.(st_datapath)) - (AssocMap.set n st s.(st_controllogic)) - s.(st_funct_units)). + (AssocMap.set n st s.(st_controllogic))). Proof. constructor; intros; try (simpl; destruct (peq n n0); subst); @@ -249,8 +242,7 @@ Definition add_node_skip (n : node) (st : stmnt) : mon unit := s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n Vskip s.(st_datapath)) - (AssocMap.set n st s.(st_controllogic)) - s.(st_funct_units)) + (AssocMap.set n st s.(st_controllogic))) (add_node_skip_state_incr s n st TRANS) | _ => Error (Errors.msg "HTL.add_node_skip") end. @@ -347,8 +339,7 @@ Lemma create_reg_state_incr: (AssocMap.set s.(st_freshreg) (i, VScalar sz) s.(st_scldecls)) s.(st_arrdecls) (st_datapath s) - (st_controllogic s) - s.(st_funct_units)). + (st_controllogic s)). Proof. constructor; simpl; auto with htlh. Qed. Definition create_reg (i : option io) (sz : nat) : mon reg := @@ -360,8 +351,7 @@ Definition create_reg (i : option io) (sz : nat) : mon reg := (AssocMap.set s.(st_freshreg) (i, VScalar sz) s.(st_scldecls)) (st_arrdecls s) (st_datapath s) - (st_controllogic s) - s.(st_funct_units)) + (st_controllogic s)) (create_reg_state_incr s sz i). Definition translate_eff_addressing (a: Op.addressing) (args: list reg) @@ -445,8 +435,7 @@ Lemma add_branch_instr_state_incr: s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n Vskip (st_datapath s)) - (AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s)) - s.(st_funct_units)). + (AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s))). Proof. intros. apply state_incr_intro; simpl; try (intros; destruct (peq n0 n); subst); @@ -464,8 +453,7 @@ Definition add_branch_instr (e: expr) (n n1 n2: node) : mon unit := s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n Vskip (st_datapath s)) - (AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s)) - s.(st_funct_units)) + (AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s))) (add_branch_instr_state_incr s e n n1 n2 NTRANS) | _ => Error (Errors.msg "Htlgen: add_branch_instr") end. @@ -516,8 +504,7 @@ Lemma create_arr_state_incr: s.(st_scldecls) (AssocMap.set s.(st_freshreg) (i, VArray sz ln) s.(st_arrdecls)) (st_datapath s) - (st_controllogic s) - s.(st_funct_units)). + (st_controllogic s)). Proof. constructor; simpl; auto with htlh. Qed. Definition create_arr (i : option io) (sz : nat) (ln : nat) : mon (reg * nat) := @@ -529,8 +516,7 @@ Definition create_arr (i : option io) (sz : nat) (ln : nat) : mon (reg * nat) := s.(st_scldecls) (AssocMap.set s.(st_freshreg) (i, VArray sz ln) s.(st_arrdecls)) (st_datapath s) - (st_controllogic s) - s.(st_funct_units)) + (st_controllogic s)) (create_arr_state_incr s sz ln i). Definition max_pc_map (m : Maps.PTree.t stmnt) := @@ -593,8 +579,7 @@ Lemma add_data_instr_state_incr : s.(st_arrdecls) (AssocMap.set n (Vseq (AssocMapExt.get_default _ Vskip n s.(st_datapath)) st) s.(st_datapath)) - s.(st_controllogic) - s.(st_funct_units)). + s.(st_controllogic)). Proof. constructor; intros; try (simpl; destruct (peq n n0); subst); @@ -610,8 +595,7 @@ Definition add_data_instr (n : node) (st : stmnt) : mon unit := s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n (Vseq (AssocMapExt.get_default _ Vskip n s.(st_datapath)) st) s.(st_datapath)) - s.(st_controllogic) - s.(st_funct_units)) + s.(st_controllogic)) (add_data_instr_state_incr s n st). Lemma add_control_instr_state_incr : @@ -625,8 +609,7 @@ Lemma add_control_instr_state_incr : s.(st_scldecls) s.(st_arrdecls) s.(st_datapath) - (AssocMap.set n st s.(st_controllogic)) - s.(st_funct_units)). + (AssocMap.set n st s.(st_controllogic))). Proof. constructor; intros; try (simpl; destruct (peq n n0); subst); @@ -644,19 +627,45 @@ Definition add_control_instr (n : node) (st : stmnt) : mon unit := s.(st_scldecls) s.(st_arrdecls) s.(st_datapath) - (AssocMap.set n st s.(st_controllogic)) - s.(st_funct_units)) + (AssocMap.set n st s.(st_controllogic))) (add_control_instr_state_incr s n st CTRL) | _ => Error (Errors.msg "HTLPargen.add_control_instr: control logic is not empty") end. +Definition add_control_instr_force_state_incr : + forall s n st, + st_incr s + (mkstate + s.(st_st) + s.(st_freshreg) + (st_freshstate s) + s.(st_scldecls) + s.(st_arrdecls) + s.(st_datapath) + (AssocMap.set n st s.(st_controllogic))). +Admitted. + +Definition add_control_instr_force (n : node) (st : stmnt) : mon unit := + fun s => + OK tt (mkstate + s.(st_st) + s.(st_freshreg) + (st_freshstate s) + s.(st_scldecls) + s.(st_arrdecls) + s.(st_datapath) + (AssocMap.set n st s.(st_controllogic))) + (add_control_instr_force_state_incr s n st). + Fixpoint pred_expr (preg: reg) (p: pred_op) := match p with - | Pvar pred => - Vrange preg (Vlit (natToValue pred)) (Vlit (natToValue pred)) - | Pnot pred => - Vunop Vnot (pred_expr preg pred) + | Plit (b, pred) => + if b + then Vrange preg (Vlit (posToValue pred)) (Vlit (posToValue pred)) + else Vunop Vnot (Vrange preg (Vlit (posToValue pred)) (Vlit (posToValue pred))) + | Ptrue => Vlit (ZToValue 1) + | Pfalse => Vlit (ZToValue 0) | Pand p1 p2 => Vbinop Vand (pred_expr preg p1) (pred_expr preg p2) | Por p1 p2 => @@ -671,33 +680,20 @@ Definition translate_predicate (a : assignment) ret (a dst (Vternary (pred_expr preg pos) e dst)) end. -Definition translate_inst a (fu : funct_units) (fin rtrn stack preg : reg) (n : node) (i : instr) +Definition translate_inst a (fin rtrn stack preg : reg) (n : node) (i : instr) : mon stmnt := match i with - | RBnop => + | FUnop => ret Vskip - | RBop p op args dst => + | FUop p op args dst => do instr <- translate_instr op args; do _ <- declare_reg None dst 32; translate_predicate a preg p (Vvar dst) instr - | RBload p chunk addr args dst => - do src <- translate_arr_access chunk addr args stack; - do _ <- declare_reg None dst 32; - translate_predicate a preg p (Vvar dst) src - | RBstore p chunk addr args src => - do dst <- translate_arr_access chunk addr args stack; - translate_predicate a preg p dst (Vvar src) - | RBsetpred c args p => + | FUread p1 p2 r => ret Vskip + | FUwrite p1 p2 r => ret Vskip + | FUsetpred _ c args p => do cond <- translate_condition c args; - ret (a (pred_expr preg (Pvar p)) cond) - | RBpiped p f args => - match PTree.get f fu.(avail_units), args with - | Some (SignedDiv s n d q _), r1::r2::nil => - ret (Vseq (a (Vvar n) (Vvar r1)) (a (Vvar d) (Vvar r2))) - | _, _ => error (Errors.msg "HTLPargen.translate_inst: not a signed divide.") - end - | RBassign p f src dst => - ret (a (Vvar dst) (Vvar src)) + ret (a (pred_expr preg (Plit (true, p))) cond) end. Lemma create_new_state_state_incr: @@ -710,8 +706,7 @@ Lemma create_new_state_state_incr: s.(st_scldecls) s.(st_arrdecls) s.(st_datapath) - s.(st_controllogic) - s.(st_funct_units)). + s.(st_controllogic)). Admitted. Definition create_new_state (p: node): mon node := @@ -723,17 +718,15 @@ Definition create_new_state (p: node): mon node := s.(st_scldecls) s.(st_arrdecls) s.(st_datapath) - s.(st_controllogic) - s.(st_funct_units)) + s.(st_controllogic)) (create_new_state_state_incr s p). -Definition translate_inst_list (fu: funct_units) - (fin rtrn stack preg: reg) (ni : node * node * list (list instr)) := +Definition translate_inst_list (fin rtrn stack preg: reg) (ni : node * node * list (list instr)) := match ni with | (n, p, li) => do _ <- collectlist (fun l => - do stmnt <- translate_inst Vblock fu fin rtrn stack preg n l; + do stmnt <- translate_inst Vblock fin rtrn stack preg n l; add_data_instr n stmnt) (concat li); do st <- get; add_control_instr n (state_goto st.(st_st) p) @@ -742,14 +735,14 @@ Definition translate_inst_list (fu: funct_units) Fixpoint translate_cfi' (fin rtrn stack preg: reg) (cfi: cf_instr) : mon (stmnt * stmnt) := match cfi with - | RBgoto n' => + | FUgoto n' => do st <- get; ret (Vskip, state_goto st.(st_st) n') - | RBcond c args n1 n2 => + | FUcond c args n1 n2 => do st <- get; do e <- translate_condition c args; ret (Vskip, state_cond st.(st_st) e n1 n2) - | RBreturn r => + | FUreturn r => match r with | Some r' => ret ((Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r'))), @@ -758,18 +751,18 @@ Fixpoint translate_cfi' (fin rtrn stack preg: reg) (cfi: cf_instr) ret ((Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vlit (ZToValue 0%Z)))), Vskip) end - | RBpred_cf p c1 c2 => + | FUpred_cf p c1 c2 => do (tc1s, tc1c) <- translate_cfi' fin rtrn stack preg c1; do (tc2s, tc2c) <- translate_cfi' fin rtrn stack preg c2; ret ((Vcond (pred_expr preg p) tc1s tc2s), (Vcond (pred_expr preg p) tc1c tc2c)) - | RBjumptable r tbl => + | FUjumptable r tbl => do s <- get; - ret (Vskip, Vcase (Vvar r) (tbl_to_case_expr s.(st_st) tbl) (Some Vskip)) - | RBcall sig ri rl r n => + ret (Vskip, Vcase (Vvar r) (list_to_stmnt (tbl_to_case_expr s.(st_st) tbl)) (Some Vskip)) + | FUcall sig ri rl r n => error (Errors.msg "HTLPargen: RPcall not supported.") - | RBtailcall sig ri lr => + | FUtailcall sig ri lr => error (Errors.msg "HTLPargen: RPtailcall not supported.") - | RBbuiltin e lb b n => + | FUbuiltin e lb b n => error (Errors.msg "HTLPargen: RPbuildin not supported.") end. @@ -780,11 +773,11 @@ Definition translate_cfi (fin rtrn stack preg: reg) (ni: node * cf_instr) do _ <- add_control_instr n c; add_data_instr n s. -Definition transf_bblock (fu: funct_units) (fin rtrn stack preg: reg) (ni : node * bblock) +Definition transf_bblock (fin rtrn stack preg: reg) (ni : node * bblock) : mon unit := let (n, bb) := ni in do nstate <- create_new_state ((poslength bb.(bb_body)))%positive; - do _ <- collectlist (translate_inst_list fu fin rtrn stack preg) + do _ <- collectlist (translate_inst_list fin rtrn stack preg) (prange n (nstate + poslength bb.(bb_body) - 1)%positive bb.(bb_body)); match bb.(bb_body) with @@ -792,14 +785,31 @@ Definition transf_bblock (fu: funct_units) (fin rtrn stack preg: reg) (ni : node | _ => translate_cfi fin rtrn stack preg (nstate, bb.(bb_exit)) end. -Definition transf_module (f: function) : mon HTL.module := +Definition decide_order a b c d e f g : {module_ordering a b c d e f g} + {True}. + refine (match bool_dec ((a <? b) && (b <? c) && (c <? d) + && (d <? e) && (e <? f) && (f <? g))%positive true with + | left t => left _ + | _ => _ + end); auto. + simplify; repeat match goal with + | H: context[(_ <? _)%positive] |- _ => apply Pos.ltb_lt in H + end; unfold module_ordering; auto. +Defined. + +Lemma clk_greater : + forall ram clk r', + Some ram = Some r' -> (clk < ram_addr r')%positive. +Proof. Admitted. + +Definition transf_module (f: function) : mon HTL.module. + refine ( if stack_correct f.(fn_stacksize) then do fin <- create_reg (Some Voutput) 1; do rtrn <- create_reg (Some Voutput) 32; do (stack, stack_len) <- create_arr None 32 (Z.to_nat (f.(fn_stacksize) / 4)); do preg <- create_reg None 32; - do _ <- collectlist (transf_bblock f.(fn_funct_units) fin rtrn stack preg) + do _ <- collectlist (transf_bblock fin rtrn stack preg) (Maps.PTree.elements f.(fn_code)); do _ <- collectlist (fun r => declare_reg (Some Vinput) r 32) f.(fn_params); @@ -810,8 +820,12 @@ Definition transf_module (f: function) : mon HTL.module := match zle (Z.pos (max_pc_map current_state.(st_datapath))) Integers.Int.max_unsigned, zle (Z.pos (max_pc_map current_state.(st_controllogic))) - Integers.Int.max_unsigned with - | left LEDATA, left LECTRL => + Integers.Int.max_unsigned, + decide_order (st_st current_state) fin rtrn stack start rst clk, + max_list_dec (fn_params f) (st_st current_state), + get_ram 0 (fn_funct_units f) + with + | left LEDATA, left LECTRL, left MORD, left WFPARAMS, Some (i, ram) => ret (HTL.mkmodule f.(fn_params) current_state.(st_datapath) @@ -825,13 +839,40 @@ Definition transf_module (f: function) : mon HTL.module := start rst clk - f.(fn_funct_units) current_state.(st_scldecls) current_state.(st_arrdecls) - (conj (max_pc_wf _ LECTRL) (max_pc_wf _ LEDATA))) - | _, _ => error (Errors.msg "More than 2^32 states.") + (Some ram) + (conj (max_pc_wf _ LECTRL) (max_pc_wf _ LEDATA)) + MORD + _ + WFPARAMS) + | left LEDATA, left LECTRL, left MORD, left WFPARAMS, _ => + ret (HTL.mkmodule + f.(fn_params) + current_state.(st_datapath) + current_state.(st_controllogic) + f.(fn_entrypoint) + current_state.(st_st) + stack + stack_len + fin + rtrn + start + rst + clk + current_state.(st_scldecls) + current_state.(st_arrdecls) + None + (conj (max_pc_wf _ LECTRL) (max_pc_wf _ LEDATA)) + MORD + _ + WFPARAMS) + | _, _, _, _, _ => error (Errors.msg "More than 2^32 states.") end - else error (Errors.msg "Stack size misalignment."). + else error (Errors.msg "Stack size misalignment.")). + apply clk_greater. + discriminate. +Defined. Definition max_state (f: function) : state := let st := Pos.succ (max_reg_function f) in @@ -841,15 +882,14 @@ Definition max_state (f: function) : state := (AssocMap.set st (None, VScalar 32) (st_scldecls (init_state st))) (st_arrdecls (init_state st)) (st_datapath (init_state st)) - (st_controllogic (init_state st)) - (st_funct_units (init_state st)). + (st_controllogic (init_state st)). Definition transl_module (f : function) : Errors.res HTL.module := run_mon (max_state f) (transf_module f). Definition transl_fundef := transf_partial_fundef transl_module. -Definition main_is_internal (p : RTLPar.program) : bool := +Definition main_is_internal (p : RTLParFU.program) : bool := let ge := Globalenvs.Genv.globalenv p in match Globalenvs.Genv.find_symbol ge p.(AST.prog_main) with | Some b => @@ -860,7 +900,7 @@ Definition main_is_internal (p : RTLPar.program) : bool := | _ => false end. -Definition transl_program (p : RTLBlockInstr.program) : Errors.res HTL.program := +Definition transl_program (p : RTLParFU.program) : Errors.res HTL.program := if main_is_internal p then transform_partial_program transl_fundef p else Errors.Error (Errors.msg "Main function is not Internal."). diff --git a/src/hls/HTLgen.v b/src/hls/HTLgen.v index 76616fb..b879c8d 100644 --- a/src/hls/HTLgen.v +++ b/src/hls/HTLgen.v @@ -34,11 +34,11 @@ Require Import vericert.hls.ValueInt. Require Import vericert.hls.Verilog. Require Import vericert.hls.FunctionalUnits. -Hint Resolve AssocMap.gempty : htlh. -Hint Resolve AssocMap.gso : htlh. -Hint Resolve AssocMap.gss : htlh. -Hint Resolve Ple_refl : htlh. -Hint Resolve Ple_succ : htlh. +#[local] Hint Resolve AssocMap.gempty : htlh. +#[local] Hint Resolve AssocMap.gso : htlh. +#[local] Hint Resolve AssocMap.gss : htlh. +#[local] Hint Resolve Ple_refl : htlh. +#[local] Hint Resolve Ple_succ : htlh. Record state: Type := mkstate { st_st : reg; @@ -75,10 +75,10 @@ Module HTLState <: State. s1.(st_controllogic)!n = None \/ s2.(st_controllogic)!n = s1.(st_controllogic)!n) -> st_incr s1 s2. - Hint Constructors st_incr : htlh. + #[export] Hint Constructors st_incr : htlh. Definition st_prop := st_incr. - Hint Unfold st_prop : htlh. + #[export] Hint Unfold st_prop : htlh. Lemma st_refl : forall s, st_prop s s. Proof. auto with htlh. Qed. @@ -584,7 +584,19 @@ Proof. simplify. transitivity (Z.pos (max_pc_map m)); eauto. Qed. -Definition transf_module (f: function) : mon HTL.module := +Definition decide_order a b c d e f g : {module_ordering a b c d e f g} + {True}. + refine (match bool_dec ((a <? b) && (b <? c) && (c <? d) + && (d <? e) && (e <? f) && (f <? g))%positive true with + | left t => left _ + | _ => _ + end); auto. + simplify; repeat match goal with + | H: context[(_ <? _)%positive] |- _ => apply Pos.ltb_lt in H + end; unfold module_ordering; auto. +Defined. + +Definition transf_module (f: function) : mon HTL.module. + refine ( if stack_correct f.(fn_stacksize) then do fin <- create_reg (Some Voutput) 1; do rtrn <- create_reg (Some Voutput) 32; @@ -596,8 +608,11 @@ Definition transf_module (f: function) : mon HTL.module := do clk <- create_reg (Some Vinput) 1; do current_state <- get; match zle (Z.pos (max_pc_map current_state.(st_datapath))) Integers.Int.max_unsigned, - zle (Z.pos (max_pc_map current_state.(st_controllogic))) Integers.Int.max_unsigned with - | left LEDATA, left LECTRL => + zle (Z.pos (max_pc_map current_state.(st_controllogic))) Integers.Int.max_unsigned, + decide_order (st_st current_state) fin rtrn stack start rst clk, + max_list_dec (RTL.fn_params f) (st_st current_state) + with + | left LEDATA, left LECTRL, left MORD, left WFPARAMS => ret (HTL.mkmodule f.(RTL.fn_params) current_state.(st_datapath) @@ -611,19 +626,23 @@ Definition transf_module (f: function) : mon HTL.module := start rst clk - initial_funct_units current_state.(st_scldecls) current_state.(st_arrdecls) - (conj (max_pc_wf _ LECTRL) (max_pc_wf _ LEDATA))) - | _, _ => error (Errors.msg "More than 2^32 states.") + None + (conj (max_pc_wf _ LECTRL) (max_pc_wf _ LEDATA)) + MORD + _ + WFPARAMS) + | _, _, _, _ => error (Errors.msg "More than 2^32 states.") end - else error (Errors.msg "Stack size misalignment."). + else error (Errors.msg "Stack size misalignment.")); discriminate. +Defined. Definition max_state (f: function) : state := let st := Pos.succ (max_reg_function f) in mkstate st (Pos.succ st) - (Pos.succ (max_pc_function f)) + (Pos.succ (RTL.max_pc_function f)) (AssocMap.set st (None, VScalar 32) (st_scldecls (init_state st))) (st_arrdecls (init_state st)) (st_datapath (init_state st)) @@ -634,23 +653,6 @@ Definition transl_module (f : function) : Errors.res HTL.module := Definition transl_fundef := transf_partial_fundef transl_module. -(* Definition transl_program (p : RTL.program) := transform_partial_program transl_fundef p. *) - -(*Definition transl_main_fundef f : Errors.res HTL.fundef := - match f with - | Internal f => transl_fundef (Internal f) - | External f => Errors.Error (Errors.msg "Could not find internal main function") - end. - -(** Translation of a whole program. *) - -Definition transl_program (p: RTL.program) : Errors.res HTL.program := - transform_partial_program2 (fun i f => if Pos.eqb p.(AST.prog_main) i - then transl_fundef f - else transl_main_fundef f) - (fun i v => Errors.OK v) p. -*) - Definition main_is_internal (p : RTL.program) : bool := let ge := Globalenvs.Genv.globalenv p in match Globalenvs.Genv.find_symbol ge p.(AST.prog_main) with diff --git a/src/hls/HTLgenproof.v b/src/hls/HTLgenproof.v index 9a7e272..fc7af6b 100644 --- a/src/hls/HTLgenproof.v +++ b/src/hls/HTLgenproof.v @@ -1,4 +1,4 @@ - (* +(* * Vericert: Verified high-level synthesis. * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com> * 2020 James Pollard <j@mes.dev> @@ -40,24 +40,24 @@ Require Import Lia. Local Open Scope assocmap. -Hint Resolve Smallstep.forward_simulation_plus : htlproof. -Hint Resolve AssocMap.gss : htlproof. -Hint Resolve AssocMap.gso : htlproof. +#[local] Hint Resolve Smallstep.forward_simulation_plus : htlproof. +#[local] Hint Resolve AssocMap.gss : htlproof. +#[local] Hint Resolve AssocMap.gso : htlproof. -Hint Unfold find_assocmap AssocMapExt.get_default : htlproof. +#[local] Hint Unfold find_assocmap AssocMapExt.get_default : htlproof. Inductive match_assocmaps : RTL.function -> RTL.regset -> assocmap -> Prop := match_assocmap : forall f rs am, (forall r, Ple r (RTL.max_reg_function f) -> val_value_lessdef (Registers.Regmap.get r rs) am#r) -> match_assocmaps f rs am. -Hint Constructors match_assocmaps : htlproof. +#[local] Hint Constructors match_assocmaps : htlproof. Definition state_st_wf (m : HTL.module) (s : HTL.state) := forall st asa asr res, s = HTL.State res m st asa asr -> asa!(m.(HTL.mod_st)) = Some (posToValue st). -Hint Unfold state_st_wf : htlproof. +#[local] Hint Unfold state_st_wf : htlproof. Inductive match_arrs (m : HTL.module) (f : RTL.function) (sp : Values.val) (mem : mem) : Verilog.assocmap_arr -> Prop := @@ -133,7 +133,7 @@ Inductive match_states : RTL.state -> HTL.state -> Prop := forall f m m0 (TF : tr_module f m), match_states (RTL.Callstate nil (AST.Internal f) nil m0) (HTL.Callstate nil m nil). -Hint Constructors match_states : htlproof. +#[local] Hint Constructors match_states : htlproof. Definition match_prog (p: RTL.program) (tp: HTL.program) := Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp /\ @@ -187,7 +187,7 @@ Proof. apply Pos.le_lt_trans with _ _ n in H2. unfold not. intros. subst. eapply Pos.lt_irrefl. eassumption. assumption. Qed. -Hint Resolve regs_lessdef_add_greater : htlproof. +#[local] Hint Resolve regs_lessdef_add_greater : htlproof. Lemma regs_lessdef_add_match : forall f rs am r v v', @@ -206,7 +206,7 @@ Proof. unfold find_assocmap. unfold AssocMapExt.get_default. rewrite AssocMap.gso; eauto. Qed. -Hint Resolve regs_lessdef_add_match : htlproof. +#[local] Hint Resolve regs_lessdef_add_match : htlproof. Lemma list_combine_none : forall n l, @@ -348,7 +348,7 @@ Proof. eexists. unfold Verilog.arr_assocmap_lookup. rewrite H5. reflexivity. Qed. -Hint Resolve arr_lookup_some : htlproof. +#[local] Hint Resolve arr_lookup_some : htlproof. Section CORRECTNESS. @@ -392,7 +392,7 @@ Section CORRECTNESS. Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). Proof (Genv.senv_transf_partial TRANSL'). - Hint Resolve senv_preserved : htlproof. + #[local] Hint Resolve senv_preserved : htlproof. Lemma ptrofs_inj : forall a b, @@ -1030,6 +1030,7 @@ Section CORRECTNESS. Ltac tac0 := match goal with + | [ |- HTL.exec_ram _ _ _ _ _ ] => constructor | [ |- context[Verilog.merge_arrs _ _] ] => unfold Verilog.merge_arrs | [ |- context[Verilog.merge_arr] ] => unfold Verilog.merge_arr | [ |- context[Verilog.merge_regs _ _] ] => unfold Verilog.merge_regs; crush; unfold_merge @@ -1103,7 +1104,7 @@ Section CORRECTNESS. Unshelve. exact tt. Qed. - Hint Resolve transl_inop_correct : htlproof. + #[local] Hint Resolve transl_inop_correct : htlproof. Lemma transl_iop_correct: forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) @@ -1155,7 +1156,7 @@ Section CORRECTNESS. unfold Ple in HPle. lia. Unshelve. exact tt. Qed. - Hint Resolve transl_iop_correct : htlproof. + #[local] Hint Resolve transl_iop_correct : htlproof. Ltac tac := repeat match goal with @@ -1628,7 +1629,7 @@ Section CORRECTNESS. exact (Values.Vint (Int.repr 0)). exact tt. Qed. - Hint Resolve transl_iload_correct : htlproof. + #[local] Hint Resolve transl_iload_correct : htlproof. Lemma transl_istore_correct: forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) @@ -1701,7 +1702,7 @@ Section CORRECTNESS. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. - all: crush. + all: try constructor; crush. (** State Lookup *) unfold Verilog.merge_regs. @@ -1735,11 +1736,21 @@ Section CORRECTNESS. crush. unfold Verilog.merge_arrs. - rewrite AssocMap.gcombine. - 2: { reflexivity. } + rewrite AssocMap.gcombine by reflexivity. + rewrite AssocMap.gss. + erewrite Verilog.merge_arr_empty2. unfold Verilog.arr_assocmap_set. + rewrite AssocMap.gcombine by reflexivity. + rewrite AssocMap.gss. rewrite AssocMap.gss. unfold Verilog.merge_arr. + setoid_rewrite H7. + reflexivity. + + rewrite AssocMap.gcombine by reflexivity. + unfold Verilog.merge_arr. + unfold Verilog.arr_assocmap_set. + rewrite AssocMap.gss. rewrite AssocMap.gss. setoid_rewrite H7. reflexivity. @@ -1747,12 +1758,23 @@ Section CORRECTNESS. rewrite combine_length. rewrite <- array_set_len. unfold arr_repeat. crush. + symmetry. apply list_repeat_len. rewrite <- array_set_len. unfold arr_repeat. crush. - rewrite list_repeat_len. - rewrite H4. reflexivity. + rewrite H4. + apply list_repeat_len. + + rewrite combine_length. + rewrite <- array_set_len. + unfold arr_repeat. crush. + apply list_repeat_len. + + rewrite <- array_set_len. + unfold arr_repeat. crush. + rewrite H4. + apply list_repeat_len. remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. @@ -1981,7 +2003,7 @@ Section CORRECTNESS. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. - all: crush. + all: try constructor; crush. (** State Lookup *) unfold Verilog.merge_regs. @@ -2014,11 +2036,21 @@ Section CORRECTNESS. crush. unfold Verilog.merge_arrs. - rewrite AssocMap.gcombine. - 2: { reflexivity. } + rewrite AssocMap.gcombine by reflexivity. + rewrite AssocMap.gss. + erewrite Verilog.merge_arr_empty2. unfold Verilog.arr_assocmap_set. + rewrite AssocMap.gcombine by reflexivity. rewrite AssocMap.gss. + rewrite AssocMap.gss. + unfold Verilog.merge_arr. + setoid_rewrite H7. + reflexivity. + + rewrite AssocMap.gcombine by reflexivity. unfold Verilog.merge_arr. + unfold Verilog.arr_assocmap_set. + rewrite AssocMap.gss. rewrite AssocMap.gss. setoid_rewrite H7. reflexivity. @@ -2026,12 +2058,23 @@ Section CORRECTNESS. rewrite combine_length. rewrite <- array_set_len. unfold arr_repeat. crush. + symmetry. apply list_repeat_len. rewrite <- array_set_len. unfold arr_repeat. crush. - rewrite list_repeat_len. - rewrite H4. reflexivity. + rewrite H4. + apply list_repeat_len. + + rewrite combine_length. + rewrite <- array_set_len. + unfold arr_repeat. crush. + apply list_repeat_len. + + rewrite <- array_set_len. + unfold arr_repeat. crush. + rewrite H4. + apply list_repeat_len. remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) (Integers.Ptrofs.of_int @@ -2229,7 +2272,7 @@ Section CORRECTNESS. eapply Verilog.stmnt_runp_Vnonblock_arr. crush. econstructor. econstructor. econstructor. econstructor. - all: crush. + all: try constructor; crush. (** State Lookup *) unfold Verilog.merge_regs. @@ -2263,11 +2306,21 @@ Section CORRECTNESS. crush. unfold Verilog.merge_arrs. - rewrite AssocMap.gcombine. - 2: { reflexivity. } + rewrite AssocMap.gcombine by reflexivity. + rewrite AssocMap.gss. + erewrite Verilog.merge_arr_empty2. unfold Verilog.arr_assocmap_set. + rewrite AssocMap.gcombine by reflexivity. + rewrite AssocMap.gss. rewrite AssocMap.gss. unfold Verilog.merge_arr. + setoid_rewrite H7. + reflexivity. + + rewrite AssocMap.gcombine by reflexivity. + unfold Verilog.merge_arr. + unfold Verilog.arr_assocmap_set. + rewrite AssocMap.gss. rewrite AssocMap.gss. setoid_rewrite H7. reflexivity. @@ -2275,12 +2328,23 @@ Section CORRECTNESS. rewrite combine_length. rewrite <- array_set_len. unfold arr_repeat. crush. + symmetry. + apply list_repeat_len. + + rewrite <- array_set_len. + unfold arr_repeat. crush. + rewrite H4. + apply list_repeat_len. + + rewrite combine_length. + rewrite <- array_set_len. + unfold arr_repeat. crush. apply list_repeat_len. rewrite <- array_set_len. unfold arr_repeat. crush. - rewrite list_repeat_len. - rewrite H4. reflexivity. + rewrite H4. + apply list_repeat_len. remember i0 as OFFSET. destruct (4 * ptr ==Z Integers.Ptrofs.unsigned OFFSET). @@ -2435,7 +2499,7 @@ Section CORRECTNESS. exact tt. exact (Values.Vint (Int.repr 0)). Qed. - Hint Resolve transl_istore_correct : htlproof. + #[local] Hint Resolve transl_istore_correct : htlproof. Lemma transl_icond_correct: forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) @@ -2463,7 +2527,7 @@ Section CORRECTNESS. eapply eval_cond_correct; eauto. intros. intros. eapply RTL.max_reg_function_use. apply H22. auto. econstructor. auto. - simpl. econstructor. unfold Verilog.merge_regs. unfold_merge. simpl. + simpl. econstructor. constructor. unfold Verilog.merge_regs. unfold_merge. simpl. apply AssocMap.gss. inv MARR. inv CONST. @@ -2480,7 +2544,7 @@ Section CORRECTNESS. eapply eval_cond_correct; eauto. intros. intros. eapply RTL.max_reg_function_use. apply H22. auto. econstructor. auto. - simpl. econstructor. unfold Verilog.merge_regs. unfold_merge. simpl. + simpl. econstructor. constructor. unfold Verilog.merge_regs. unfold_merge. simpl. apply AssocMap.gss. inv MARR. inv CONST. @@ -2489,7 +2553,7 @@ Section CORRECTNESS. Unshelve. all: exact tt. Qed. - Hint Resolve transl_icond_correct : htlproof. + #[local] Hint Resolve transl_icond_correct : htlproof. (*Lemma transl_ijumptable_correct: forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) @@ -2505,7 +2569,7 @@ Section CORRECTNESS. Proof. intros s f sp pc rs m arg tbl n pc' H H0 H1 R1 MSTATE. - Hint Resolve transl_ijumptable_correct : htlproof.*) + #[local] Hint Resolve transl_ijumptable_correct : htlproof.*) Lemma transl_ireturn_correct: forall (s : list RTL.stackframe) (f : RTL.function) (stk : Values.block) @@ -2535,10 +2599,10 @@ Section CORRECTNESS. econstructor; simpl; trivial. constructor. - constructor. constructor. + constructor. constructor. constructor. unfold state_st_wf in WF; big_tac; eauto. - destruct wf as [HCTRL HDATA]. apply HCTRL. + destruct wf1 as [HCTRL HDATA]. apply HCTRL. apply AssocMapExt.elements_iff. eexists. match goal with H: control ! pc = Some _ |- _ => apply H end. @@ -2564,16 +2628,18 @@ Section CORRECTNESS. econstructor; simpl; trivial. constructor. constructor. constructor. constructor. constructor. constructor. + constructor. unfold state_st_wf in WF; big_tac; eauto. - destruct wf as [HCTRL HDATA]. apply HCTRL. + destruct wf1 as [HCTRL HDATA]. apply HCTRL. apply AssocMapExt.elements_iff. eexists. match goal with H: control ! pc = Some _ |- _ => apply H end. apply HTL.step_finish. unfold Verilog.merge_regs. unfold_merge. + unfold_merge. rewrite AssocMap.gso. apply AssocMap.gss. simpl; lia. apply AssocMap.gss. @@ -2591,7 +2657,7 @@ Section CORRECTNESS. Unshelve. all: constructor. Qed. - Hint Resolve transl_ireturn_correct : htlproof. + #[local] Hint Resolve transl_ireturn_correct : htlproof. Lemma transl_callstate_correct: forall (s : list RTL.stackframe) (f : RTL.function) (args : list Values.val) @@ -2699,7 +2765,7 @@ Section CORRECTNESS. Opaque Mem.load. Opaque Mem.store. Qed. - Hint Resolve transl_callstate_correct : htlproof. + #[local] Hint Resolve transl_callstate_correct : htlproof. Lemma transl_returnstate_correct: forall (res0 : Registers.reg) (f : RTL.function) (sp : Values.val) (pc : RTL.node) @@ -2713,7 +2779,7 @@ Section CORRECTNESS. intros res0 f sp pc rs s vres m R1 MSTATE. inversion MSTATE. inversion MF. Qed. - Hint Resolve transl_returnstate_correct : htlproof. + #[local] Hint Resolve transl_returnstate_correct : htlproof. Lemma option_inv : forall A x y, @@ -2773,7 +2839,7 @@ Section CORRECTNESS. rewrite <- H6. setoid_rewrite <- A. trivial. trivial. inv H7. assumption. Qed. - Hint Resolve transl_initial_states : htlproof. + #[local] Hint Resolve transl_initial_states : htlproof. Lemma transl_final_states : forall (s1 : Smallstep.state (RTL.semantics prog)) @@ -2785,7 +2851,7 @@ Section CORRECTNESS. Proof. intros. inv H0. inv H. inv H4. invert MF. constructor. reflexivity. Qed. - Hint Resolve transl_final_states : htlproof. + #[local] Hint Resolve transl_final_states : htlproof. Theorem transl_step_correct: forall (S1 : RTL.state) t S2, @@ -2796,7 +2862,7 @@ Section CORRECTNESS. Proof. induction 1; eauto with htlproof; (intros; inv_state). Qed. - Hint Resolve transl_step_correct : htlproof. + #[local] Hint Resolve transl_step_correct : htlproof. Theorem transf_program_correct: Smallstep.forward_simulation (RTL.semantics prog) (HTL.semantics tprog). diff --git a/src/hls/HTLgenspec.v b/src/hls/HTLgenspec.v index 556e3cc..75d5321 100644 --- a/src/hls/HTLgenspec.v +++ b/src/hls/HTLgenspec.v @@ -33,8 +33,8 @@ Require Import vericert.hls.HTLgen. Require Import vericert.hls.AssocMap. Require Import vericert.hls.FunctionalUnits. -Hint Resolve Maps.PTree.elements_keys_norepet : htlspec. -Hint Resolve Maps.PTree.elements_correct : htlspec. +#[local] Hint Resolve Maps.PTree.elements_keys_norepet : htlspec. +#[local] Hint Resolve Maps.PTree.elements_correct : htlspec. Remark bind_inversion: forall (A B: Type) (f: mon A) (g: A -> mon B) @@ -164,7 +164,7 @@ Inductive tr_instr (fin rtrn st stk : reg) : RTL.instruction -> stmnt -> stmnt - forall cexpr tbl r, cexpr = tbl_to_case_expr st tbl -> tr_instr fin rtrn st stk (RTL.Ijumptable r tbl) (Vskip) (Vcase (Vvar r) cexpr (Some Vskip)).*) -Hint Constructors tr_instr : htlspec. +#[local] Hint Constructors tr_instr : htlspec. Inductive tr_code (c : RTL.code) (pc : RTL.node) (i : RTL.instruction) (stmnts trans : PTree.t stmnt) (fin rtrn st stk : reg) : Prop := @@ -175,16 +175,16 @@ Inductive tr_code (c : RTL.code) (pc : RTL.node) (i : RTL.instruction) (stmnts t trans!pc = Some t -> tr_instr fin rtrn st stk i s t -> tr_code c pc i stmnts trans fin rtrn st stk. -Hint Constructors tr_code : htlspec. +#[local] Hint Constructors tr_code : htlspec. Inductive tr_module (f : RTL.function) : module -> Prop := tr_module_intro : - forall data control fin rtrn st stk stk_len m start rst clk scldecls arrdecls wf, + forall data control fin rtrn st stk stk_len m start rst clk scldecls arrdecls wf1 wf2 wf3 wf4, m = (mkmodule f.(RTL.fn_params) data control f.(RTL.fn_entrypoint) - st stk stk_len fin rtrn start rst clk initial_funct_units scldecls arrdecls wf) -> + st stk stk_len fin rtrn start rst clk scldecls arrdecls None wf1 wf2 wf3 wf4) -> (forall pc i, Maps.PTree.get pc f.(RTL.fn_code) = Some i -> tr_code f.(RTL.fn_code) pc i data control fin rtrn st stk) -> stk_len = Z.to_nat (f.(RTL.fn_stacksize) / 4) -> @@ -198,70 +198,70 @@ Inductive tr_module (f : RTL.function) : module -> Prop := rst = ((RTL.max_reg_function f) + 6)%positive -> clk = ((RTL.max_reg_function f) + 7)%positive -> tr_module f m. -Hint Constructors tr_module : htlspec. +#[local] Hint Constructors tr_module : htlspec. Lemma create_reg_datapath_trans : forall sz s s' x i iop, create_reg iop sz s = OK x s' i -> s.(st_datapath) = s'.(st_datapath). Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_reg_datapath_trans : htlspec. +#[local] Hint Resolve create_reg_datapath_trans : htlspec. Lemma create_reg_controllogic_trans : forall sz s s' x i iop, create_reg iop sz s = OK x s' i -> s.(st_controllogic) = s'.(st_controllogic). Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_reg_controllogic_trans : htlspec. +#[local] Hint Resolve create_reg_controllogic_trans : htlspec. Lemma declare_reg_datapath_trans : forall sz s s' x i iop r, declare_reg iop r sz s = OK x s' i -> s.(st_datapath) = s'.(st_datapath). Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_reg_datapath_trans : htlspec. +#[local] Hint Resolve create_reg_datapath_trans : htlspec. Lemma declare_reg_controllogic_trans : forall sz s s' x i iop r, declare_reg iop r sz s = OK x s' i -> s.(st_controllogic) = s'.(st_controllogic). Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_reg_controllogic_trans : htlspec. +#[local] Hint Resolve create_reg_controllogic_trans : htlspec. Lemma declare_reg_freshreg_trans : forall sz s s' x i iop r, declare_reg iop r sz s = OK x s' i -> s.(st_freshreg) = s'.(st_freshreg). Proof. inversion 1; auto. Qed. -Hint Resolve declare_reg_freshreg_trans : htlspec. +#[local] Hint Resolve declare_reg_freshreg_trans : htlspec. Lemma create_arr_datapath_trans : forall sz ln s s' x i iop, create_arr iop sz ln s = OK x s' i -> s.(st_datapath) = s'.(st_datapath). Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_arr_datapath_trans : htlspec. +#[local] Hint Resolve create_arr_datapath_trans : htlspec. Lemma create_arr_controllogic_trans : forall sz ln s s' x i iop, create_arr iop sz ln s = OK x s' i -> s.(st_controllogic) = s'.(st_controllogic). Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_arr_controllogic_trans : htlspec. +#[local] Hint Resolve create_arr_controllogic_trans : htlspec. Lemma get_refl_x : forall s s' x i, get s = OK x s' i -> s = x. Proof. inversion 1. trivial. Qed. -Hint Resolve get_refl_x : htlspec. +#[local] Hint Resolve get_refl_x : htlspec. Lemma get_refl_s : forall s s' x i, get s = OK x s' i -> s = s'. Proof. inversion 1. trivial. Qed. -Hint Resolve get_refl_s : htlspec. +#[local] Hint Resolve get_refl_s : htlspec. Ltac inv_incr := repeat match goal with @@ -350,7 +350,7 @@ Lemma translate_eff_addressing_freshreg_trans : Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. Qed. -Hint Resolve translate_eff_addressing_freshreg_trans : htlspec. +#[local] Hint Resolve translate_eff_addressing_freshreg_trans : htlspec. Lemma translate_comparison_freshreg_trans : forall op args s r s' i, @@ -359,7 +359,7 @@ Lemma translate_comparison_freshreg_trans : Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. Qed. -Hint Resolve translate_comparison_freshreg_trans : htlspec. +#[local] Hint Resolve translate_comparison_freshreg_trans : htlspec. Lemma translate_comparisonu_freshreg_trans : forall op args s r s' i, @@ -368,7 +368,7 @@ Lemma translate_comparisonu_freshreg_trans : Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. Qed. -Hint Resolve translate_comparisonu_freshreg_trans : htlspec. +#[local] Hint Resolve translate_comparisonu_freshreg_trans : htlspec. Lemma translate_comparison_imm_freshreg_trans : forall op args s r s' i n, @@ -377,7 +377,7 @@ Lemma translate_comparison_imm_freshreg_trans : Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. Qed. -Hint Resolve translate_comparison_imm_freshreg_trans : htlspec. +#[local] Hint Resolve translate_comparison_imm_freshreg_trans : htlspec. Lemma translate_comparison_immu_freshreg_trans : forall op args s r s' i n, @@ -386,7 +386,7 @@ Lemma translate_comparison_immu_freshreg_trans : Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. Qed. -Hint Resolve translate_comparison_immu_freshreg_trans : htlspec. +#[local] Hint Resolve translate_comparison_immu_freshreg_trans : htlspec. Lemma translate_condition_freshreg_trans : forall op args s r s' i, @@ -395,7 +395,7 @@ Lemma translate_condition_freshreg_trans : Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. Qed. -Hint Resolve translate_condition_freshreg_trans : htlspec. +#[local] Hint Resolve translate_condition_freshreg_trans : htlspec. Lemma translate_instr_freshreg_trans : forall op args s r s' i, @@ -405,7 +405,7 @@ Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. monadInv H1. eauto with htlspec. Qed. -Hint Resolve translate_instr_freshreg_trans : htlspec. +#[local] Hint Resolve translate_instr_freshreg_trans : htlspec. Lemma translate_arr_access_freshreg_trans : forall mem addr args st s r s' i, @@ -414,35 +414,35 @@ Lemma translate_arr_access_freshreg_trans : Proof. intros. unfold translate_arr_access in H. repeat (unfold_match H); inv H; eauto with htlspec. Qed. -Hint Resolve translate_arr_access_freshreg_trans : htlspec. +#[local] Hint Resolve translate_arr_access_freshreg_trans : htlspec. Lemma add_instr_freshreg_trans : forall n n' st s r s' i, add_instr n n' st s = OK r s' i -> s.(st_freshreg) = s'.(st_freshreg). Proof. intros. unfold add_instr in H. repeat (unfold_match H). inv H. auto. Qed. -Hint Resolve add_instr_freshreg_trans : htlspec. +#[local] Hint Resolve add_instr_freshreg_trans : htlspec. Lemma add_branch_instr_freshreg_trans : forall n n0 n1 e s r s' i, add_branch_instr e n n0 n1 s = OK r s' i -> s.(st_freshreg) = s'.(st_freshreg). Proof. intros. unfold add_branch_instr in H. repeat (unfold_match H). inv H. auto. Qed. -Hint Resolve add_branch_instr_freshreg_trans : htlspec. +#[local] Hint Resolve add_branch_instr_freshreg_trans : htlspec. Lemma add_node_skip_freshreg_trans : forall n1 n2 s r s' i, add_node_skip n1 n2 s = OK r s' i -> s.(st_freshreg) = s'.(st_freshreg). Proof. intros. unfold add_node_skip in H. repeat (unfold_match H). inv H. auto. Qed. -Hint Resolve add_node_skip_freshreg_trans : htlspec. +#[local] Hint Resolve add_node_skip_freshreg_trans : htlspec. Lemma add_instr_skip_freshreg_trans : forall n1 n2 s r s' i, add_instr_skip n1 n2 s = OK r s' i -> s.(st_freshreg) = s'.(st_freshreg). Proof. intros. unfold add_instr_skip in H. repeat (unfold_match H). inv H. auto. Qed. -Hint Resolve add_instr_skip_freshreg_trans : htlspec. +#[local] Hint Resolve add_instr_skip_freshreg_trans : htlspec. Lemma transf_instr_freshreg_trans : forall fin ret st instr s v s' i, @@ -460,7 +460,7 @@ Proof. congruence. (*- inv EQ. apply add_node_skip_freshreg_trans in EQ0. congruence.*) Qed. -Hint Resolve transf_instr_freshreg_trans : htlspec. +#[local] Hint Resolve transf_instr_freshreg_trans : htlspec. Lemma collect_trans_instr_freshreg_trans : forall fin ret st l s s' i, @@ -590,7 +590,7 @@ Proof. intros. specialize H1 with pc0 instr0. destruct H1. tauto. trivial. destruct H2. inv H2. contradiction. assumption. assumption. Qed. -Hint Resolve iter_expand_instr_spec : htlspec. +#[local] Hint Resolve iter_expand_instr_spec : htlspec. Lemma create_arr_inv : forall w x y z a b c d, create_arr w x y z = OK (a, b) c d -> @@ -649,5 +649,9 @@ Proof. replace (st_datapath s10) with (st_datapath s3) by congruence. replace (st_st s10) with (st_st s3) by congruence. eapply iter_expand_instr_spec; eauto with htlspec. + rewrite H5. rewrite H7. apply EQ2. apply PTree.elements_complete. + eauto with htlspec. + erewrite <- collect_declare_freshreg_trans; try eassumption. + lia. Qed. diff --git a/src/hls/HashTree.v b/src/hls/HashTree.v new file mode 100644 index 0000000..f3c57a8 --- /dev/null +++ b/src/hls/HashTree.v @@ -0,0 +1,438 @@ +(* + * Vericert: Verified high-level synthesis. + * Copyright (C) 2021 Yann Herklotz <yann@yannherklotz.com> + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see <https://www.gnu.org/licenses/>. + *) + +Require Import compcert.lib.Maps. + +Require Import vericert.common.Vericertlib. + +#[local] Open Scope positive. + +#[local] Hint Resolve in_eq : core. +#[local] Hint Resolve in_cons : core. + +Definition max_key {A} (t: PTree.t A) := + fold_right Pos.max 1%positive (map fst (PTree.elements t)). + +Lemma max_key_correct' : + forall l hi, In hi l -> hi <= fold_right Pos.max 1 l. +Proof. + induction l; crush. + inv H. lia. + destruct (Pos.max_dec a (fold_right Pos.max 1 l)); rewrite e. + - apply Pos.max_l_iff in e. + assert (forall a b c, a <= c -> c <= b -> a <= b) by lia. + eapply H; eauto. + - apply IHl; auto. +Qed. + +Lemma max_key_correct : + forall A h_tree hi (c: A), + h_tree ! hi = Some c -> + hi <= max_key h_tree. +Proof. + unfold max_key. intros. apply PTree.elements_correct in H. + apply max_key_correct'. + eapply in_map with (f := fst) in H. auto. +Qed. + +Lemma max_not_present : + forall A k (h: PTree.t A), k > max_key h -> h ! k = None. +Proof. + intros. destruct (h ! k) eqn:?; auto. + apply max_key_correct in Heqo. lia. +Qed. + +Lemma filter_none : + forall A f l (x: A), filter f l = nil -> In x l -> f x = false. +Proof. induction l; crush; inv H0; subst; destruct_match; crush. Qed. + +Lemma filter_set : + forall A l l' f (x: A), + (In x l -> In x l') -> + In x (filter f l) -> + In x (filter f l'). +Proof. + induction l; crush. + destruct_match; crush. inv H0; crush. + apply filter_In. simplify; crush. +Qed. + +Lemma filter_cons_true : + forall A f l (a: A) l', + filter f l = a :: l' -> f a = true. +Proof. + induction l; crush. destruct (f a) eqn:?. + inv H. auto. eapply IHl; eauto. +Qed. + +Lemma PTree_set_elements : + forall A t x x' (c: A), + In x (PTree.elements t) -> + x' <> (fst x) -> + In x (PTree.elements (PTree.set x' c t)). +Proof. + intros. destruct x. + eapply PTree.elements_correct. simplify. + rewrite PTree.gso; auto. apply PTree.elements_complete in H. auto. +Qed. + +Lemma filter_set2 : + forall A x y z (h: PTree.t A), + In z (PTree.elements (PTree.set x y h)) -> + In z (PTree.elements h) \/ fst z = x. +Proof. + intros. destruct z. + destruct (Pos.eq_dec p x); subst. + tauto. + left. apply PTree.elements_correct. apply PTree.elements_complete in H. + rewrite PTree.gso in H; auto. +Qed. + +Lemma in_filter : forall A f l (x: A), In x (filter f l) -> In x l. +Proof. induction l; crush. destruct_match; crush. inv H; crush. Qed. + +Lemma filter_norepet: + forall A f (l: list A), + list_norepet l -> + list_norepet (filter f l). +Proof. + induction l; crush. + inv H. destruct (f a). + constructor. unfold not in *; intros. apply H2. + eapply in_filter; eauto. + apply IHl; auto. + apply IHl; auto. +Qed. + +Lemma filter_norepet2: + forall A B g (l: list (A * B)), + list_norepet (map fst l) -> + list_norepet (map fst (filter g l)). +Proof. + induction l; crush. + inv H. destruct (g a) eqn:?. + simplify. constructor. unfold not in *. intros. + eapply H2. + apply list_in_map_inv in H. simplify; subst. + rewrite H. + apply filter_In in H1. simplify. + apply in_map. eauto. + eapply IHl. eauto. + eapply IHl. eauto. +Qed. + +Module Type Hashable. + + Parameter t: Type. + Parameter eq_dec: forall (t1 t2: t), {t1 = t2} + {t1 <> t2}. + +End Hashable. + +Module HashTree(H: Hashable). + + Import H. + + Definition hash := positive. + Definition hash_tree := PTree.t t. + + Definition find_tree (el: t) (h: hash_tree) : option hash := + match filter (fun x => if eq_dec el (snd x) then true else false) (PTree.elements h) with + | (p, _) :: nil => Some p + | _ => None + end. + + Definition hash_value (max: hash) (e: t) (h: hash_tree): hash * hash_tree := + match find_tree e h with + | Some p => (p, h) + | None => + let nkey := Pos.max max (max_key h) + 1 in + (nkey, PTree.set nkey e h) + end. + + Definition wf_hash_table h_tree := + forall x c, h_tree ! x = Some c -> find_tree c h_tree = Some x. + + Lemma find_tree_correct : + forall c h_tree p, + find_tree c h_tree = Some p -> + h_tree ! p = Some c. + Proof. + intros. + unfold find_tree in H. destruct_match; crush. + destruct_match; simplify. + destruct_match; crush. + assert (In (p, t0) (filter + (fun x : hash * t => + if eq_dec c (snd x) then true else false) (PTree.elements h_tree))). + { setoid_rewrite Heql. constructor; auto. } + apply filter_In in H. simplify. destruct_match; crush. subst. + apply PTree.elements_complete; auto. + Qed. + + Lemma find_tree_unique : + forall c h_tree p p', + find_tree c h_tree = Some p -> + h_tree ! p' = Some c -> + p = p'. + Proof. + intros. + unfold find_tree in H. + repeat (destruct_match; crush; []). + assert (In (p, t0) (filter + (fun x : hash * t => + if eq_dec c (snd x) then true else false) (PTree.elements h_tree))). + { setoid_rewrite Heql. constructor; auto. } + apply filter_In in H. simplify. + destruct (Pos.eq_dec p p'); auto. + exfalso. + destruct_match; subst; crush. + assert (In (p', t0) (PTree.elements h_tree) /\ (fun x : hash * t => + if eq_dec t0 (snd x) then true else false) (p', t0) = true). + { split. apply PTree.elements_correct. auto. setoid_rewrite Heqs. auto. } + apply filter_In in H. setoid_rewrite Heql in H. inv H. simplify. crush. crush. + Qed. + + Lemma hash_no_element' : + forall c h_tree, + find_tree c h_tree = None -> + wf_hash_table h_tree -> + ~ forall x, h_tree ! x = Some c. + Proof. + unfold not, wf_hash_table; intros. + specialize (H1 1). eapply H0 in H1. crush. + Qed. + + Lemma hash_no_element : + forall c h_tree, + find_tree c h_tree = None -> + wf_hash_table h_tree -> + ~ exists x, h_tree ! x = Some c. + Proof. + unfold not, wf_hash_table; intros. + simplify. apply H0 in H2. rewrite H in H2. crush. + Qed. + + Lemma wf_hash_table_set_gso' : + forall h x p0 c', + filter + (fun x : hash * t => + if eq_dec c' (snd x) then true else false) (PTree.elements h) = + (x, p0) :: nil -> + h ! x = Some p0 /\ p0 = c'. + Proof. + intros. + match goal with + | H: filter ?f ?el = ?x::?xs |- _ => + assert (In x (filter f el)) by (rewrite H; crush) + end. + apply filter_In in H0. simplify. destruct_match; subst; crush. + apply PTree.elements_complete; auto. + destruct_match; crush. + Qed. + + Lemma wf_hash_table_set_gso : + forall x x' c' c h, + x <> x' -> + wf_hash_table h -> + find_tree c' h = Some x -> + find_tree c h = None -> + find_tree c' (PTree.set x' c h) = Some x. + Proof. + intros. pose proof H1 as X. unfold find_tree in H1. + destruct_match; crush. + destruct p. destruct l; crush. + apply wf_hash_table_set_gso' in Heql. simplify. + pose proof H2 as Z. apply hash_no_element in H2; auto. + destruct (eq_dec c c'); subst. + { exfalso. eapply H2. econstructor; eauto. } + unfold wf_hash_table in H0. + assert (In (x', c) (PTree.elements (PTree.set x' c h))). + { apply PTree.elements_correct. rewrite PTree.gss; auto. } + assert (In (x, c') (PTree.elements h)). + { apply PTree.elements_correct; auto. } + assert (In (x, c') (PTree.elements (PTree.set x' c h))). + { apply PTree.elements_correct. rewrite PTree.gso; auto. } + pose proof X as Y. + unfold find_tree in X. repeat (destruct_match; crush; []). + match goal with + | H: filter ?f ?el = ?x::?xs |- _ => + assert (In x (filter f el)) by (rewrite H; crush) + end. + apply filter_In in H6. simplify. destruct_match; crush; subst. + unfold find_tree. repeat (destruct_match; crush). + { eapply filter_none in Heql0. + 2: { apply PTree.elements_correct. rewrite PTree.gso; eauto. } + destruct_match; crush. } + + { subst. + repeat match goal with + | H: filter ?f ?el = ?x::?xs |- _ => + learn H; assert (In x (filter f el)) by (rewrite H; crush) + end. + eapply filter_set in H10. rewrite Heql0 in H10. inv H10. simplify. auto. + inv H11. auto. inv H11. intros. eapply PTree_set_elements; auto. } + + { exfalso. subst. + repeat match goal with + | H: filter ?f ?el = ?x::?xs |- _ => + learn H; assert (In x (filter f el)) by (rewrite H; crush) + end. + + pose proof H8 as X2. destruct p1. + pose proof X2 as X4. + apply in_filter in X2. apply PTree.elements_complete in X2. + assert (In (p, t2) (filter + (fun x : positive * t => if eq_dec t0 (snd x) then true else false) + (PTree.elements (PTree.set x' c h)))) by (rewrite H6; eauto). + pose proof H11 as X3. + apply in_filter in H11. apply PTree.elements_complete in H11. + destruct (peq p0 p); subst. + { + assert (list_norepet (map fst (filter + (fun x : positive * t => if eq_dec t0 (snd x) then true else false) + (PTree.elements (PTree.set x' c h))))). + { eapply filter_norepet2. eapply PTree.elements_keys_norepet. } + rewrite Heql0 in H12. simplify. inv H12. eapply H15. apply in_eq. + } + { apply filter_In in X4. simplify. destruct_match; crush; subst. + apply filter_In in X3. simplify. destruct_match; crush; subst. + destruct (peq p x'); subst. + { rewrite PTree.gss in H11; crush. } + { destruct (peq p0 x'); subst. + { rewrite PTree.gss in X2; crush. } + { rewrite PTree.gso in X2 by auto. + rewrite PTree.gso in H11 by auto. + assert (p = p0) by (eapply find_tree_unique; eauto). + crush. } } } } + Qed. + + Lemma wf_hash_table_set : + forall h_tree c v (GT: v > max_key h_tree), + find_tree c h_tree = None -> + wf_hash_table h_tree -> + wf_hash_table (PTree.set v c h_tree). + Proof. + unfold wf_hash_table; simplify. + destruct (peq v x); subst. + pose proof (hash_no_element c h_tree H H0). + rewrite PTree.gss in H1. simplify. + unfold find_tree. + assert (In (x, c0) (PTree.elements (PTree.set x c0 h_tree)) + /\ (fun x : positive * t => if eq_dec c0 (snd x) then true else false) + (x, c0) = true). + { simplify. apply PTree.elements_correct. rewrite PTree.gss. auto. + destruct (eq_dec c0 c0); crush. } + destruct_match. + apply filter_In in H1. rewrite Heql in H1. crush. + apply filter_In in H1. repeat (destruct_match; crush; []). subst. + destruct l. simplify. rewrite Heql in H1. inv H1. inv H3. auto. + crush. + + exfalso. apply H2. destruct p. + pose proof Heql as X. apply filter_cons_true in X. destruct_match; crush; subst. + assert (In (p0, t0) (filter + (fun x : positive * t => if eq_dec t0 (snd x) then true else false) + (PTree.elements (PTree.set x t0 h_tree)))) by (rewrite Heql; eauto). + assert (In (p, t1) (filter + (fun x : positive * t => if eq_dec t0 (snd x) then true else false) + (PTree.elements (PTree.set x t0 h_tree)))) by (rewrite Heql; eauto). + apply filter_In in H4. simplify. destruct_match; crush; subst. + apply in_filter in H3. apply PTree.elements_complete in H5. apply PTree.elements_complete in H3. + assert (list_norepet (map fst (filter + (fun x : positive * t => if eq_dec t1 (snd x) then true else false) + (PTree.elements (PTree.set x t1 h_tree))))). + { eapply filter_norepet2. eapply PTree.elements_keys_norepet. } + rewrite Heql in H4. simplify. + destruct (peq p0 p); subst. + { inv H4. exfalso. eapply H8. eauto. } + destruct (peq x p); subst. + rewrite PTree.gso in H3; auto. econstructor; eauto. + rewrite PTree.gso in H5; auto. econstructor; eauto. + + rewrite PTree.gso in H1; auto. + destruct (eq_dec c c0); subst. + { apply H0 in H1. rewrite H in H1. discriminate. } + apply H0 in H1. + apply wf_hash_table_set_gso; eauto. + Qed. + + Lemma wf_hash_table_distr : + forall m p h_tree h h_tree', + hash_value m p h_tree = (h, h_tree') -> + wf_hash_table h_tree -> + wf_hash_table h_tree'. + Proof. + unfold hash_value; simplify. + destruct_match. + - inv H; auto. + - inv H. apply wf_hash_table_set; try lia; auto. + Qed. + + Lemma wf_hash_table_eq : + forall h_tree a b c, + wf_hash_table h_tree -> + h_tree ! a = Some c -> + h_tree ! b = Some c -> + a = b. + Proof. + unfold wf_hash_table; intros; apply H in H0; eapply find_tree_unique; eauto. + Qed. + + Lemma hash_constant : + forall p h h_tree hi c h_tree' m, + h_tree ! hi = Some c -> + hash_value m p h_tree = (h, h_tree') -> + h_tree' ! hi = Some c. + Proof. + intros. unfold hash_value in H0. destruct_match. + inv H0. eauto. + inv H0. + pose proof H. apply max_key_correct in H0. + rewrite PTree.gso; solve [eauto | lia]. + Qed. + + Lemma find_tree_Some : + forall el h v, + find_tree el h = Some v -> + h ! v = Some el. + Proof. + intros. unfold find_tree in *. + destruct_match; crush. destruct p. + destruct_match; crush. + match goal with + | H: filter ?f ?el = ?x::?xs |- _ => + assert (In x (filter f el)) by (rewrite H; crush) + end. + apply PTree.elements_complete. + apply filter_In in H. inv H. + destruct_match; crush. + Qed. + + Lemma hash_present_eq : + forall m e1 e2 p1 h h', + hash_value m e2 h = (p1, h') -> + h ! p1 = Some e1 -> e1 = e2. + Proof. + intros. unfold hash_value in *. destruct_match. + - inv H. apply find_tree_Some in Heqo. + rewrite Heqo in H0. inv H0. auto. + - inv H. assert (h ! (Pos.max m (max_key h) + 1) = None) + by (apply max_not_present; lia). crush. + Qed. + +End HashTree. diff --git a/src/hls/IfConversion.v b/src/hls/IfConversion.v index e893578..b397d43 100644 --- a/src/hls/IfConversion.v +++ b/src/hls/IfConversion.v @@ -25,6 +25,7 @@ Require Import compcert.lib.Maps. Require Import vericert.common.Vericertlib. Require Import vericert.hls.RTLBlockInstr. Require Import vericert.hls.RTLBlock. +Require Import vericert.hls.Predicate. (*| ============= @@ -57,10 +58,10 @@ Definition if_convert_block (c: code) (p: predicate) (bb: bblock) : bblock := | RBcond cond args n1 n2 => match PTree.get n1 c, PTree.get n2 c with | Some bb1, Some bb2 => - let bb1' := List.map (map_if_convert (Pvar p)) bb1.(bb_body) in - let bb2' := List.map (map_if_convert (Pnot (Pvar p))) bb2.(bb_body) in - mk_bblock (List.concat (bb.(bb_body) :: ((RBsetpred cond args p) :: bb1') :: bb2' :: nil)) - (RBpred_cf (Pvar p) bb1.(bb_exit) bb2.(bb_exit)) + let bb1' := List.map (map_if_convert (Plit (true, p))) bb1.(bb_body) in + let bb2' := List.map (map_if_convert (Plit (false, p))) bb2.(bb_body) in + mk_bblock (List.concat (bb.(bb_body) :: ((RBsetpred None cond args p) :: bb1') :: bb2' :: nil)) + (RBpred_cf (Plit (true, p)) bb1.(bb_exit) bb2.(bb_exit)) | _, _ => bb end | _ => bb @@ -104,16 +105,14 @@ Definition find_blocks_with_cond (c: code) : list (node * bblock) := ) (PTree.elements c). Definition if_convert_code (p: nat * code) (nb: node * bblock) := - let (n, bb) := nb in - let (p', c) := p in - let nbb := if_convert_block c p' bb in - (S p', PTree.set n nbb c). + let nbb := if_convert_block (snd p) (Pos.of_nat (fst p)) (snd nb) in + (S (fst p), PTree.set (fst nb) nbb (snd p)). Definition transf_function (f: function) : function := let (_, c) := List.fold_left if_convert_code (find_blocks_with_cond f.(fn_code)) (1%nat, f.(fn_code)) in - mkfunction f.(fn_sig) f.(fn_params) f.(fn_stacksize) c f.(fn_funct_units) f.(fn_entrypoint). + mkfunction f.(fn_sig) f.(fn_params) f.(fn_stacksize) c f.(fn_entrypoint). Definition transf_fundef (fd: fundef) : fundef := transf_fundef transf_function fd. diff --git a/src/hls/Memorygen.v b/src/hls/Memorygen.v new file mode 100644 index 0000000..4ff4a19 --- /dev/null +++ b/src/hls/Memorygen.v @@ -0,0 +1,3204 @@ +(* + * Vericert: Verified high-level synthesis. + * Copyright (C) 2021 Yann Herklotz <yann@yannherklotz.com> + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see <https://www.gnu.org/licenses/>. + *) + +Require Import Coq.micromega.Lia. + +Require Import compcert.backend.Registers. +Require Import compcert.common.AST. +Require Import compcert.common.Globalenvs. +Require compcert.common.Memory. +Require Import compcert.common.Values. +Require Import compcert.lib.Floats. +Require Import compcert.lib.Integers. +Require Import compcert.lib.Maps. +Require compcert.common.Smallstep. +Require compcert.verilog.Op. + +Require Import vericert.common.Vericertlib. +Require Import vericert.hls.ValueInt. +Require Import vericert.hls.Verilog. +Require Import vericert.hls.HTL. +Require Import vericert.hls.AssocMap. +Require Import vericert.hls.Array. +Require Import vericert.hls.FunctionalUnits. + +Local Open Scope positive. +Local Open Scope assocmap. + +#[local] Hint Resolve max_reg_stmnt_le_stmnt_tree : mgen. +#[local] Hint Resolve max_reg_stmnt_lt_stmnt_tree : mgen. +#[local] Hint Resolve max_stmnt_lt_module : mgen. + +Lemma int_eq_not_false : forall x, Int.eq x (Int.not x) = false. +Proof. + intros. unfold Int.eq. + rewrite Int.unsigned_not. + replace Int.max_unsigned with 4294967295%Z by crush. + assert (X: forall x, (x <> 4294967295 - x)%Z) by lia. + specialize (X (Int.unsigned x)). apply zeq_false; auto. +Qed. + +Definition transf_maps state ram in_ (dc: PTree.t stmnt * PTree.t stmnt) := + match dc, in_ with + | (d, c), (i, n) => + match PTree.get i d, PTree.get i c with + | Some (Vnonblock (Vvari r e1) e2), Some c_s => + if r =? (ram_mem ram) then + let nd := Vseq (Vnonblock (Vvar (ram_u_en ram)) (Vunop Vnot (Vvar (ram_u_en ram)))) + (Vseq (Vnonblock (Vvar (ram_wr_en ram)) (Vlit (ZToValue 1))) + (Vseq (Vnonblock (Vvar (ram_d_in ram)) e2) + (Vnonblock (Vvar (ram_addr ram)) e1))) + in + (PTree.set i nd d, c) + else dc + | Some (Vnonblock (Vvar e1) (Vvari r e2)), Some (Vnonblock (Vvar st') e3) => + if (r =? (ram_mem ram)) && (st' =? state) && (Z.pos n <=? Int.max_unsigned)%Z + && (e1 <? state) && (max_reg_expr e2 <? state) && (max_reg_expr e3 <? state) + then + let nd := + Vseq (Vnonblock (Vvar (ram_u_en ram)) (Vunop Vnot (Vvar (ram_u_en ram)))) + (Vseq (Vnonblock (Vvar (ram_wr_en ram)) (Vlit (ZToValue 0))) + (Vnonblock (Vvar (ram_addr ram)) e2)) + in + let aout := Vnonblock (Vvar e1) (Vvar (ram_d_out ram)) in + let redirect := Vnonblock (Vvar state) (Vlit (posToValue n)) in + (PTree.set i nd (PTree.set n aout d), + PTree.set i redirect (PTree.set n (Vnonblock (Vvar st') e3) c)) + else dc + | _, _ => dc + end + end. + +Lemma transf_maps_wf : + forall state ram d c d' c' i, + map_well_formed c /\ map_well_formed d -> + transf_maps state ram i (d, c) = (d', c') -> + map_well_formed c' /\ map_well_formed d'. +Proof. + unfold transf_maps; intros; repeat destruct_match; + match goal with + | H: (_, _) = (_, _) |- _ => inv H + end; auto. + unfold map_well_formed. + simplify; intros. + destruct (Pos.eq_dec p0 p1); subst; auto. + destruct (Pos.eq_dec p p1); subst. unfold map_well_formed in *. + apply AssocMap.elements_correct in Heqo. + eapply in_map with (f := fst) in Heqo. simplify. + apply H1 in Heqo. auto. + apply AssocMapExt.elements_iff in H3. inv H3. + repeat rewrite AssocMap.gso in H8 by lia. + apply AssocMap.elements_correct in H8. + eapply in_map with (f := fst) in H8. simplify. + unfold map_well_formed in *. apply H0 in H8. auto. + apply AssocMapExt.elements_iff in H3. inv H3. + destruct (Pos.eq_dec p0 p1); subst; auto. + destruct (Pos.eq_dec p p1); subst. unfold map_well_formed in *. + apply AssocMap.elements_correct in Heqo. + eapply in_map with (f := fst) in Heqo. simplify. + apply H1 in Heqo. auto. + repeat rewrite AssocMap.gso in H8 by lia. + apply AssocMap.elements_correct in H8. + eapply in_map with (f := fst) in H8. simplify. + unfold map_well_formed in *. apply H1 in H8. auto. + unfold map_well_formed in *; simplify; intros. + destruct (Pos.eq_dec p0 p1); subst; auto. + destruct (Pos.eq_dec p p1); subst. unfold map_well_formed in *. + apply AssocMap.elements_correct in Heqo. + eapply in_map with (f := fst) in Heqo. simplify. + apply H1 in Heqo. auto. + apply AssocMapExt.elements_iff in H. inv H. + repeat rewrite AssocMap.gso in H2 by lia. + apply AssocMap.elements_correct in H2. + eapply in_map with (f := fst) in H2. simplify. + unfold map_well_formed in *. apply H1 in H2. auto. +Qed. + +Definition max_pc {A: Type} (m: PTree.t A) := + fold_right Pos.max 1%positive (map fst (PTree.elements m)). + +Fixpoint zip_range {A: Type} n (l: list A) {struct l} := + match l with + | nil => nil + | a :: b => (a, n) :: zip_range (n+1) b + end. + +Lemma zip_range_fst_idem : forall A (l: list A) a, map fst (zip_range a l) = l. +Proof. induction l; crush. Qed. + +Lemma zip_range_not_in_snd : + forall A (l: list A) a n, a < n -> ~ In a (map snd (zip_range n l)). +Proof. + unfold not; induction l; crush. + inv H0; try lia. eapply IHl. + assert (X: a0 < n + 1) by lia. apply X; auto. auto. +Qed. + +Lemma zip_range_snd_no_repet : + forall A (l: list A) a, list_norepet (map snd (zip_range a l)). +Proof. + induction l; crush; constructor; auto; []. + apply zip_range_not_in_snd; lia. +Qed. + +Lemma zip_range_in : + forall A (l: list A) a n i, In (a, i) (zip_range n l) -> In a l. +Proof. + induction l; crush. inv H. inv H0. auto. right. eapply IHl; eauto. +Qed. + +Lemma zip_range_not_in : + forall A (l: list A) a i n, ~ In a l -> ~ In (a, i) (zip_range n l). +Proof. + unfold not; induction l; crush. inv H0. inv H1. apply H. left. auto. + apply H. right. eapply zip_range_in; eauto. +Qed. + +Lemma zip_range_no_repet : + forall A (l: list A) a, list_norepet l -> list_norepet (zip_range a l). +Proof. + induction l; simplify; constructor; + match goal with H: list_norepet _ |- _ => inv H end; + [apply zip_range_not_in|]; auto. +Qed. + +Definition transf_code state ram d c := + fold_right (transf_maps state ram) (d, c) + (zip_range (Pos.max (max_pc c) (max_pc d) + 1) + (map fst (PTree.elements d))). + +Lemma transf_code_wf' : + forall l c d state ram c' d', + map_well_formed c /\ map_well_formed d -> + fold_right (transf_maps state ram) (d, c) l = (d', c') -> + map_well_formed c' /\ map_well_formed d'. +Proof. + induction l; intros; simpl in *. inv H0; auto. + remember (fold_right (transf_maps state ram) (d, c) l). destruct p. + apply transf_maps_wf in H0. auto. eapply IHl; eauto. +Qed. + +Lemma transf_code_wf : + forall c d state ram c' d', + map_well_formed c /\ map_well_formed d -> + transf_code state ram d c = (d', c') -> + map_well_formed c' /\ map_well_formed d'. +Proof. eauto using transf_code_wf'. Qed. + +Lemma ram_wf : + forall x, + x + 1 < x + 2 /\ x + 2 < x + 3 /\ x + 3 < x + 4 /\ x + 4 < x + 5 /\ x + 5 < x + 6. +Proof. lia. Qed. + +Lemma module_ram_wf' : + forall m addr, + addr = max_reg_module m + 1 -> + mod_clk m < addr. +Proof. unfold max_reg_module; lia. Qed. + +Definition transf_module (m: module): module. + refine ( + let max_reg := max_reg_module m in + let addr := max_reg+1 in + let en := max_reg+2 in + let d_in := max_reg+3 in + let d_out := max_reg+4 in + let wr_en := max_reg+5 in + let u_en := max_reg+6 in + let new_size := (mod_stk_len m) in + let ram := mk_ram new_size (mod_stk m) en u_en addr wr_en d_in d_out ltac:(eauto using ram_wf) in + let tc := transf_code (mod_st m) ram (mod_datapath m) (mod_controllogic m) in + match mod_ram m with + | None => + mkmodule m.(mod_params) + (fst tc) + (snd tc) + (mod_entrypoint m) + (mod_st m) + (mod_stk m) + (mod_stk_len m) + (mod_finish m) + (mod_return m) + (mod_start m) + (mod_reset m) + (mod_clk m) + (AssocMap.set u_en (None, VScalar 1) + (AssocMap.set en (None, VScalar 1) + (AssocMap.set wr_en (None, VScalar 1) + (AssocMap.set d_out (None, VScalar 32) + (AssocMap.set d_in (None, VScalar 32) + (AssocMap.set addr (None, VScalar 32) m.(mod_scldecls))))))) + (AssocMap.set m.(mod_stk) + (None, VArray 32 (2 ^ Nat.log2_up new_size))%nat m.(mod_arrdecls)) + (Some ram) + _ (mod_ordering_wf m) _ (mod_params_wf m) + | _ => m + end). + eapply transf_code_wf. apply (mod_wf m). destruct tc eqn:?; simpl. + rewrite <- Heqp. intuition. + inversion 1; subst. auto using module_ram_wf'. +Defined. + +Definition transf_fundef := transf_fundef transf_module. + +Definition transf_program (p : program) := + transform_program transf_fundef p. + +Inductive match_assocmaps : positive -> assocmap -> assocmap -> Prop := + match_assocmap: forall p rs rs', + (forall r, r < p -> rs!r = rs'!r) -> + match_assocmaps p rs rs'. + +Inductive match_arrs : assocmap_arr -> assocmap_arr -> Prop := +| match_assocmap_arr_intro: forall ar ar', + (forall s arr, + ar ! s = Some arr -> + exists arr', + ar' ! s = Some arr' + /\ (forall addr, + array_get_error addr arr = array_get_error addr arr') + /\ arr_length arr = arr_length arr')%nat -> + (forall s, ar ! s = None -> ar' ! s = None) -> + match_arrs ar ar'. + +Inductive match_arrs_size : assocmap_arr -> assocmap_arr -> Prop := + match_arrs_size_intro : + forall nasa basa, + (forall s arr, + nasa ! s = Some arr -> + exists arr', + basa ! s = Some arr' /\ arr_length arr = arr_length arr') -> + (forall s arr, + basa ! s = Some arr -> + exists arr', + nasa ! s = Some arr' /\ arr_length arr = arr_length arr') -> + (forall s, basa ! s = None <-> nasa ! s = None) -> + match_arrs_size nasa basa. + +Definition match_empty_size (m : module) (ar : assocmap_arr) : Prop := + match_arrs_size (empty_stack m) ar. +#[local] Hint Unfold match_empty_size : mgen. + +Definition disable_ram (ram: option ram) (asr : assocmap_reg) : Prop := + match ram with + | Some r => Int.eq (asr # ((ram_en r), 32)) (asr # ((ram_u_en r), 32)) = true + | None => True + end. + +Inductive match_stackframes : stackframe -> stackframe -> Prop := + match_stackframe_intro : + forall r m pc asr asa asr' asa' + (DISABLE_RAM: disable_ram (mod_ram (transf_module m)) asr') + (MATCH_ASSOC: match_assocmaps (max_reg_module m + 1) asr asr') + (MATCH_ARRS: match_arrs asa asa') + (MATCH_EMPT1: match_empty_size m asa) + (MATCH_EMPT2: match_empty_size m asa') + (MATCH_RES: r < mod_st m), + match_stackframes (Stackframe r m pc asr asa) + (Stackframe r (transf_module m) pc asr' asa'). + +Inductive match_states : state -> state -> Prop := +| match_state : + forall res res' m st asr asr' asa asa' + (ASSOC: match_assocmaps (max_reg_module m + 1) asr asr') + (ARRS: match_arrs asa asa') + (STACKS: list_forall2 match_stackframes res res') + (ARRS_SIZE: match_empty_size m asa) + (ARRS_SIZE2: match_empty_size m asa') + (DISABLE_RAM: disable_ram (mod_ram (transf_module m)) asr'), + match_states (State res m st asr asa) + (State res' (transf_module m) st asr' asa') +| match_returnstate : + forall res res' i + (STACKS: list_forall2 match_stackframes res res'), + match_states (Returnstate res i) (Returnstate res' i) +| match_initial_call : + forall m, + match_states (Callstate nil m nil) + (Callstate nil (transf_module m) nil). +#[local] Hint Constructors match_states : htlproof. + +Definition empty_stack_ram r := + AssocMap.set (ram_mem r) (Array.arr_repeat None (ram_size r)) (AssocMap.empty arr). + +Definition empty_stack' len st := + AssocMap.set st (Array.arr_repeat None len) (AssocMap.empty arr). + +Definition match_empty_size' l s (ar : assocmap_arr) : Prop := + match_arrs_size (empty_stack' l s) ar. +#[local] Hint Unfold match_empty_size : mgen. + +Definition merge_reg_assocs r := + Verilog.mkassociations (Verilog.merge_regs (assoc_nonblocking r) (assoc_blocking r)) empty_assocmap. + +Definition merge_arr_assocs st len r := + Verilog.mkassociations (Verilog.merge_arrs (assoc_nonblocking r) (assoc_blocking r)) (empty_stack' len st). + +Inductive match_reg_assocs : positive -> reg_associations -> reg_associations -> Prop := + match_reg_association: + forall p rab rab' ran ran', + match_assocmaps p rab rab' -> + match_assocmaps p ran ran' -> + match_reg_assocs p (mkassociations rab ran) (mkassociations rab' ran'). + +Inductive match_arr_assocs : arr_associations -> arr_associations -> Prop := + match_arr_association: + forall rab rab' ran ran', + match_arrs rab rab' -> + match_arrs ran ran' -> + match_arr_assocs (mkassociations rab ran) (mkassociations rab' ran'). + +Ltac mgen_crush := crush; eauto with mgen. + +Lemma match_assocmaps_equiv : forall p a, match_assocmaps p a a. +Proof. constructor; auto. Qed. +#[local] Hint Resolve match_assocmaps_equiv : mgen. + +Lemma match_arrs_equiv : forall a, match_arrs a a. +Proof. econstructor; mgen_crush. Qed. +#[local] Hint Resolve match_arrs_equiv : mgen. + +Lemma match_reg_assocs_equiv : forall p a, match_reg_assocs p a a. +Proof. destruct a; constructor; mgen_crush. Qed. +#[local] Hint Resolve match_reg_assocs_equiv : mgen. + +Lemma match_arr_assocs_equiv : forall a, match_arr_assocs a a. +Proof. destruct a; constructor; mgen_crush. Qed. +#[local] Hint Resolve match_arr_assocs_equiv : mgen. + +Lemma match_arrs_size_equiv : forall a, match_arrs_size a a. +Proof. intros; repeat econstructor; eauto. Qed. +#[local] Hint Resolve match_arrs_size_equiv : mgen. + +Lemma match_stacks_equiv : + forall m s l, + mod_stk m = s -> + mod_stk_len m = l -> + empty_stack' l s = empty_stack m. +Proof. unfold empty_stack', empty_stack; mgen_crush. Qed. +Hint Rewrite match_stacks_equiv : mgen. + +Lemma match_assocmaps_max1 : + forall p p' a b, + match_assocmaps (Pos.max p' p) a b -> + match_assocmaps p a b. +Proof. + intros. inv H. constructor. intros. + apply H0. lia. +Qed. +#[local] Hint Resolve match_assocmaps_max1 : mgen. + +Lemma match_assocmaps_max2 : + forall p p' a b, + match_assocmaps (Pos.max p p') a b -> + match_assocmaps p a b. +Proof. + intros. inv H. constructor. intros. + apply H0. lia. +Qed. +#[local] Hint Resolve match_assocmaps_max2 : mgen. + +Lemma match_assocmaps_ge : + forall p p' a b, + match_assocmaps p' a b -> + p <= p' -> + match_assocmaps p a b. +Proof. + intros. inv H. constructor. intros. + apply H1. lia. +Qed. +#[local] Hint Resolve match_assocmaps_ge : mgen. + +Lemma match_reg_assocs_max1 : + forall p p' a b, + match_reg_assocs (Pos.max p' p) a b -> + match_reg_assocs p a b. +Proof. intros; inv H; econstructor; mgen_crush. Qed. +#[local] Hint Resolve match_reg_assocs_max1 : mgen. + +Lemma match_reg_assocs_max2 : + forall p p' a b, + match_reg_assocs (Pos.max p p') a b -> + match_reg_assocs p a b. +Proof. intros; inv H; econstructor; mgen_crush. Qed. +#[local] Hint Resolve match_reg_assocs_max2 : mgen. + +Lemma match_reg_assocs_ge : + forall p p' a b, + match_reg_assocs p' a b -> + p <= p' -> + match_reg_assocs p a b. +Proof. intros; inv H; econstructor; mgen_crush. Qed. +#[local] Hint Resolve match_reg_assocs_ge : mgen. + +Definition forall_ram (P: reg -> Prop) ram := + P (ram_en ram) + /\ P (ram_u_en ram) + /\ P (ram_addr ram) + /\ P (ram_wr_en ram) + /\ P (ram_d_in ram) + /\ P (ram_d_out ram). + +Lemma forall_ram_lt : + forall m r, + (mod_ram m) = Some r -> + forall_ram (fun x => x < max_reg_module m + 1) r. +Proof. + assert (X: forall a b c, a < b + 1 -> a < Pos.max c b + 1) by lia. + unfold forall_ram; simplify; unfold HTL.max_reg_module; repeat apply X; + unfold HTL.max_reg_ram; rewrite H; try lia. +Qed. +#[local] Hint Resolve forall_ram_lt : mgen. + +Definition exec_all d_s c_s rs1 ar1 rs3 ar3 := + exists f rs2 ar2, + stmnt_runp f rs1 ar1 c_s rs2 ar2 + /\ stmnt_runp f rs2 ar2 d_s rs3 ar3. + +Definition exec_all_ram r d_s c_s rs1 ar1 rs4 ar4 := + exists f rs2 ar2 rs3 ar3, + stmnt_runp f rs1 ar1 c_s rs2 ar2 + /\ stmnt_runp f rs2 ar2 d_s rs3 ar3 + /\ exec_ram (merge_reg_assocs rs3) (merge_arr_assocs (ram_mem r) (ram_size r) ar3) (Some r) rs4 ar4. + +Lemma merge_reg_idempotent : + forall rs, merge_reg_assocs (merge_reg_assocs rs) = merge_reg_assocs rs. +Proof. auto. Qed. +Hint Rewrite merge_reg_idempotent : mgen. + +Lemma merge_arr_idempotent : + forall ar st len v v', + (assoc_nonblocking ar)!st = Some v -> + (assoc_blocking ar)!st = Some v' -> + arr_length v' = len -> + arr_length v = len -> + (assoc_blocking (merge_arr_assocs st len (merge_arr_assocs st len ar)))!st + = (assoc_blocking (merge_arr_assocs st len ar))!st + /\ (assoc_nonblocking (merge_arr_assocs st len (merge_arr_assocs st len ar)))!st + = (assoc_nonblocking (merge_arr_assocs st len ar))!st. +Proof. + split; simplify; eauto. + unfold merge_arrs. + rewrite AssocMap.gcombine by reflexivity. + unfold empty_stack'. + rewrite AssocMap.gss. + setoid_rewrite merge_arr_empty2; auto. + rewrite AssocMap.gcombine by reflexivity. + unfold merge_arr, arr. + rewrite H. rewrite H0. auto. + unfold combine. + simplify. + rewrite list_combine_length. + rewrite (arr_wf v). rewrite (arr_wf v'). + lia. +Qed. + +Lemma empty_arr : + forall m s, + (exists l, (empty_stack m) ! s = Some (arr_repeat None l)) + \/ (empty_stack m) ! s = None. +Proof. + unfold empty_stack. simplify. + destruct (Pos.eq_dec s (mod_stk m)); subst. + left. eexists. apply AssocMap.gss. + right. rewrite AssocMap.gso; auto. apply AssocMap.gempty. +Qed. + +Lemma merge_arr_empty': + forall m ar s v, + match_empty_size m ar -> + (merge_arrs (empty_stack m) ar) ! s = v -> + ar ! s = v. +Proof. + inversion 1; subst. + pose proof (empty_arr m s). + simplify. + destruct (merge_arrs (empty_stack m) ar) ! s eqn:?; subst. + - inv H3. inv H4. + learn H3 as H5. apply H0 in H5. inv H5. simplify. + unfold merge_arrs in *. rewrite AssocMap.gcombine in Heqo; auto. + rewrite H3 in Heqo. erewrite merge_arr_empty2 in Heqo. auto. eauto. + rewrite list_repeat_len in H6. auto. + learn H4 as H6. apply H2 in H6. + unfold merge_arrs in *. rewrite AssocMap.gcombine in Heqo; auto. + rewrite H4 in Heqo. unfold Verilog.arr in *. rewrite H6 in Heqo. + discriminate. + - inv H3. inv H4. learn H3 as H4. apply H0 in H4. inv H4. simplify. + rewrite list_repeat_len in H6. + unfold merge_arrs in *. rewrite AssocMap.gcombine in Heqo; auto. rewrite H3 in Heqo. + unfold Verilog.arr in *. rewrite H4 in Heqo. + discriminate. + apply H2 in H4; auto. +Qed. + +Lemma merge_arr_empty : + forall m ar ar', + match_empty_size m ar -> + match_arrs ar ar' -> + match_arrs (merge_arrs (empty_stack m) ar) ar'. +Proof. + inversion 1; subst; inversion 1; subst; + econstructor; intros; apply merge_arr_empty' in H6; auto. +Qed. +#[local] Hint Resolve merge_arr_empty : mgen. + +Lemma merge_arr_empty'': + forall m ar s v, + match_empty_size m ar -> + ar ! s = v -> + (merge_arrs (empty_stack m) ar) ! s = v. +Proof. + inversion 1; subst. + pose proof (empty_arr m s). + simplify. + destruct (merge_arrs (empty_stack m) ar) ! s eqn:?; subst. + - inv H3. inv H4. + learn H3 as H5. apply H0 in H5. inv H5. simplify. + unfold merge_arrs in *. rewrite AssocMap.gcombine in Heqo; auto. + rewrite H3 in Heqo. erewrite merge_arr_empty2 in Heqo. auto. eauto. + rewrite list_repeat_len in H6. auto. + learn H4 as H6. apply H2 in H6. + unfold merge_arrs in *. rewrite AssocMap.gcombine in Heqo; auto. + rewrite H4 in Heqo. unfold Verilog.arr in *. rewrite H6 in Heqo. + discriminate. + - inv H3. inv H4. learn H3 as H4. apply H0 in H4. inv H4. simplify. + rewrite list_repeat_len in H6. + unfold merge_arrs in *. rewrite AssocMap.gcombine in Heqo; auto. rewrite H3 in Heqo. + unfold Verilog.arr in *. rewrite H4 in Heqo. + discriminate. + apply H2 in H4; auto. +Qed. + +Lemma merge_arr_empty_match : + forall m ar, + match_empty_size m ar -> + match_empty_size m (merge_arrs (empty_stack m) ar). +Proof. + inversion 1; subst. + constructor; simplify. + learn H3 as H4. apply H0 in H4. inv H4. simplify. + eexists; split; eauto. apply merge_arr_empty''; eauto. + apply merge_arr_empty' in H3; auto. + split; simplify. + unfold merge_arrs in H3. rewrite AssocMap.gcombine in H3; auto. + unfold merge_arr in *. + destruct (empty_stack m) ! s eqn:?; + destruct ar ! s; try discriminate; eauto. + apply merge_arr_empty''; auto. apply H2 in H3; auto. +Qed. +#[local] Hint Resolve merge_arr_empty_match : mgen. + +Definition ram_present {A: Type} ar r v v' := + (assoc_nonblocking ar)!(ram_mem r) = Some v + /\ @arr_length A v = ram_size r + /\ (assoc_blocking ar)!(ram_mem r) = Some v' + /\ arr_length v' = ram_size r. + +Lemma find_assoc_get : + forall rs r trs, + rs ! r = trs ! r -> + rs # r = trs # r. +Proof. + intros; unfold find_assocmap, AssocMapExt.get_default; rewrite H; auto. +Qed. +#[local] Hint Resolve find_assoc_get : mgen. + +Lemma find_assoc_get2 : + forall rs p r v trs, + (forall r, r < p -> rs ! r = trs ! r) -> + r < p -> + rs # r = v -> + trs # r = v. +Proof. + intros; unfold find_assocmap, AssocMapExt.get_default; rewrite <- H; auto. +Qed. +#[local] Hint Resolve find_assoc_get2 : mgen. + +Lemma get_assoc_gt : + forall A (rs : AssocMap.t A) p r v trs, + (forall r, r < p -> rs ! r = trs ! r) -> + r < p -> + rs ! r = v -> + trs ! r = v. +Proof. intros. rewrite <- H; auto. Qed. +#[local] Hint Resolve get_assoc_gt : mgen. + +Lemma expr_runp_matches : + forall f rs ar e v, + expr_runp f rs ar e v -> + forall trs tar, + match_assocmaps (max_reg_expr e + 1) rs trs -> + match_arrs ar tar -> + expr_runp f trs tar e v. +Proof. + induction 1. + - intros. econstructor. + - intros. econstructor. inv H0. symmetry. + apply find_assoc_get. + apply H2. crush. + - intros. econstructor. apply IHexpr_runp; eauto. + inv H1. constructor. simplify. + assert (forall a b c, a < b + 1 -> a < Pos.max c b + 1) by lia. + eapply H4 in H1. eapply H3 in H1. auto. + inv H2. + unfold arr_assocmap_lookup in *. + destruct (stack ! r) eqn:?; [|discriminate]. + inv H1. + inv H0. + eapply H3 in Heqo. inv Heqo. inv H0. + unfold arr in *. rewrite H1. inv H5. + rewrite H0. auto. + - intros. econstructor; eauto. eapply IHexpr_runp1; eauto. + econstructor. inv H2. intros. + assert (forall a b c, a < b + 1 -> a < Pos.max b c + 1) by lia. + simplify. + eapply H5 in H2. apply H4 in H2. auto. + apply IHexpr_runp2; eauto. + econstructor. inv H2. intros. + assert (forall a b c, a < b + 1 -> a < Pos.max c b + 1) by lia. + simplify. eapply H5 in H2. apply H4 in H2. auto. + - intros. econstructor; eauto. + - intros. econstructor; eauto. apply IHexpr_runp1; eauto. + constructor. inv H2. intros. simplify. + assert (forall a b c, a < b + 1 -> a < Pos.max b c + 1) by lia. + eapply H5 in H2. apply H4 in H2. auto. + apply IHexpr_runp2; eauto. simplify. + assert (forall a b c d, a < b + 1 -> a < Pos.max c (Pos.max b d) + 1) by lia. + constructor. intros. eapply H4 in H5. inv H2. apply H6 in H5. auto. + - intros. eapply erun_Vternary_false. apply IHexpr_runp1; eauto. constructor. inv H2. + intros. simplify. assert (forall a b c, a < b + 1 -> a < Pos.max b c + 1) by lia. + eapply H5 in H2. apply H4 in H2. auto. + apply IHexpr_runp2; eauto. econstructor. inv H2. simplify. + assert (forall a b c d, a < b + 1 -> a < Pos.max c (Pos.max d b) + 1) by lia. + eapply H5 in H2. apply H4 in H2. auto. auto. +Qed. +#[local] Hint Resolve expr_runp_matches : mgen. + +Lemma expr_runp_matches2 : + forall f rs ar e v p, + expr_runp f rs ar e v -> + max_reg_expr e < p -> + forall trs tar, + match_assocmaps p rs trs -> + match_arrs ar tar -> + expr_runp f trs tar e v. +Proof. + intros. eapply expr_runp_matches; eauto. + assert (max_reg_expr e + 1 <= p) by lia. + mgen_crush. +Qed. +#[local] Hint Resolve expr_runp_matches2 : mgen. + +Lemma match_assocmaps_gss : + forall p rab rab' r rhsval, + match_assocmaps p rab rab' -> + match_assocmaps p rab # r <- rhsval rab' # r <- rhsval. +Proof. + intros. inv H. econstructor. + intros. + unfold find_assocmap. unfold AssocMapExt.get_default. + destruct (Pos.eq_dec r r0); subst. + repeat rewrite PTree.gss; auto. + repeat rewrite PTree.gso; auto. +Qed. +#[local] Hint Resolve match_assocmaps_gss : mgen. + +Lemma match_assocmaps_gt : + forall p s ra ra' v, + p <= s -> + match_assocmaps p ra ra' -> + match_assocmaps p ra (ra' # s <- v). +Proof. + intros. inv H0. constructor. + intros. rewrite AssocMap.gso; try lia. apply H1; auto. +Qed. +#[local] Hint Resolve match_assocmaps_gt : mgen. + +Lemma match_reg_assocs_block : + forall p rab rab' r rhsval, + match_reg_assocs p rab rab' -> + match_reg_assocs p (block_reg r rab rhsval) (block_reg r rab' rhsval). +Proof. inversion 1; econstructor; eauto with mgen. Qed. +#[local] Hint Resolve match_reg_assocs_block : mgen. + +Lemma match_reg_assocs_nonblock : + forall p rab rab' r rhsval, + match_reg_assocs p rab rab' -> + match_reg_assocs p (nonblock_reg r rab rhsval) (nonblock_reg r rab' rhsval). +Proof. inversion 1; econstructor; eauto with mgen. Qed. +#[local] Hint Resolve match_reg_assocs_nonblock : mgen. + +Lemma some_inj : + forall A (x: A) y, + Some x = Some y -> + x = y. +Proof. inversion 1; auto. Qed. + +Lemma arrs_present : + forall r i v ar arr, + (arr_assocmap_set r i v ar) ! r = Some arr -> + exists b, ar ! r = Some b. +Proof. + intros. unfold arr_assocmap_set in *. + destruct ar!r eqn:?. + rewrite AssocMap.gss in H. + inv H. eexists. auto. rewrite Heqo in H. discriminate. +Qed. + +Ltac inv_exists := + match goal with + | H: exists _, _ |- _ => inv H + end. + +Lemma array_get_error_bound_gt : + forall A i (a : Array A), + (i >= arr_length a)%nat -> + array_get_error i a = None. +Proof. + intros. unfold array_get_error. + apply nth_error_None. destruct a. simplify. + lia. +Qed. +#[local] Hint Resolve array_get_error_bound_gt : mgen. + +Lemma array_get_error_each : + forall A addr i (v : A) a x, + arr_length a = arr_length x -> + array_get_error addr a = array_get_error addr x -> + array_get_error addr (array_set i v a) = array_get_error addr (array_set i v x). +Proof. + intros. + destruct (Nat.eq_dec addr i); subst. + destruct (lt_dec i (arr_length a)). + repeat rewrite array_get_error_set_bound; auto. + rewrite <- H. auto. + apply Nat.nlt_ge in n. + repeat rewrite array_get_error_bound_gt; auto. + rewrite <- array_set_len. rewrite <- H. lia. + repeat rewrite array_gso; auto. +Qed. +#[local] Hint Resolve array_get_error_each : mgen. + +Lemma match_arrs_gss : + forall ar ar' r v i, + match_arrs ar ar' -> + match_arrs (arr_assocmap_set r i v ar) (arr_assocmap_set r i v ar'). +Proof. + Ltac mag_tac := + match goal with + | H: ?ar ! _ = Some _, H2: forall s arr, ?ar ! s = Some arr -> _ |- _ => + let H3 := fresh "H" in + learn H as H3; apply H2 in H3; inv_exists; simplify + | H: ?ar ! _ = None, H2: forall s, ?ar ! s = None -> _ |- _ => + let H3 := fresh "H" in + learn H as H3; apply H2 in H3; inv_exists; simplify + | H: ?ar ! _ = _ |- context[match ?ar ! _ with _ => _ end] => + unfold Verilog.arr in *; rewrite H + | H: ?ar ! _ = _, H2: context[match ?ar ! _ with _ => _ end] |- _ => + unfold Verilog.arr in *; rewrite H in H2 + | H: context[(_ # ?s <- _) ! ?s] |- _ => rewrite AssocMap.gss in H + | H: context[(_ # ?r <- _) ! ?s], H2: ?r <> ?s |- _ => rewrite AssocMap.gso in H; auto + | |- context[(_ # ?s <- _) ! ?s] => rewrite AssocMap.gss + | H: ?r <> ?s |- context[(_ # ?r <- _) ! ?s] => rewrite AssocMap.gso; auto + end. + intros. + inv H. econstructor; simplify. + destruct (Pos.eq_dec r s); subst. + - unfold arr_assocmap_set, Verilog.arr in *. + destruct ar!s eqn:?. + mag_tac. + econstructor; simplify. + repeat mag_tac; auto. + intros. repeat mag_tac. simplify. + apply array_get_error_each; auto. + repeat mag_tac; crush. + repeat mag_tac; crush. + - unfold arr_assocmap_set in *. + destruct ar ! r eqn:?. rewrite AssocMap.gso in H; auto. + apply H0 in Heqo. apply H0 in H. repeat inv_exists. simplify. + econstructor. unfold Verilog.arr in *. rewrite H3. simplify. + rewrite AssocMap.gso; auto. eauto. intros. auto. auto. + apply H1 in Heqo. apply H0 in H. repeat inv_exists; simplify. + econstructor. unfold Verilog.arr in *. rewrite Heqo. simplify; eauto. + - destruct (Pos.eq_dec r s); unfold arr_assocmap_set, Verilog.arr in *; simplify; subst. + destruct ar!s eqn:?; repeat mag_tac; crush. + apply H1 in H. mag_tac; crush. + destruct ar!r eqn:?; repeat mag_tac; crush. + apply H1 in Heqo. repeat mag_tac; auto. +Qed. +#[local] Hint Resolve match_arrs_gss : mgen. + +Lemma match_arr_assocs_block : + forall rab rab' r i rhsval, + match_arr_assocs rab rab' -> + match_arr_assocs (block_arr r i rab rhsval) (block_arr r i rab' rhsval). +Proof. inversion 1; econstructor; eauto with mgen. Qed. +#[local] Hint Resolve match_arr_assocs_block : mgen. + +Lemma match_arr_assocs_nonblock : + forall rab rab' r i rhsval, + match_arr_assocs rab rab' -> + match_arr_assocs (nonblock_arr r i rab rhsval) (nonblock_arr r i rab' rhsval). +Proof. inversion 1; econstructor; eauto with mgen. Qed. +#[local] Hint Resolve match_arr_assocs_nonblock : mgen. + +Lemma match_states_same : + forall f rs1 ar1 c rs2 ar2 p, + stmnt_runp f rs1 ar1 c rs2 ar2 -> + max_reg_stmnt c < p -> + forall trs1 tar1, + match_reg_assocs p rs1 trs1 -> + match_arr_assocs ar1 tar1 -> + exists trs2 tar2, + stmnt_runp f trs1 tar1 c trs2 tar2 + /\ match_reg_assocs p rs2 trs2 + /\ match_arr_assocs ar2 tar2. +Proof. + Ltac match_states_same_facts := + match goal with + | H: match_reg_assocs _ _ _ |- _ => + let H2 := fresh "H" in + learn H as H2; inv H2 + | H: match_arr_assocs _ _ |- _ => + let H2 := fresh "H" in + learn H as H2; inv H2 + | H1: context[exists _, _], H2: context[exists _, _] |- _ => + learn H1; learn H2; + exploit H1; mgen_crush; exploit H2; mgen_crush + | H1: context[exists _, _] |- _ => + learn H1; exploit H1; mgen_crush + end. + Ltac match_states_same_tac := + match goal with + | |- exists _, _ => econstructor + | |- _ < _ => lia + | H: context[_ <> _] |- stmnt_runp _ _ _ (Vcase _ (Stmntcons _ _ _) _) _ _ => + eapply stmnt_runp_Vcase_nomatch + | |- stmnt_runp _ _ _ (Vcase _ (Stmntcons _ _ _) _) _ _ => + eapply stmnt_runp_Vcase_match + | H: valueToBool _ = false |- stmnt_runp _ _ _ _ _ _ => + eapply stmnt_runp_Vcond_false + | |- stmnt_runp _ _ _ _ _ _ => econstructor + | |- expr_runp _ _ _ _ _ => eapply expr_runp_matches2 + end; mgen_crush; try lia. + induction 1; simplify; repeat match_states_same_facts; + try destruct_match; try solve [repeat match_states_same_tac]. + - inv H. exists (block_reg r {| assoc_blocking := rab'; assoc_nonblocking := ran' |} rhsval); + repeat match_states_same_tac; econstructor. + - exists (nonblock_reg r {| assoc_blocking := rab'; assoc_nonblocking := ran' |} rhsval); + repeat match_states_same_tac; inv H; econstructor. + - econstructor. exists (block_arr r i {| assoc_blocking := rab'0; assoc_nonblocking := ran'0 |} rhsval). + simplify; repeat match_states_same_tac. inv H. econstructor. + repeat match_states_same_tac. eauto. mgen_crush. + - econstructor. exists (nonblock_arr r i {| assoc_blocking := rab'0; assoc_nonblocking := ran'0 |} rhsval). + simplify; repeat match_states_same_tac. inv H. econstructor. + repeat match_states_same_tac. eauto. mgen_crush. +Qed. + +Lemma match_reg_assocs_merge : + forall p rs rs', + match_reg_assocs p rs rs' -> + match_reg_assocs p (merge_reg_assocs rs) (merge_reg_assocs rs'). +Proof. + inversion 1. + econstructor; econstructor; crush. inv H3. inv H. + inv H7. inv H9. + unfold merge_regs. + destruct (ran!r) eqn:?; destruct (rab!r) eqn:?. + erewrite AssocMapExt.merge_correct_1; eauto. + erewrite AssocMapExt.merge_correct_1; eauto. + rewrite <- H2; eauto. + erewrite AssocMapExt.merge_correct_1; eauto. + erewrite AssocMapExt.merge_correct_1; eauto. + rewrite <- H2; eauto. + erewrite AssocMapExt.merge_correct_2; eauto. + erewrite AssocMapExt.merge_correct_2; eauto. + rewrite <- H2; eauto. + rewrite <- H; eauto. + erewrite AssocMapExt.merge_correct_3; eauto. + erewrite AssocMapExt.merge_correct_3; eauto. + rewrite <- H2; eauto. + rewrite <- H; eauto. +Qed. +#[local] Hint Resolve match_reg_assocs_merge : mgen. + +Lemma transf_not_changed : + forall state ram n d c i d_s c_s, + (forall e1 e2 r, d_s <> Vnonblock (Vvari r e1) e2) -> + (forall e1 e2 r, d_s <> Vnonblock e1 (Vvari r e2)) -> + d!i = Some d_s -> + c!i = Some c_s -> + transf_maps state ram (i, n) (d, c) = (d, c). +Proof. intros; unfold transf_maps; repeat destruct_match; mgen_crush. Qed. + +Lemma transf_not_changed_neq : + forall state ram n d c d' c' i a d_s c_s, + transf_maps state ram (a, n) (d, c) = (d', c') -> + d!i = Some d_s -> + c!i = Some c_s -> + a <> i -> n <> i -> + d'!i = Some d_s /\ c'!i = Some c_s. +Proof. + unfold transf_maps; intros; repeat destruct_match; mgen_crush; + match goal with [ H: (_, _) = (_, _) |- _ ] => inv H end; + repeat (rewrite AssocMap.gso; auto). +Qed. + +Lemma forall_gt : + forall l, Forall (Pos.ge (fold_right Pos.max 1 l)) l. +Proof. + induction l; auto. + constructor. inv IHl; simplify; lia. + simplify. destruct (Pos.max_dec a (fold_right Pos.max 1 l)). + rewrite e. apply Pos.max_l_iff in e. apply Pos.le_ge in e. + apply Forall_forall. rewrite Forall_forall in IHl. + intros. + assert (X: forall a b c, a >= c -> c >= b -> a >= b) by lia. + apply X with (b := x) in e; auto. + rewrite e; auto. +Qed. + +Lemma max_index_list : + forall A (l : list (positive * A)) i d_s, + In (i, d_s) l -> + list_norepet (map fst l) -> + i <= fold_right Pos.max 1 (map fst l). +Proof. + induction l; crush. + inv H. inv H0. simplify. lia. + inv H0. + let H := fresh "H" in + assert (H: forall a b c, c <= b -> c <= Pos.max a b) by lia; + apply H; eapply IHl; eauto. +Qed. + +Lemma max_index : + forall A d i (d_s: A), d ! i = Some d_s -> i <= max_pc d. +Proof. + unfold max_pc; + eauto using max_index_list, + PTree.elements_correct, PTree.elements_keys_norepet. +Qed. + +Lemma max_index_2' : + forall l i, i > fold_right Pos.max 1 l -> Forall (Pos.gt i) l. +Proof. induction l; crush; constructor; [|apply IHl]; lia. Qed. + +Lemma max_index_2'' : + forall l i, Forall (Pos.gt i) l -> ~ In i l. +Proof. + induction l; crush. unfold not in *. + intros. inv H0. inv H. lia. eapply IHl. + inv H. apply H4. auto. +Qed. + +Lemma elements_correct_none : + forall A am k, + ~ List.In k (List.map (@fst _ A) (AssocMap.elements am)) -> + AssocMap.get k am = None. +Proof. + intros. apply AssocMapExt.elements_correct' in H. unfold not in *. + destruct am ! k eqn:?; auto. exfalso. apply H. eexists. auto. +Qed. +#[local] Hint Resolve elements_correct_none : assocmap. + +Lemma max_index_2 : + forall A (d: AssocMap.t A) i, i > max_pc d -> d ! i = None. +Proof. + intros. unfold max_pc in *. apply max_index_2' in H. + apply max_index_2'' in H. apply elements_correct_none. auto. +Qed. + +Definition match_prog (p: program) (tp: program) := + Linking.match_program (fun cu f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p, match_prog p (transf_program p). +Proof. + intros. unfold transf_program, match_prog. + apply Linking.match_transform_program. +Qed. + +Lemma exec_all_Vskip : + forall rs ar, + exec_all Vskip Vskip rs ar rs ar. +Proof. + unfold exec_all. + intros. repeat econstructor. + Unshelve. unfold fext. exact tt. +Qed. + +Lemma match_assocmaps_trans: + forall p rs1 rs2 rs3, + match_assocmaps p rs1 rs2 -> + match_assocmaps p rs2 rs3 -> + match_assocmaps p rs1 rs3. +Proof. + intros. inv H. inv H0. econstructor; eauto. + intros. rewrite H1 by auto. auto. +Qed. + +Lemma match_reg_assocs_trans: + forall p rs1 rs2 rs3, + match_reg_assocs p rs1 rs2 -> + match_reg_assocs p rs2 rs3 -> + match_reg_assocs p rs1 rs3. +Proof. + intros. inv H. inv H0. + econstructor; eapply match_assocmaps_trans; eauto. +Qed. + +Lemma empty_arrs_match : + forall m, + match_arrs (empty_stack m) (empty_stack (transf_module m)). +Proof. + intros; + unfold empty_stack, transf_module; repeat destruct_match; mgen_crush. +Qed. +#[local] Hint Resolve empty_arrs_match : mgen. + +Lemma max_module_stmnts : + forall m, + Pos.max (max_stmnt_tree (mod_controllogic m)) + (max_stmnt_tree (mod_datapath m)) < max_reg_module m + 1. +Proof. intros. unfold max_reg_module. lia. Qed. +#[local] Hint Resolve max_module_stmnts : mgen. + +Lemma transf_module_code : + forall m, + mod_ram m = None -> + transf_code (mod_st m) + {| ram_size := mod_stk_len m; + ram_mem := mod_stk m; + ram_en := max_reg_module m + 2; + ram_addr := max_reg_module m + 1; + ram_wr_en := max_reg_module m + 5; + ram_d_in := max_reg_module m + 3; + ram_d_out := max_reg_module m + 4; + ram_u_en := max_reg_module m + 6; + ram_ordering := ram_wf (max_reg_module m) |} + (mod_datapath m) (mod_controllogic m) + = ((mod_datapath (transf_module m)), mod_controllogic (transf_module m)). +Proof. unfold transf_module; intros; repeat destruct_match; crush. + apply surjective_pairing. Qed. +#[local] Hint Resolve transf_module_code : mgen. + +Lemma transf_module_code_ram : + forall m r, mod_ram m = Some r -> transf_module m = m. +Proof. unfold transf_module; intros; repeat destruct_match; crush. Qed. +#[local] Hint Resolve transf_module_code_ram : mgen. + +Lemma mod_reset_lt : forall m, mod_reset m < max_reg_module m + 1. +Proof. intros; unfold max_reg_module; lia. Qed. +#[local] Hint Resolve mod_reset_lt : mgen. + +Lemma mod_finish_lt : forall m, mod_finish m < max_reg_module m + 1. +Proof. intros; unfold max_reg_module; lia. Qed. +#[local] Hint Resolve mod_finish_lt : mgen. + +Lemma mod_return_lt : forall m, mod_return m < max_reg_module m + 1. +Proof. intros; unfold max_reg_module; lia. Qed. +#[local] Hint Resolve mod_return_lt : mgen. + +Lemma mod_start_lt : forall m, mod_start m < max_reg_module m + 1. +Proof. intros; unfold max_reg_module; lia. Qed. +#[local] Hint Resolve mod_start_lt : mgen. + +Lemma mod_stk_lt : forall m, mod_stk m < max_reg_module m + 1. +Proof. intros; unfold max_reg_module; lia. Qed. +#[local] Hint Resolve mod_stk_lt : mgen. + +Lemma mod_st_lt : forall m, mod_st m < max_reg_module m + 1. +Proof. intros; unfold max_reg_module; lia. Qed. +#[local] Hint Resolve mod_st_lt : mgen. + +Lemma mod_reset_modify : + forall m ar ar' v, + match_assocmaps (max_reg_module m + 1) ar ar' -> + ar ! (mod_reset m) = Some v -> + ar' ! (mod_reset (transf_module m)) = Some v. +Proof. + inversion 1. intros. + unfold transf_module; repeat destruct_match; simplify; + rewrite <- H0; eauto with mgen. +Qed. +#[local] Hint Resolve mod_reset_modify : mgen. + +Lemma mod_finish_modify : + forall m ar ar' v, + match_assocmaps (max_reg_module m + 1) ar ar' -> + ar ! (mod_finish m) = Some v -> + ar' ! (mod_finish (transf_module m)) = Some v. +Proof. + inversion 1. intros. + unfold transf_module; repeat destruct_match; simplify; + rewrite <- H0; eauto with mgen. +Qed. +#[local] Hint Resolve mod_finish_modify : mgen. + +Lemma mod_return_modify : + forall m ar ar' v, + match_assocmaps (max_reg_module m + 1) ar ar' -> + ar ! (mod_return m) = Some v -> + ar' ! (mod_return (transf_module m)) = Some v. +Proof. + inversion 1. intros. + unfold transf_module; repeat destruct_match; simplify; + rewrite <- H0; eauto with mgen. +Qed. +#[local] Hint Resolve mod_return_modify : mgen. + +Lemma mod_start_modify : + forall m ar ar' v, + match_assocmaps (max_reg_module m + 1) ar ar' -> + ar ! (mod_start m) = Some v -> + ar' ! (mod_start (transf_module m)) = Some v. +Proof. + inversion 1. intros. + unfold transf_module; repeat destruct_match; simplify; + rewrite <- H0; eauto with mgen. +Qed. +#[local] Hint Resolve mod_start_modify : mgen. + +Lemma mod_st_modify : + forall m ar ar' v, + match_assocmaps (max_reg_module m + 1) ar ar' -> + ar ! (mod_st m) = Some v -> + ar' ! (mod_st (transf_module m)) = Some v. +Proof. + inversion 1. intros. + unfold transf_module; repeat destruct_match; simplify; + rewrite <- H0; eauto with mgen. +Qed. +#[local] Hint Resolve mod_st_modify : mgen. + +Lemma match_arrs_read : + forall ra ra' addr v mem, + arr_assocmap_lookup ra mem addr = Some v -> + match_arrs ra ra' -> + arr_assocmap_lookup ra' mem addr = Some v. +Proof. + unfold arr_assocmap_lookup. intros. destruct_match; destruct_match; try discriminate. + inv H0. eapply H1 in Heqo0. inv Heqo0. simplify. unfold arr in *. + rewrite H in Heqo. inv Heqo. + rewrite H0. auto. + inv H0. eapply H1 in Heqo0. inv Heqo0. inv H0. unfold arr in *. + rewrite H3 in Heqo. discriminate. +Qed. +#[local] Hint Resolve match_arrs_read : mgen. + +Lemma match_reg_implies_equal : + forall ra ra' p a b c, + Int.eq (ra # a) (ra # b) = c -> + a < p -> b < p -> + match_assocmaps p ra ra' -> + Int.eq (ra' # a) (ra' # b) = c. +Proof. + unfold find_assocmap, AssocMapExt.get_default; intros. + inv H2. destruct (ra ! a) eqn:?; destruct (ra ! b) eqn:?; + repeat rewrite <- H3 by lia; rewrite Heqo; rewrite Heqo0; auto. +Qed. +#[local] Hint Resolve match_reg_implies_equal : mgen. + +Lemma exec_ram_same : + forall rs1 ar1 ram rs2 ar2 p, + exec_ram rs1 ar1 (Some ram) rs2 ar2 -> + forall_ram (fun x => x < p) ram -> + forall trs1 tar1, + match_reg_assocs p rs1 trs1 -> + match_arr_assocs ar1 tar1 -> + exists trs2 tar2, + exec_ram trs1 tar1 (Some ram) trs2 tar2 + /\ match_reg_assocs p rs2 trs2 + /\ match_arr_assocs ar2 tar2. +Proof. + Ltac exec_ram_same_facts := + match goal with + | H: match_reg_assocs _ _ _ |- _ => let H2 := fresh "H" in learn H as H2; inv H2 + | H: match_assocmaps _ _ _ |- _ => let H2 := fresh "H" in learn H as H2; inv H2 + | H: match_arr_assocs _ _ |- _ => let H2 := fresh "H" in learn H as H2; inv H2 + | H: match_arrs _ _ |- _ => let H2 := fresh "H" in learn H as H2; inv H2 + end. + inversion 1; subst; destruct ram; unfold forall_ram; simplify; repeat exec_ram_same_facts. + - repeat (econstructor; mgen_crush). + - do 2 econstructor; simplify; + [eapply exec_ram_Some_write; [ apply H1 | apply H2 | | | | | ] | | ]; + mgen_crush. + - do 2 econstructor; simplify; [eapply exec_ram_Some_read | | ]; + repeat (try econstructor; mgen_crush). +Qed. + +Lemma match_assocmaps_merge : + forall p nasr basr nasr' basr', + match_assocmaps p nasr nasr' -> + match_assocmaps p basr basr' -> + match_assocmaps p (merge_regs nasr basr) (merge_regs nasr' basr'). +Proof. + unfold merge_regs. + intros. inv H. inv H0. econstructor. + intros. + destruct nasr ! r eqn:?; destruct basr ! r eqn:?. + erewrite AssocMapExt.merge_correct_1; mgen_crush. + erewrite AssocMapExt.merge_correct_1; mgen_crush. + erewrite AssocMapExt.merge_correct_1; mgen_crush. + erewrite AssocMapExt.merge_correct_1; mgen_crush. + erewrite AssocMapExt.merge_correct_2; mgen_crush. + erewrite AssocMapExt.merge_correct_2; mgen_crush. + erewrite AssocMapExt.merge_correct_3; mgen_crush. + erewrite AssocMapExt.merge_correct_3; mgen_crush. +Qed. +#[local] Hint Resolve match_assocmaps_merge : mgen. + +Lemma list_combine_nth_error1 : + forall l l' addr v, + length l = length l' -> + nth_error l addr = Some (Some v) -> + nth_error (list_combine merge_cell l l') addr = Some (Some v). +Proof. induction l; destruct l'; destruct addr; crush. Qed. + +Lemma list_combine_nth_error2 : + forall l' l addr v, + length l = length l' -> + nth_error l addr = Some None -> + nth_error l' addr = Some (Some v) -> + nth_error (list_combine merge_cell l l') addr = Some (Some v). +Proof. induction l'; try rewrite nth_error_nil in *; destruct l; destruct addr; crush. Qed. + +Lemma list_combine_nth_error3 : + forall l l' addr, + length l = length l' -> + nth_error l addr = Some None -> + nth_error l' addr = Some None -> + nth_error (list_combine merge_cell l l') addr = Some None. +Proof. induction l; destruct l'; destruct addr; crush. Qed. + +Lemma list_combine_nth_error4 : + forall l l' addr, + length l = length l' -> + nth_error l addr = None -> + nth_error (list_combine merge_cell l l') addr = None. +Proof. induction l; destruct l'; destruct addr; crush. Qed. + +Lemma list_combine_nth_error5 : + forall l l' addr, + length l = length l' -> + nth_error l' addr = None -> + nth_error (list_combine merge_cell l l') addr = None. +Proof. induction l; destruct l'; destruct addr; crush. Qed. + +Lemma array_get_error_merge1 : + forall a a0 addr v, + arr_length a = arr_length a0 -> + array_get_error addr a = Some (Some v) -> + array_get_error addr (combine merge_cell a a0) = Some (Some v). +Proof. + unfold array_get_error, combine in *; intros; + apply list_combine_nth_error1; destruct a; destruct a0; crush. +Qed. + +Lemma array_get_error_merge2 : + forall a a0 addr v, + arr_length a = arr_length a0 -> + array_get_error addr a0 = Some (Some v) -> + array_get_error addr a = Some None -> + array_get_error addr (combine merge_cell a a0) = Some (Some v). +Proof. + unfold array_get_error, combine in *; intros; + apply list_combine_nth_error2; destruct a; destruct a0; crush. +Qed. + +Lemma array_get_error_merge3 : + forall a a0 addr, + arr_length a = arr_length a0 -> + array_get_error addr a0 = Some None -> + array_get_error addr a = Some None -> + array_get_error addr (combine merge_cell a a0) = Some None. +Proof. + unfold array_get_error, combine in *; intros; + apply list_combine_nth_error3; destruct a; destruct a0; crush. +Qed. + +Lemma array_get_error_merge4 : + forall a a0 addr, + arr_length a = arr_length a0 -> + array_get_error addr a = None -> + array_get_error addr (combine merge_cell a a0) = None. +Proof. + unfold array_get_error, combine in *; intros; + apply list_combine_nth_error4; destruct a; destruct a0; crush. +Qed. + +Lemma array_get_error_merge5 : + forall a a0 addr, + arr_length a = arr_length a0 -> + array_get_error addr a0 = None -> + array_get_error addr (combine merge_cell a a0) = None. +Proof. + unfold array_get_error, combine in *; intros; + apply list_combine_nth_error5; destruct a; destruct a0; crush. +Qed. + +Lemma match_arrs_merge' : + forall addr nasa basa arr s x x0 a a0 nasa' basa', + (AssocMap.combine merge_arr nasa basa) ! s = Some arr -> + nasa ! s = Some a -> + basa ! s = Some a0 -> + nasa' ! s = Some x0 -> + basa' ! s = Some x -> + arr_length x = arr_length x0 -> + array_get_error addr a0 = array_get_error addr x -> + arr_length a0 = arr_length x -> + array_get_error addr a = array_get_error addr x0 -> + arr_length a = arr_length x0 -> + array_get_error addr arr = array_get_error addr (combine merge_cell x0 x). +Proof. + intros. rewrite AssocMap.gcombine in H by auto. + unfold merge_arr in H. + rewrite H0 in H. rewrite H1 in H. inv H. + destruct (array_get_error addr a0) eqn:?; destruct (array_get_error addr a) eqn:?. + destruct o; destruct o0. + erewrite array_get_error_merge1; eauto. erewrite array_get_error_merge1; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. + erewrite array_get_error_merge2; eauto. erewrite array_get_error_merge2; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. + erewrite array_get_error_merge1; eauto. erewrite array_get_error_merge1; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. + erewrite array_get_error_merge3; eauto. erewrite array_get_error_merge3; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. + erewrite array_get_error_merge4; eauto. erewrite array_get_error_merge4; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. + erewrite array_get_error_merge5; eauto. erewrite array_get_error_merge5; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. + erewrite array_get_error_merge5; eauto. erewrite array_get_error_merge5; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. +Qed. + +Lemma match_arrs_merge : + forall nasa nasa' basa basa', + match_arrs_size nasa basa -> + match_arrs nasa nasa' -> + match_arrs basa basa' -> + match_arrs (merge_arrs nasa basa) (merge_arrs nasa' basa'). +Proof. + unfold merge_arrs. + intros. inv H. inv H0. inv H1. econstructor. + - intros. destruct nasa ! s eqn:?; destruct basa ! s eqn:?; unfold Verilog.arr in *. + + pose proof Heqo. apply H in Heqo. pose proof Heqo0. apply H0 in Heqo0. + repeat inv_exists. simplify. + eexists. simplify. rewrite AssocMap.gcombine; eauto. + unfold merge_arr. unfold Verilog.arr in *. rewrite H11. rewrite H12. auto. + intros. eapply match_arrs_merge'; eauto. eapply H2 in H7; eauto. + inv_exists. simplify. congruence. + rewrite AssocMap.gcombine in H1; auto. unfold merge_arr in H1. + rewrite H7 in H1. rewrite H8 in H1. inv H1. + repeat rewrite combine_length; auto. + eapply H2 in H7; eauto. inv_exists; simplify; congruence. + eapply H2 in H7; eauto. inv_exists; simplify; congruence. + + apply H2 in Heqo; inv_exists; crush. + + apply H3 in Heqo0; inv_exists; crush. + + rewrite AssocMap.gcombine in H1 by auto. unfold merge_arr in *. + rewrite Heqo in H1. rewrite Heqo0 in H1. discriminate. + - intros. rewrite AssocMap.gcombine in H1 by auto. unfold merge_arr in H1. + repeat destruct_match; crush. + rewrite AssocMap.gcombine by auto; unfold merge_arr. + apply H5 in Heqo. apply H6 in Heqo0. + unfold Verilog.arr in *. + rewrite Heqo. rewrite Heqo0. auto. +Qed. +#[local] Hint Resolve match_arrs_merge : mgen. + +Lemma match_empty_size_merge : + forall nasa2 basa2 m, + match_empty_size m nasa2 -> + match_empty_size m basa2 -> + match_empty_size m (merge_arrs nasa2 basa2). +Proof. + intros. inv H. inv H0. constructor. + simplify. unfold merge_arrs. rewrite AssocMap.gcombine by auto. + pose proof H0 as H6. apply H1 in H6. inv_exists; simplify. + pose proof H0 as H9. apply H in H9. inv_exists; simplify. + eexists. simplify. unfold merge_arr. unfold Verilog.arr in *. rewrite H6. + rewrite H9. auto. rewrite H8. symmetry. apply combine_length. congruence. + intros. + destruct (nasa2 ! s) eqn:?; destruct (basa2 ! s) eqn:?. + unfold merge_arrs in H0. rewrite AssocMap.gcombine in H0 by auto. + unfold merge_arr in *. setoid_rewrite Heqo in H0. setoid_rewrite Heqo0 in H0. inv H0. + apply H2 in Heqo. apply H4 in Heqo0. repeat inv_exists; simplify. + eexists. simplify. eauto. rewrite list_combine_length. + rewrite (arr_wf a). rewrite (arr_wf a0). lia. + unfold merge_arrs in H0. rewrite AssocMap.gcombine in H0 by auto. + unfold merge_arr in *. setoid_rewrite Heqo in H0. setoid_rewrite Heqo0 in H0. + apply H2 in Heqo. inv_exists; simplify. + econstructor; eauto. + unfold merge_arrs in H0. rewrite AssocMap.gcombine in H0 by auto. + unfold merge_arr in *. setoid_rewrite Heqo in H0. setoid_rewrite Heqo0 in H0. + inv H0. apply H4 in Heqo0. inv_exists; simplify. econstructor; eauto. + unfold merge_arrs in H0. rewrite AssocMap.gcombine in H0 by auto. + unfold merge_arr in *. setoid_rewrite Heqo in H0. setoid_rewrite Heqo0 in H0. + discriminate. + split; intros. + unfold merge_arrs in H0. rewrite AssocMap.gcombine in H0 by auto. + unfold merge_arr in *. repeat destruct_match; crush. apply H5 in Heqo0; auto. + pose proof H0. + apply H5 in H0. + apply H3 in H6. unfold merge_arrs. rewrite AssocMap.gcombine by auto. + setoid_rewrite H0. setoid_rewrite H6. auto. +Qed. +#[local] Hint Resolve match_empty_size_merge : mgen. + +Lemma match_empty_size_match : + forall m nasa2 basa2, + match_empty_size m nasa2 -> + match_empty_size m basa2 -> + match_arrs_size nasa2 basa2. +Proof. + Ltac match_empty_size_match_solve := + match goal with + | H: context[forall s arr, ?ar ! s = Some arr -> _], H2: ?ar ! _ = Some _ |- _ => + let H3 := fresh "H" in + learn H; pose proof H2 as H3; apply H in H3; repeat inv_exists + | H: context[forall s, ?ar ! s = None <-> _], H2: ?ar ! _ = None |- _ => + let H3 := fresh "H" in + learn H; pose proof H2 as H3; apply H in H3 + | H: context[forall s, _ <-> ?ar ! s = None], H2: ?ar ! _ = None |- _ => + let H3 := fresh "H" in + learn H; pose proof H2 as H3; apply H in H3 + | |- exists _, _ => econstructor + | |- _ ! _ = Some _ => eassumption + | |- _ = _ => congruence + | |- _ <-> _ => split + end; simplify. + inversion 1; inversion 1; constructor; simplify; repeat match_empty_size_match_solve. +Qed. +#[local] Hint Resolve match_empty_size_match : mgen. + +Lemma match_get_merge : + forall p ran ran' rab rab' s v, + s < p -> + match_assocmaps p ran ran' -> + match_assocmaps p rab rab' -> + (merge_regs ran rab) ! s = Some v -> + (merge_regs ran' rab') ! s = Some v. +Proof. + intros. + assert (X: match_assocmaps p (merge_regs ran rab) (merge_regs ran' rab')) by auto with mgen. + inv X. rewrite <- H3; auto. +Qed. +#[local] Hint Resolve match_get_merge : mgen. + +Ltac masrp_tac := + match goal with + | H: context[forall s arr, ?ar ! s = Some arr -> _], H2: ?ar ! _ = Some _ |- _ => + let H3 := fresh "H" in + learn H; pose proof H2 as H3; apply H in H3; repeat inv_exists + | H: context[forall s, ?ar ! s = None <-> _], H2: ?ar ! _ = None |- _ => + let H3 := fresh "H" in + learn H; pose proof H2 as H3; apply H in H3 + | H: context[forall s, _ <-> ?ar ! s = None], H2: ?ar ! _ = None |- _ => + let H3 := fresh "H" in + learn H; pose proof H2 as H3; apply H in H3 + | ra: arr_associations |- _ => + let ra1 := fresh "ran" in let ra2 := fresh "rab" in destruct ra as [ra1 ra2] + | |- _ ! _ = _ => solve [mgen_crush] + | |- _ = _ => congruence + | |- _ <> _ => lia + | H: ?ar ! ?s = _ |- context[match ?ar ! ?r with _ => _ end] => learn H; destruct (Pos.eq_dec s r); subst + | H: ?ar ! ?s = _ |- context[match ?ar ! ?s with _ => _ end] => setoid_rewrite H + | |- context[match ?ar ! ?s with _ => _ end] => destruct (ar ! s) eqn:? + | H: ?s <> ?r |- context[(_ # ?r <- _) ! ?s] => rewrite AssocMap.gso + | H: ?r <> ?s |- context[(_ # ?r <- _) ! ?s] => rewrite AssocMap.gso + | |- context[(_ # ?s <- _) ! ?s] => rewrite AssocMap.gss + | H: context[match ?ar ! ?r with _ => _ end ! ?s] |- _ => + destruct (ar ! r) eqn:?; destruct (Pos.eq_dec r s); subst + | H: ?ar ! ?s = _, H2: context[match ?ar ! ?s with _ => _ end] |- _ => + setoid_rewrite H in H2 + | H: context[match ?ar ! ?s with _ => _ end] |- _ => destruct (ar ! s) eqn:? + | H: ?s <> ?r, H2: context[(_ # ?r <- _) ! ?s] |- _ => rewrite AssocMap.gso in H2 + | H: ?r <> ?s, H2: context[(_ # ?r <- _) ! ?s] |- _ => rewrite AssocMap.gso in H2 + | H: context[(_ # ?s <- _) ! ?s] |- _ => rewrite AssocMap.gss in H + | |- context[match_empty_size] => constructor + | |- context[arr_assocmap_set] => unfold arr_assocmap_set + | H: context[arr_assocmap_set] |- _ => unfold arr_assocmap_set in H + | |- exists _, _ => econstructor + | |- _ <-> _ => split + end; simplify. + +Lemma match_empty_assocmap_set : + forall m r i rhsval asa, + match_empty_size m asa -> + match_empty_size m (arr_assocmap_set r i rhsval asa). +Proof. + inversion 1; subst; simplify. + constructor. intros. + repeat masrp_tac. + intros. do 5 masrp_tac; try solve [repeat masrp_tac]. + apply H1 in H3. inv_exists. simplify. + econstructor. simplify. apply H3. congruence. + repeat masrp_tac. destruct (Pos.eq_dec r s); subst. + rewrite AssocMap.gss in H8. discriminate. + rewrite AssocMap.gso in H8; auto. apply H2 in H8. auto. + destruct (Pos.eq_dec r s); subst. apply H1 in H5. inv_exists. simplify. + rewrite H5 in H8. discriminate. + rewrite AssocMap.gso; auto. + apply H2 in H5. auto. apply H2 in H5. auto. + Unshelve. auto. +Qed. +#[local] Hint Resolve match_empty_assocmap_set : mgen. + +Lemma match_arrs_size_stmnt_preserved : + forall m f rs1 ar1 ar2 c rs2, + stmnt_runp f rs1 ar1 c rs2 ar2 -> + match_empty_size m (assoc_nonblocking ar1) -> + match_empty_size m (assoc_blocking ar1) -> + match_empty_size m (assoc_nonblocking ar2) /\ match_empty_size m (assoc_blocking ar2). +Proof. + induction 1; inversion 1; inversion 1; eauto; simplify; try solve [repeat masrp_tac]. + subst. apply IHstmnt_runp2; apply IHstmnt_runp1; auto. + apply IHstmnt_runp2; apply IHstmnt_runp1; auto. + apply match_empty_assocmap_set. auto. + apply match_empty_assocmap_set. auto. +Qed. + +Lemma match_arrs_size_stmnt_preserved2 : + forall m f rs1 na ba na' ba' c rs2, + stmnt_runp f rs1 {| assoc_nonblocking := na; assoc_blocking := ba |} c rs2 + {| assoc_nonblocking := na'; assoc_blocking := ba' |} -> + match_empty_size m na -> + match_empty_size m ba -> + match_empty_size m na' /\ match_empty_size m ba'. +Proof. + intros. + remember ({| assoc_blocking := ba; assoc_nonblocking := na |}) as ar1. + remember ({| assoc_blocking := ba'; assoc_nonblocking := na' |}) as ar2. + assert (X1: na' = (assoc_nonblocking ar2)) by (rewrite Heqar2; auto). rewrite X1. + assert (X2: ba' = (assoc_blocking ar2)) by (rewrite Heqar2; auto). rewrite X2. + assert (X3: na = (assoc_nonblocking ar1)) by (rewrite Heqar1; auto). rewrite X3 in *. + assert (X4: ba = (assoc_blocking ar1)) by (rewrite Heqar1; auto). rewrite X4 in *. + eapply match_arrs_size_stmnt_preserved; mgen_crush. +Qed. +#[local] Hint Resolve match_arrs_size_stmnt_preserved2 : mgen. + +Lemma match_arrs_size_ram_preserved : + forall m rs1 ar1 ar2 ram rs2, + exec_ram rs1 ar1 ram rs2 ar2 -> + match_empty_size m (assoc_nonblocking ar1) -> + match_empty_size m (assoc_blocking ar1) -> + match_empty_size m (assoc_nonblocking ar2) + /\ match_empty_size m (assoc_blocking ar2). +Proof. + induction 1; inversion 1; inversion 1; subst; simplify; try solve [repeat masrp_tac]. + masrp_tac. masrp_tac. solve [repeat masrp_tac]. + masrp_tac. masrp_tac. masrp_tac. masrp_tac. masrp_tac. masrp_tac. masrp_tac. + masrp_tac. masrp_tac. masrp_tac. masrp_tac. masrp_tac. masrp_tac. masrp_tac. + masrp_tac. apply H8 in H1; inv_exists; simplify. repeat masrp_tac. auto. + repeat masrp_tac. + repeat masrp_tac. + repeat masrp_tac. + destruct (Pos.eq_dec (ram_mem r) s); subst; repeat masrp_tac. + destruct (Pos.eq_dec (ram_mem r) s); subst; repeat masrp_tac. + apply H9 in H17; auto. apply H9 in H17; auto. + Unshelve. eauto. +Qed. +#[local] Hint Resolve match_arrs_size_ram_preserved : mgen. + +Lemma match_arrs_size_ram_preserved2 : + forall m rs1 na na' ba ba' ram rs2, + exec_ram rs1 {| assoc_nonblocking := na; assoc_blocking := ba |} ram rs2 + {| assoc_nonblocking := na'; assoc_blocking := ba' |} -> + match_empty_size m na -> match_empty_size m ba -> + match_empty_size m na' /\ match_empty_size m ba'. +Proof. + intros. + remember ({| assoc_blocking := ba; assoc_nonblocking := na |}) as ar1. + remember ({| assoc_blocking := ba'; assoc_nonblocking := na' |}) as ar2. + assert (X1: na' = (assoc_nonblocking ar2)) by (rewrite Heqar2; auto). rewrite X1. + assert (X2: ba' = (assoc_blocking ar2)) by (rewrite Heqar2; auto). rewrite X2. + assert (X3: na = (assoc_nonblocking ar1)) by (rewrite Heqar1; auto). rewrite X3 in *. + assert (X4: ba = (assoc_blocking ar1)) by (rewrite Heqar1; auto). rewrite X4 in *. + eapply match_arrs_size_ram_preserved; mgen_crush. +Qed. +#[local] Hint Resolve match_arrs_size_ram_preserved2 : mgen. + +Lemma empty_stack_m : + forall m, empty_stack m = empty_stack' (mod_stk_len m) (mod_stk m). +Proof. unfold empty_stack, empty_stack'; mgen_crush. Qed. +Hint Rewrite empty_stack_m : mgen. + +Ltac clear_forall := + repeat match goal with + | H: context[forall _, _] |- _ => clear H + end. + +Lemma list_combine_none : + forall n l, + length l = n -> + list_combine Verilog.merge_cell (list_repeat None n) l = l. +Proof. + induction n; intros; crush. + - symmetry. apply length_zero_iff_nil. auto. + - destruct l; crush. + rewrite list_repeat_cons. + crush. f_equal. + eauto. +Qed. + +Lemma combine_none : + forall n a, + a.(arr_length) = n -> + arr_contents (combine Verilog.merge_cell (arr_repeat None n) a) = arr_contents a. +Proof. + intros. + unfold combine. + crush. + + rewrite <- (arr_wf a) in H. + apply list_combine_none. + assumption. +Qed. + +Lemma combine_none2 : + forall n a addr, + arr_length a = n -> + array_get_error addr (combine Verilog.merge_cell (arr_repeat None n) a) + = array_get_error addr a. +Proof. intros; auto using array_get_error_equal, combine_none. Qed. + +Lemma list_combine_lookup_first : + forall l1 l2 n, + length l1 = length l2 -> + nth_error l1 n = Some None -> + nth_error (list_combine Verilog.merge_cell l1 l2) n = nth_error l2 n. +Proof. + induction l1; intros; crush. + + rewrite nth_error_nil in H0. + discriminate. + + destruct l2 eqn:EQl2. crush. + simpl in H. invert H. + destruct n; simpl in *. + invert H0. simpl. reflexivity. + eauto. +Qed. + +Lemma combine_lookup_first : + forall a1 a2 n, + a1.(arr_length) = a2.(arr_length) -> + array_get_error n a1 = Some None -> + array_get_error n (combine Verilog.merge_cell a1 a2) = array_get_error n a2. +Proof. + intros. + + unfold array_get_error in *. + apply list_combine_lookup_first; eauto. + rewrite a1.(arr_wf). rewrite a2.(arr_wf). + assumption. +Qed. + +Lemma list_combine_lookup_second : + forall l1 l2 n x, + length l1 = length l2 -> + nth_error l1 n = Some (Some x) -> + nth_error (list_combine Verilog.merge_cell l1 l2) n = Some (Some x). +Proof. + induction l1; intros; crush; auto. + + destruct l2 eqn:EQl2. crush. + simpl in H. invert H. + destruct n; simpl in *. + invert H0. simpl. reflexivity. + eauto. +Qed. + +Lemma combine_lookup_second : + forall a1 a2 n x, + a1.(arr_length) = a2.(arr_length) -> + array_get_error n a1 = Some (Some x) -> + array_get_error n (combine Verilog.merge_cell a1 a2) = Some (Some x). +Proof. + intros. + + unfold array_get_error in *. + apply list_combine_lookup_second; eauto. + rewrite a1.(arr_wf). rewrite a2.(arr_wf). + assumption. +Qed. + +Lemma match_get_arrs2 : + forall a i v l, + length a = l -> + list_combine merge_cell (list_set i (Some v) (list_repeat None l)) a = + list_combine merge_cell (list_repeat None l) (list_set i (Some v) a). +Proof. + induction a; crush; subst. + - destruct i. unfold list_repeat. unfold list_repeat'. auto. + unfold list_repeat. unfold list_repeat'. auto. + - destruct i. + rewrite list_repeat_cons. simplify. auto. + rewrite list_repeat_cons. simplify. f_equal. apply IHa. auto. +Qed. + +Lemma match_get_arrs : + forall addr i v x4 x x3, + x4 = arr_length x -> + x4 = arr_length x3 -> + array_get_error addr (combine merge_cell (array_set i (Some v) (arr_repeat None x4)) + (combine merge_cell x x3)) + = array_get_error addr (combine merge_cell (arr_repeat None x4) + (array_set i (Some v) (combine merge_cell x x3))). +Proof. + intros. apply array_get_error_equal. unfold combine. simplify. + destruct x; destruct x3; simplify. + apply match_get_arrs2. rewrite list_combine_length. subst. + rewrite H0. lia. +Qed. + +Lemma combine_array_set' : + forall a b i v, + length a = length b -> + list_combine merge_cell (list_set i (Some v) a) b = + list_set i (Some v) (list_combine merge_cell a b). +Proof. + induction a; simplify; crush. + - destruct i; crush. + - destruct i; destruct b; crush. + f_equal. apply IHa. auto. +Qed. + +Lemma combine_array_set : + forall a b i v addr, + arr_length a = arr_length b -> + array_get_error addr (combine merge_cell (array_set i (Some v) a) b) + = array_get_error addr (array_set i (Some v) (combine merge_cell a b)). +Proof. + intros. destruct a; destruct b. unfold array_set. simplify. + unfold array_get_error. simplify. f_equal. + apply combine_array_set'. crush. +Qed. + +Lemma array_get_combine' : + forall a b a' b' addr, + length a = length b -> + length a = length b' -> + length a = length a' -> + nth_error a addr = nth_error a' addr -> + nth_error b addr = nth_error b' addr -> + nth_error (list_combine merge_cell a b) addr = + nth_error (list_combine merge_cell a' b') addr. +Proof. + induction a; crush. + - destruct b; crush; destruct b'; crush; destruct a'; crush. + - destruct b; crush; destruct b'; crush; destruct a'; crush; + destruct addr; crush; apply IHa. +Qed. + +Lemma array_get_combine : + forall a b a' b' addr, + arr_length a = arr_length b -> + arr_length a = arr_length b' -> + arr_length a = arr_length a' -> + array_get_error addr a = array_get_error addr a' -> + array_get_error addr b = array_get_error addr b' -> + array_get_error addr (combine merge_cell a b) + = array_get_error addr (combine merge_cell a' b'). +Proof. + intros; unfold array_get_error, combine in *; destruct a; destruct b; + destruct a'; destruct b'; simplify; apply array_get_combine'; crush. +Qed. + +Lemma match_empty_size_exists_Some : + forall m rab s v, + match_empty_size m rab -> + rab ! s = Some v -> + exists v', (empty_stack m) ! s = Some v' /\ arr_length v = arr_length v'. +Proof. inversion 1; intros; repeat masrp_tac. Qed. + +Lemma match_empty_size_exists_None : + forall m rab s, + match_empty_size m rab -> + rab ! s = None -> + (empty_stack m) ! s = None. +Proof. inversion 1; intros; repeat masrp_tac. Qed. + +Lemma match_empty_size_exists_None' : + forall m rab s, + match_empty_size m rab -> + (empty_stack m) ! s = None -> + rab ! s = None. +Proof. inversion 1; intros; repeat masrp_tac. Qed. + +Lemma match_empty_size_exists_Some' : + forall m rab s v, + match_empty_size m rab -> + (empty_stack m) ! s = Some v -> + exists v', rab ! s = Some v' /\ arr_length v = arr_length v'. +Proof. inversion 1; intros; repeat masrp_tac. Qed. + +Lemma match_arrs_Some : + forall ra ra' s v, + match_arrs ra ra' -> + ra ! s = Some v -> + exists v', ra' ! s = Some v' + /\ (forall addr, array_get_error addr v = array_get_error addr v') + /\ arr_length v = arr_length v'. +Proof. inversion 1; intros; repeat masrp_tac. intros. rewrite H5. auto. Qed. + +Lemma match_arrs_None : + forall ra ra' s, + match_arrs ra ra' -> + ra ! s = None -> + ra' ! s = None. +Proof. inversion 1; intros; repeat masrp_tac. Qed. + +Ltac learn_next := + match goal with + | H: match_empty_size _ ?rab, H2: ?rab ! _ = Some _ |- _ => + let H3 := fresh "H" in + learn H2 as H3; eapply match_empty_size_exists_Some in H3; + eauto; inv_exists; simplify + | H: match_empty_size _ ?rab, H2: ?rab ! _ = None |- _ => + let H3 := fresh "H" in + learn H2 as H3; eapply match_empty_size_exists_None in H3; eauto + end. + +Ltac learn_empty := + match goal with + | H: match_empty_size _ _, H2: (empty_stack _) ! _ = Some _ |- _ => + let H3 := fresh "H" in + learn H as H3; eapply match_empty_size_exists_Some' in H3; + [| eassumption]; inv_exists; simplify + | H: match_arrs ?ar _, H2: ?ar ! _ = Some _ |- _ => + let H3 := fresh "H" in + learn H as H3; eapply match_arrs_Some in H3; + [| eassumption]; inv_exists; simplify + | H: match_empty_size _ _, H2: (empty_stack _) ! _ = None |- _ => + let H3 := fresh "H" in + learn H as H3; eapply match_empty_size_exists_None' in H3; + [| eassumption]; simplify + end. + +Lemma empty_set_none : + forall m ran rab s i v s0, + match_empty_size m ran -> + match_empty_size m rab -> + (arr_assocmap_set s i v ran) ! s0 = None -> + (arr_assocmap_set s i v rab) ! s0 = None. +Proof. + unfold arr_assocmap_set; inversion 1; subst; simplify. + destruct (Pos.eq_dec s s0); subst. + destruct ran ! s0 eqn:?. + rewrite AssocMap.gss in H4. inv H4. + learn_next. learn_empty. rewrite H6; auto. + destruct ran ! s eqn:?. rewrite AssocMap.gso in H4. + learn_next. learn_empty. rewrite H6. rewrite AssocMap.gso. + repeat match goal with + | H: Learnt _ |- _ => clear H + end. clear Heqo. clear H5. clear H6. + learn_next. repeat learn_empty. auto. auto. auto. + pose proof Heqo. learn_next; repeat learn_empty. + repeat match goal with + | H: Learnt _ |- _ => clear H + end. + pose proof H4. learn_next; repeat learn_empty. + rewrite H7. auto. +Qed. + +Ltac clear_learnt := + repeat match goal with + | H: Learnt _ |- _ => clear H + end. + +Lemma match_arrs_size_assoc : + forall a b, + match_arrs_size a b -> + match_arrs_size b a. +Proof. inversion 1; constructor; crush; split; apply H2. Qed. +#[local] Hint Resolve match_arrs_size_assoc : mgen. + +Lemma match_arrs_merge_set2 : + forall rab rab' ran ran' s m i v, + match_empty_size m rab -> + match_empty_size m ran -> + match_empty_size m rab' -> + match_empty_size m ran' -> + match_arrs rab rab' -> + match_arrs ran ran' -> + match_arrs (merge_arrs (arr_assocmap_set s i v ran) rab) + (merge_arrs (arr_assocmap_set s i v (empty_stack m)) + (merge_arrs ran' rab')). +Proof. + simplify. + constructor; intros. + unfold arr_assocmap_set in *. destruct (Pos.eq_dec s s0); subst. + destruct ran ! s0 eqn:?. unfold merge_arrs in *. rewrite AssocMap.gcombine in *; auto. + learn_next. repeat learn_empty. + econstructor. simplify. rewrite H6. rewrite AssocMap.gcombine by auto. + rewrite AssocMap.gss. simplify. setoid_rewrite H9. setoid_rewrite H7. simplify. + intros. rewrite AssocMap.gss in H5. setoid_rewrite H13 in H5. + simplify. pose proof (empty_arr m s0). inv H5. inv_exists. setoid_rewrite H5 in H6. inv H6. + unfold arr_repeat in H8. simplify. rewrite list_repeat_len in H8. rewrite list_repeat_len in H10. + rewrite match_get_arrs. crush. rewrite combine_none2. rewrite combine_array_set; try congruence. + apply array_get_error_each. rewrite combine_length; try congruence. + rewrite combine_length; try congruence. + apply array_get_combine; crush. + rewrite <- array_set_len. rewrite combine_length; crush. crush. crush. + setoid_rewrite H21 in H6; discriminate. rewrite combine_length. + rewrite <- array_set_len; crush. + unfold merge_arr in *. rewrite AssocMap.gss in H5. setoid_rewrite H13 in H5. + inv H5. rewrite combine_length. rewrite <- array_set_len; crush. + rewrite <- array_set_len; crush. + rewrite combine_length; crush. + destruct rab ! s0 eqn:?. learn_next. repeat learn_empty. + rewrite H11 in Heqo. discriminate. + unfold merge_arrs in H5. rewrite AssocMap.gcombine in H5; auto. rewrite Heqo in H5. + rewrite Heqo0 in H5. crush. + + destruct ran ! s eqn:?. + learn_next. repeat learn_empty. rewrite H6. + unfold merge_arrs in *. rewrite AssocMap.gcombine in H5; auto. + rewrite AssocMap.gcombine; auto. rewrite AssocMap.gso in H5; auto. + rewrite AssocMap.gso; auto. + destruct ran ! s0 eqn:?. + learn_next. + repeat match goal with + | H: Learnt _ |- _ => clear H + end. + repeat learn_empty. + repeat match goal with + | H: Learnt _ |- _ => clear H + end. + rewrite AssocMap.gcombine; auto. setoid_rewrite Heqo0 in H5. setoid_rewrite H29 in H5. + simplify. + pose proof (empty_arr m s0). inv H5. inv_exists. rewrite H5 in H21. inv H21. + econstructor. simplify. setoid_rewrite H23. rewrite H25. setoid_rewrite H5. + simplify. intros. rewrite combine_none2. apply array_get_combine; solve [crush]. + crush. rewrite list_combine_length. rewrite (arr_wf x5). rewrite (arr_wf x6). + rewrite <- H26. rewrite <- H28. rewrite list_repeat_len. lia. rewrite list_combine_length. + rewrite (arr_wf a). rewrite (arr_wf x7). rewrite combine_length. rewrite arr_repeat_length. + rewrite H24. rewrite <- H32. rewrite list_repeat_len. lia. + rewrite arr_repeat_length. rewrite combine_length. rewrite <- H26. symmetry. apply list_repeat_len. + congruence. + rewrite H37 in H21; discriminate. + repeat match goal with + | H: Learnt _ |- _ => clear H + end. eapply match_empty_size_exists_None in H0; eauto. + clear H6. repeat learn_empty. setoid_rewrite Heqo0 in H5. + setoid_rewrite H29 in H5. discriminate. + pose proof (match_arrs_merge ran ran' rab rab'). + eapply match_empty_size_match in H; [|apply H0]. + apply H6 in H; auto. inv H. apply H7 in H5. inv_exists. simplify. + learn_next. rewrite H9. econstructor. simplify. + apply merge_arr_empty''; mgen_crush. + auto. auto. + unfold merge_arrs in *. rewrite AssocMap.gcombine in H5; auto. rewrite AssocMap.gcombine; auto. + destruct (arr_assocmap_set s i v ran) ! s0 eqn:?; destruct rab ! s0 eqn:?; crush. + learn_next. repeat learn_empty. + repeat match goal with + | H: Learnt _ |- _ => clear H + end. + erewrite empty_set_none. rewrite AssocMap.gcombine; auto. + simplify. rewrite H7. rewrite H8. auto. apply H0. mgen_crush. auto. +Qed. + +Definition all_match_empty_size m ar := + match_empty_size m (assoc_nonblocking ar) /\ match_empty_size m (assoc_blocking ar). +#[local] Hint Unfold all_match_empty_size : mgen. + +Definition match_module_to_ram m ram := + ram_size ram = mod_stk_len m /\ ram_mem ram = mod_stk m. +#[local] Hint Unfold match_module_to_ram : mgen. + +Lemma zip_range_forall_le : + forall A (l: list A) n, Forall (Pos.le n) (map snd (zip_range n l)). +Proof. + induction l; crush; constructor; [lia|]. + assert (forall n x, n+1 <= x -> n <= x) by lia. + apply Forall_forall. intros. apply H. generalize dependent x. + apply Forall_forall. apply IHl. +Qed. + +Lemma transf_code_fold_correct: + forall l m state ram d' c' n, + fold_right (transf_maps state ram) (mod_datapath m, mod_controllogic m) l = (d', c') -> + Forall (fun x => x < n) (map fst l) -> + Forall (Pos.le n) (map snd l) -> + list_norepet (map fst l) -> + list_norepet (map snd l) -> + (forall p i c_s rs1 ar1 rs2 ar2 trs1 tar1 d_s, + i < n -> + all_match_empty_size m ar1 -> + all_match_empty_size m tar1 -> + match_module_to_ram m ram -> + (mod_datapath m)!i = Some d_s -> + (mod_controllogic m)!i = Some c_s -> + match_reg_assocs p rs1 trs1 -> + match_arr_assocs ar1 tar1 -> + max_reg_module m < p -> + exec_all d_s c_s rs1 ar1 rs2 ar2 -> + exists d_s' c_s' trs2 tar2, + d'!i = Some d_s' /\ c'!i = Some c_s' + /\ exec_all_ram ram d_s' c_s' trs1 tar1 trs2 tar2 + /\ match_reg_assocs p (merge_reg_assocs rs2) (merge_reg_assocs trs2) + /\ match_arr_assocs (merge_arr_assocs (ram_mem ram) (ram_size ram) ar2) + (merge_arr_assocs (ram_mem ram) (ram_size ram) tar2)). +Proof. + induction l as [| a l IHl]; simplify. + - match goal with + | H: (_, _) = (_, _) |- _ => inv H + end; + unfold exec_all in *; repeat inv_exists; simplify. + exploit match_states_same; + try match goal with + | H: stmnt_runp _ _ _ ?c _ _, H2: (mod_controllogic _) ! _ = Some ?c |- _ => apply H + end; eauto; mgen_crush; + try match goal with + | H: (mod_controllogic _) ! _ = Some ?c |- _ => + apply max_reg_stmnt_le_stmnt_tree in H; unfold max_reg_module in *; lia + end; intros; + exploit match_states_same; + try match goal with + | H: stmnt_runp _ _ _ ?c _ _, H2: (mod_datapath _) ! _ = Some ?c |- _ => apply H + end; eauto; mgen_crush; + try match goal with + | H: (mod_datapath _) ! _ = Some ?c |- _ => + apply max_reg_stmnt_le_stmnt_tree in H; unfold max_reg_module in *; lia + end; intros; + repeat match goal with + | |- exists _, _ => eexists + end; simplify; eauto; + unfold exec_all_ram; + repeat match goal with + | |- exists _, _ => eexists + end; simplify; eauto. + constructor. admit. + Abort. + +Lemma empty_stack_transf : forall m, empty_stack (transf_module m) = empty_stack m. +Proof. unfold empty_stack, transf_module; intros; repeat destruct_match; crush. Qed. + +Definition alt_unchanged (d : AssocMap.t stmnt) (c: AssocMap.t stmnt) d' c' i := + d ! i = d' ! i /\ c ! i = c' ! i. + +Definition alt_store ram d (c : AssocMap.t stmnt) d' c' i := + exists e1 e2, + d' ! i = Some (Vseq (Vnonblock (Vvar (ram_u_en ram)) (Vunop Vnot (Vvar (ram_u_en ram)))) + (Vseq (Vnonblock (Vvar (ram_wr_en ram)) (Vlit (ZToValue 1))) + (Vseq (Vnonblock (Vvar (ram_d_in ram)) e2) + (Vnonblock (Vvar (ram_addr ram)) e1)))) + /\ c' ! i = c ! i + /\ d ! i = Some (Vnonblock (Vvari (ram_mem ram) e1) e2). + +Definition alt_load state ram d (c : AssocMap.t stmnt) d' c' i n := + exists ns e1 e2, + d' ! i = Some (Vseq (Vnonblock (Vvar (ram_u_en ram)) (Vunop Vnot (Vvar (ram_u_en ram)))) + (Vseq (Vnonblock (Vvar (ram_wr_en ram)) (Vlit (ZToValue 0))) + (Vnonblock (Vvar (ram_addr ram)) e2))) + /\ d' ! n = Some (Vnonblock (Vvar e1) (Vvar (ram_d_out ram))) + /\ c' ! i = Some (Vnonblock (Vvar state) (Vlit (posToValue n))) + /\ c' ! n = Some (Vnonblock (Vvar state) ns) + /\ c ! i = Some (Vnonblock (Vvar state) ns) + /\ d ! i = Some (Vnonblock (Vvar e1) (Vvari (ram_mem ram) e2)) + /\ e1 < state + /\ max_reg_expr e2 < state + /\ max_reg_expr ns < state + /\ (Z.pos n <= Int.max_unsigned)%Z. + +Definition alternatives state ram d c d' c' i n := + alt_unchanged d c d' c' i + \/ alt_store ram d c d' c' i + \/ alt_load state ram d c d' c' i n. + +Lemma transf_alternatives : + forall ram n d c state i d' c', + transf_maps state ram (i, n) (d, c) = (d', c') -> + i <> n -> + alternatives state ram d c d' c' i n. +Proof. + intros. unfold transf_maps in *. + repeat destruct_match; match goal with + | H: (_, _) = (_, _) |- _ => inv H + end; try solve [left; econstructor; crush]; simplify; + repeat match goal with + | H: (_ =? _) = true |- _ => apply Peqb_true_eq in H; subst + end; unfold alternatives; right; + match goal with + | H: context[Vnonblock (Vvari _ _) _] |- _ => left + | _ => right + end; repeat econstructor; simplify; + repeat match goal with + | |- ( _ # ?s <- _ ) ! ?s = Some _ => apply AssocMap.gss + | |- ( _ # ?s <- _ ) ! ?r = Some _ => rewrite AssocMap.gso by lia + | |- _ = None => apply max_index_2; lia + | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H + end; auto. +Qed. + +Lemma transf_alternatives_neq : + forall state ram a n' n d'' c'' d' c' i d c, + transf_maps state ram (a, n) (d, c) = (d', c') -> + a <> i -> n' <> n -> i <> n' -> a <> n' -> + i <> n -> a <> n -> + alternatives state ram d'' c'' d c i n' -> + alternatives state ram d'' c'' d' c' i n'. +Proof. + unfold alternatives, alt_unchanged, alt_store, alt_load, transf_maps; intros; + repeat match goal with H: _ \/ _ |- _ => inv H | H: _ /\ _ |- _ => destruct H end; + [left | right; left | right; right]; + repeat inv_exists; simplify; + repeat destruct_match; + repeat match goal with + | H: (_, _) = (_, _) |- _ => inv H + | |- exists _, _ => econstructor + end; repeat split; repeat rewrite AssocMap.gso by lia; eauto; lia. +Qed. + +Lemma transf_alternatives_neq2 : + forall state ram a n' n d'' c'' d' c' i d c, + transf_maps state ram (a, n) (d', c') = (d, c) -> + a <> i -> n' <> n -> i <> n' -> a <> n' -> i <> n -> + alternatives state ram d c d'' c'' i n' -> + alternatives state ram d' c' d'' c'' i n'. +Proof. + unfold alternatives, alt_unchanged, alt_store, alt_load, transf_maps; intros; + repeat match goal with H: _ \/ _ |- _ => inv H | H: _ /\ _ |- _ => destruct H end; + [left | right; left | right; right]; + repeat inv_exists; simplify; + repeat destruct_match; + repeat match goal with + | H: (_, _) = (_, _) |- _ => inv H + | |- exists _, _ => econstructor + end; repeat split; repeat rewrite AssocMap.gso in * by lia; eauto; lia. +Qed. + +Lemma transf_alt_unchanged_neq : + forall i c'' d'' d c d' c', + alt_unchanged d' c' d'' c'' i -> + d' ! i = d ! i -> + c' ! i = c ! i -> + alt_unchanged d c d'' c'' i. +Proof. unfold alt_unchanged; simplify; congruence. Qed. + +Lemma transf_maps_neq : + forall state ram d c i n d' c' i' n' va vb vc vd, + transf_maps state ram (i, n) (d, c) = (d', c') -> + d ! i' = va -> d ! n' = vb -> + c ! i' = vc -> c ! n' = vd -> + i <> i' -> i <> n' -> n <> i' -> n <> n' -> + d' ! i' = va /\ d' ! n' = vb /\ c' ! i' = vc /\ c' ! n' = vd. +Proof. + unfold transf_maps; intros; repeat destruct_match; simplify; + repeat match goal with + | H: (_, _) = (_, _) |- _ => inv H + | H: (_ =? _) = true |- _ => apply Peqb_true_eq in H; subst + | |- context[( _ # ?s <- _ ) ! ?r] => rewrite AssocMap.gso by lia + end; crush. +Qed. + +Lemma alternatives_different_map : + forall l state ram d c d'' c'' d' c' n i p, + i <= p -> n > p -> + Forall (Pos.lt p) (map snd l) -> + Forall (Pos.ge p) (map fst l) -> + ~ In n (map snd l) -> + ~ In i (map fst l) -> + fold_right (transf_maps state ram) (d, c) l = (d', c') -> + alternatives state ram d' c' d'' c'' i n -> + alternatives state ram d c d'' c'' i n. +Proof. + Opaque transf_maps. + induction l; intros. + - crush. + - simplify; repeat match goal with + | H: context[_ :: _] |- _ => inv H + | H: transf_maps _ _ _ (fold_right (transf_maps ?s ?r) (?d, ?c) ?l) = (_, _) |- _ => + let X := fresh "X" in + remember (fold_right (transf_maps s r) (d, c) l) as X + | X: _ * _ |- _ => destruct X + | H: (_, _) = _ |- _ => symmetry in H + end; simplify. + remember p0 as i'. symmetry in Heqi'. subst. + remember p1 as n'. symmetry in Heqn'. subst. + assert (i <> n') by lia. + assert (n <> i') by lia. + assert (n <> n') by lia. + assert (i <> i') by lia. + eapply IHl; eauto. + eapply transf_alternatives_neq2; eauto; try lia. +Qed. + +Lemma transf_fold_alternatives : + forall l state ram d c d' c' i n d_s c_s, + fold_right (transf_maps state ram) (d, c) l = (d', c') -> + Pos.max (max_pc c) (max_pc d) < n -> + Forall (Pos.lt (Pos.max (max_pc c) (max_pc d))) (map snd l) -> + Forall (Pos.ge (Pos.max (max_pc c) (max_pc d))) (map fst l) -> + list_norepet (map fst l) -> + list_norepet (map snd l) -> + In (i, n) l -> + d ! i = Some d_s -> + c ! i = Some c_s -> + alternatives state ram d c d' c' i n. +Proof. + Opaque transf_maps. + induction l; crush; []. + repeat match goal with + | H: context[_ :: _] |- _ => inv H + | H: transf_maps _ _ _ (fold_right (transf_maps ?s ?r) (?d, ?c) ?l) = (_, _) |- _ => + let X := fresh "X" in + remember (fold_right (transf_maps s r) (d, c) l) as X + | X: _ * _ |- _ => destruct X + | H: (_, _) = _ |- _ => symmetry in H + end. + inv H5. inv H1. simplify. + eapply alternatives_different_map; eauto. + simplify; lia. simplify; lia. apply transf_alternatives; auto. lia. + simplify. + assert (X: In i (map fst l)). { replace i with (fst (i, n)) by auto. apply in_map; auto. } + assert (X2: In n (map snd l)). { replace n with (snd (i, n)) by auto. apply in_map; auto. } + assert (X3: n <> p0). { destruct (Pos.eq_dec n p0); subst; crush. } + assert (X4: i <> p). { destruct (Pos.eq_dec i p); subst; crush. } + eapply transf_alternatives_neq; eauto; apply max_index in H7; lia. + Transparent transf_maps. +Qed. + +Lemma zip_range_inv : + forall A (l: list A) i n, + In i l -> + exists n', In (i, n') (zip_range n l) /\ n' >= n. +Proof. + induction l; crush. + inv H. econstructor. + split. left. eauto. lia. + eapply IHl in H0. inv H0. inv H. + econstructor. split. right. apply H0. lia. +Qed. + +Lemma zip_range_not_in_fst : + forall A (l: list A) a n, ~ In a l -> ~ In a (map fst (zip_range n l)). +Proof. unfold not; induction l; crush; inv H0; firstorder. Qed. + +Lemma zip_range_no_repet_fst : + forall A (l: list A) a, list_norepet l -> list_norepet (map fst (zip_range a l)). +Proof. + induction l; simplify; constructor; inv H; firstorder; + eapply zip_range_not_in_fst; auto. +Qed. + +Lemma transf_code_alternatives : + forall state ram d c d' c' i d_s c_s, + transf_code state ram d c = (d', c') -> + d ! i = Some d_s -> + c ! i = Some c_s -> + exists n, alternatives state ram d c d' c' i n. +Proof. + unfold transf_code; + intros. + pose proof H0 as X. + apply PTree.elements_correct in X. assert (In i (map fst (PTree.elements d))). + { replace i with (fst (i, d_s)) by auto. apply in_map. auto. } + exploit zip_range_inv. apply H2. intros. inv H3. simplify. + instantiate (1 := (Pos.max (max_pc c) (max_pc d) + 1)) in H3. + exists x. + eapply transf_fold_alternatives; + eauto using forall_gt, PTree.elements_keys_norepet, max_index. lia. + assert (Forall (Pos.le (Pos.max (max_pc c) (max_pc d) + 1)) + (map snd (zip_range (Pos.max (max_pc c) (max_pc d) + 1) + (map fst (PTree.elements d))))) by apply zip_range_forall_le. + apply Forall_forall; intros. eapply Forall_forall in H4; eauto. lia. + rewrite zip_range_fst_idem. apply Forall_forall; intros. + apply AssocMapExt.elements_iff in H4. inv H4. apply max_index in H6. lia. + eapply zip_range_no_repet_fst. apply PTree.elements_keys_norepet. + eapply zip_range_snd_no_repet. +Qed. + +Lemma max_reg_stmnt_not_modified : + forall s f rs ar rs' ar', + stmnt_runp f rs ar s rs' ar' -> + forall r, + max_reg_stmnt s < r -> + (assoc_blocking rs) ! r = (assoc_blocking rs') ! r. +Proof. + induction 1; crush; + try solve [repeat destruct_match; apply IHstmnt_runp; try lia; auto]. + assert (X: (assoc_blocking asr1) ! r = (assoc_blocking asr2) ! r) by (apply IHstmnt_runp2; lia). + assert (X2: (assoc_blocking asr0) ! r = (assoc_blocking asr1) ! r) by (apply IHstmnt_runp1; lia). + congruence. + inv H. simplify. rewrite AssocMap.gso by lia; auto. +Qed. + +Lemma max_reg_stmnt_not_modified_nb : + forall s f rs ar rs' ar', + stmnt_runp f rs ar s rs' ar' -> + forall r, + max_reg_stmnt s < r -> + (assoc_nonblocking rs) ! r = (assoc_nonblocking rs') ! r. +Proof. + induction 1; crush; + try solve [repeat destruct_match; apply IHstmnt_runp; try lia; auto]. + assert (X: (assoc_nonblocking asr1) ! r = (assoc_nonblocking asr2) ! r) by (apply IHstmnt_runp2; lia). + assert (X2: (assoc_nonblocking asr0) ! r = (assoc_nonblocking asr1) ! r) by (apply IHstmnt_runp1; lia). + congruence. + inv H. simplify. rewrite AssocMap.gso by lia; auto. +Qed. + +Lemma int_eq_not_changed : + forall ar ar' r r2 b, + Int.eq (ar # r) (ar # r2) = b -> + ar ! r = ar' ! r -> + ar ! r2 = ar' ! r2 -> + Int.eq (ar' # r) (ar' # r2) = b. +Proof. + unfold find_assocmap, AssocMapExt.get_default. intros. + rewrite <- H0. rewrite <- H1. auto. +Qed. + +Lemma merge_find_assocmap : + forall ran rab x, + ran ! x = None -> + (merge_regs ran rab) # x = rab # x. +Proof. + unfold merge_regs, find_assocmap, AssocMapExt.get_default. + intros. destruct (rab ! x) eqn:?. + erewrite AssocMapExt.merge_correct_2; eauto. + erewrite AssocMapExt.merge_correct_3; eauto. +Qed. + +Lemma max_reg_module_controllogic_gt : + forall m i v p, + (mod_controllogic m) ! i = Some v -> + max_reg_module m < p -> + max_reg_stmnt v < p. +Proof. + intros. unfold max_reg_module in *. + apply max_reg_stmnt_le_stmnt_tree in H. lia. +Qed. + +Lemma max_reg_module_datapath_gt : + forall m i v p, + (mod_datapath m) ! i = Some v -> + max_reg_module m < p -> + max_reg_stmnt v < p. +Proof. + intros. unfold max_reg_module in *. + apply max_reg_stmnt_le_stmnt_tree in H. lia. +Qed. + +Lemma merge_arr_empty2 : + forall m ar ar', + match_empty_size m ar' -> + match_arrs ar ar' -> + match_arrs ar (merge_arrs (empty_stack m) ar'). +Proof. + inversion 1; subst; inversion 1; subst. + econstructor; intros. apply H4 in H6; inv_exists. simplify. + eapply merge_arr_empty'' in H6; eauto. + apply H5 in H6. pose proof H6. apply H2 in H7. + unfold merge_arrs. rewrite AssocMap.gcombine; auto. setoid_rewrite H6. + setoid_rewrite H7. auto. +Qed. +#[local] Hint Resolve merge_arr_empty2 : mgen. + +Lemma find_assocmap_gso : + forall ar x y v, x <> y -> (ar # y <- v) # x = ar # x. +Proof. + unfold find_assocmap, AssocMapExt.get_default; intros; rewrite AssocMap.gso; auto. +Qed. + +Lemma find_assocmap_gss : + forall ar x v, (ar # x <- v) # x = v. +Proof. + unfold find_assocmap, AssocMapExt.get_default; intros; rewrite AssocMap.gss; auto. +Qed. + +Lemma expr_lt_max_module_datapath : + forall m x, + max_reg_stmnt x <= max_stmnt_tree (mod_datapath m) -> + max_reg_stmnt x < max_reg_module m + 1. +Proof. unfold max_reg_module. lia. Qed. + +Lemma expr_lt_max_module_controllogic : + forall m x, + max_reg_stmnt x <= max_stmnt_tree (mod_controllogic m) -> + max_reg_stmnt x < max_reg_module m + 1. +Proof. unfold max_reg_module. lia. Qed. + +Lemma int_eq_not : + forall x y, Int.eq x y = true -> Int.eq x (Int.not y) = false. +Proof. + intros. pose proof (Int.eq_spec x y). rewrite H in H0. subst. + apply int_eq_not_false. +Qed. + +Lemma match_assocmaps_gt2 : + forall (p s : positive) (ra ra' : assocmap) (v : value), + p <= s -> match_assocmaps p ra ra' -> match_assocmaps p (ra # s <- v) ra'. +Proof. + intros; inv H0; constructor; intros. + destruct (Pos.eq_dec r s); subst. lia. + rewrite AssocMap.gso by lia. auto. +Qed. + +Lemma match_assocmaps_switch_neq : + forall p ra ra' r v' s v, + match_assocmaps p ra ((ra' # r <- v') # s <- v) -> + s <> r -> + match_assocmaps p ra ((ra' # s <- v) # r <- v'). +Proof. + inversion 1; constructor; simplify. + destruct (Pos.eq_dec r0 s); destruct (Pos.eq_dec r0 r); subst; try lia. + rewrite AssocMap.gso by lia. specialize (H0 s). apply H0 in H5. + rewrite AssocMap.gss in H5. rewrite AssocMap.gss. auto. + rewrite AssocMap.gss. apply H0 in H5. rewrite AssocMap.gso in H5 by lia. + rewrite AssocMap.gss in H5. auto. + repeat rewrite AssocMap.gso by lia. + apply H0 in H5. repeat rewrite AssocMap.gso in H5 by lia. + auto. +Qed. + +Lemma match_assocmaps_duplicate : + forall p ra ra' v' s v, + match_assocmaps p ra (ra' # s <- v) -> + match_assocmaps p ra ((ra' # s <- v') # s <- v). +Proof. + inversion 1; constructor; simplify. + destruct (Pos.eq_dec r s); subst. + rewrite AssocMap.gss. apply H0 in H4. rewrite AssocMap.gss in H4. auto. + repeat rewrite AssocMap.gso by lia. apply H0 in H4. rewrite AssocMap.gso in H4 by lia. + auto. +Qed. + +Lemma translation_correct : + forall m asr nasa1 basa1 nasr1 basr1 basr2 nasr2 nasa2 basa2 nasr3 basr3 + nasa3 basa3 asr'0 asa'0 res' st tge pstval sf asa ctrl data f, + asr ! (mod_reset m) = Some (ZToValue 0) -> + asr ! (mod_finish m) = Some (ZToValue 0) -> + asr ! (mod_st m) = Some (posToValue st) -> + (mod_controllogic m) ! st = Some ctrl -> + (mod_datapath m) ! st = Some data -> + stmnt_runp f {| assoc_blocking := asr; assoc_nonblocking := empty_assocmap |} + {| assoc_blocking := asa; assoc_nonblocking := empty_stack m |} ctrl + {| assoc_blocking := basr1; assoc_nonblocking := nasr1 |} + {| assoc_blocking := basa1; assoc_nonblocking := nasa1 |} -> + basr1 ! (mod_st m) = Some (posToValue st) -> + stmnt_runp f {| assoc_blocking := basr1; assoc_nonblocking := nasr1 |} + {| assoc_blocking := basa1; assoc_nonblocking := nasa1 |} data + {| assoc_blocking := basr2; assoc_nonblocking := nasr2 |} + {| assoc_blocking := basa2; assoc_nonblocking := nasa2 |} -> + exec_ram {| assoc_blocking := merge_regs nasr2 basr2; assoc_nonblocking := empty_assocmap |} + {| assoc_blocking := merge_arrs nasa2 basa2; assoc_nonblocking := empty_stack m |} None + {| assoc_blocking := basr3; assoc_nonblocking := nasr3 |} + {| assoc_blocking := basa3; assoc_nonblocking := nasa3 |} -> + (merge_regs nasr3 basr3) ! (mod_st m) = Some (posToValue pstval) -> + (Z.pos pstval <= 4294967295)%Z -> + match_states (State sf m st asr asa) (State res' (transf_module m) st asr'0 asa'0) -> + mod_ram m = None -> + exists R2 : state, + Smallstep.plus step tge (State res' (transf_module m) st asr'0 asa'0) Events.E0 R2 /\ + match_states (State sf m pstval (merge_regs nasr3 basr3) (merge_arrs nasa3 basa3)) R2. +Proof. + Ltac tac0 := + repeat match goal with + | H: match_reg_assocs _ _ _ |- _ => inv H + | H: match_arr_assocs _ _ |- _ => inv H + end. + intros. + repeat match goal with + | H: match_states _ _ |- _ => inv H + | H: context[exec_ram] |- _ => inv H + | H: mod_ram _ = None |- _ => + let H2 := fresh "TRANSF" in learn H as H2; apply transf_module_code in H2 + end. + eapply transf_code_alternatives in TRANSF; eauto; simplify; unfold alternatives in *. + repeat match goal with H: _ \/ _ |- _ => inv H end. + - unfold alt_unchanged in *; simplify. + assert (MATCH_SIZE1: match_empty_size m nasa1 /\ match_empty_size m basa1). + { eapply match_arrs_size_stmnt_preserved2; eauto. unfold match_empty_size; eauto with mgen. } + assert (MATCH_SIZE2: match_empty_size m nasa2 /\ match_empty_size m basa2). + { eapply match_arrs_size_stmnt_preserved2; mgen_crush. } simplify. + assert (MATCH_ARR3: match_arrs_size nasa2 basa2) by eauto with mgen. + exploit match_states_same; try solve [apply H4 | eapply max_stmnt_lt_module; eauto + | econstructor; eauto with mgen]; + intros; repeat inv_exists; simplify; tac0. + exploit match_states_same; try solve [eapply H6 | eapply max_stmnt_lt_module; eauto + | econstructor; eauto with mgen]; + intros; repeat inv_exists; simplify; tac0. + assert (MATCH_SIZE1': match_empty_size m ran'0 /\ match_empty_size m rab'0). + { eapply match_arrs_size_stmnt_preserved2; eauto. unfold match_empty_size; eauto with mgen. + rewrite empty_stack_transf; eauto with mgen. } + assert (MATCH_SIZE2': match_empty_size m ran'2 /\ match_empty_size m rab'2). + { eapply match_arrs_size_stmnt_preserved2; mgen_crush. } simplify. + assert (MATCH_ARR3': match_arrs_size ran'2 rab'2) by eauto with mgen. + do 2 econstructor. apply Smallstep.plus_one. econstructor. + eauto with mgen. eauto with mgen. eauto with mgen. + rewrite <- H12. eassumption. rewrite <- H7. eassumption. + eauto. eauto with mgen. eauto. + rewrite empty_stack_transf. unfold transf_module; repeat destruct_match; try discriminate. + econstructor. simplify. + unfold disable_ram in *. unfold transf_module in DISABLE_RAM. + repeat destruct_match; try discriminate; []. simplify. + pose proof H17 as R1. apply max_reg_stmnt_not_modified with (r := max_reg_module m + 2) in R1. + pose proof H17 as R2. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 2) in R2. + pose proof H18 as R3. eapply max_reg_stmnt_not_modified with (r := max_reg_module m + 2) in R3. + pose proof H18 as R4. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 2) in R4. + pose proof H17 as R1'. apply max_reg_stmnt_not_modified with (r := max_reg_module m + 6) in R1'. + pose proof H17 as R2'. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 6) in R2'. + pose proof H18 as R3'. eapply max_reg_stmnt_not_modified with (r := max_reg_module m + 6) in R3'. + pose proof H18 as R4'. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 6) in R4'. + simplify. + pose proof DISABLE_RAM as DISABLE_RAM1. + eapply int_eq_not_changed with (ar' := rab') in DISABLE_RAM; try congruence. + eapply int_eq_not_changed with (ar' := rab'1) in DISABLE_RAM; try congruence. + rewrite AssocMap.gempty in R2. rewrite <- R2 in R4. + rewrite AssocMap.gempty in R2'. rewrite <- R2' in R4'. + eapply int_eq_not_changed in DISABLE_RAM; auto. repeat (rewrite merge_find_assocmap; try congruence). + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + auto. auto. eauto with mgen. auto. + econstructor; mgen_crush. apply merge_arr_empty; mgen_crush. + unfold disable_ram in *. unfold transf_module in DISABLE_RAM. + repeat destruct_match; crush. unfold transf_module in Heqo; repeat destruct_match; crush. + pose proof H17 as R1. apply max_reg_stmnt_not_modified with (r := max_reg_module m + 2) in R1. + pose proof H17 as R2. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 2) in R2. + pose proof H18 as R3. eapply max_reg_stmnt_not_modified with (r := max_reg_module m + 2) in R3. + pose proof H18 as R4. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 2) in R4. + pose proof H17 as R1'. apply max_reg_stmnt_not_modified with (r := max_reg_module m + 6) in R1'. + pose proof H17 as R2'. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 6) in R2'. + pose proof H18 as R3'. eapply max_reg_stmnt_not_modified with (r := max_reg_module m + 6) in R3'. + pose proof H18 as R4'. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 6) in R4'. + simplify. + pose proof DISABLE_RAM as DISABLE_RAM1. + eapply int_eq_not_changed with (ar' := rab') in DISABLE_RAM; try congruence. + eapply int_eq_not_changed with (ar' := rab'1) in DISABLE_RAM; try congruence. + rewrite AssocMap.gempty in R2. rewrite <- R2 in R4. + rewrite AssocMap.gempty in R2'. rewrite <- R2' in R4'. + eapply int_eq_not_changed in DISABLE_RAM; auto. repeat (rewrite merge_find_assocmap; try congruence). + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + - unfold alt_store in *; simplify. inv H6. inv H19. inv H19. simplify. + exploit match_states_same; try solve [eapply H4 | eapply max_stmnt_lt_module; eauto + | econstructor; eauto with mgen]; + intros; repeat inv_exists; simplify; tac0. + do 2 econstructor. apply Smallstep.plus_one. econstructor. solve [eauto with mgen]. solve [eauto with mgen]. + solve [eauto with mgen]. + rewrite H7. eassumption. eassumption. eassumption. solve [eauto with mgen]. + econstructor. econstructor. econstructor. econstructor. econstructor. + auto. auto. auto. econstructor. econstructor. econstructor. + econstructor. econstructor. econstructor. econstructor. + eapply expr_runp_matches2. eassumption. 2: { eassumption. } + pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. + apply expr_lt_max_module_datapath in X; simplify; remember (max_reg_module m); lia. + auto. + econstructor. econstructor. eapply expr_runp_matches2; eauto. + pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. + apply expr_lt_max_module_datapath in X. + remember (max_reg_module m); simplify; lia. + + rewrite empty_stack_transf. + unfold transf_module; repeat destruct_match; try discriminate; simplify; []. + eapply exec_ram_Some_write. + 3: { + simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + repeat rewrite find_assocmap_gso by lia. + pose proof H12 as X. + eapply max_reg_stmnt_not_modified_nb with (r := (max_reg_module m + 2)) in X. + rewrite AssocMap.gempty in X. + apply merge_find_assocmap. auto. + apply max_reg_stmnt_le_stmnt_tree in H2. + apply expr_lt_max_module_controllogic in H2. lia. + } + 3: { + simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. + } + { unfold disable_ram in *. unfold transf_module in DISABLE_RAM; + repeat destruct_match; try discriminate. + simplify. + pose proof H12 as X2. + pose proof H12 as X4. + apply max_reg_stmnt_not_modified with (r := max_reg_module m + 2) in X2. + apply max_reg_stmnt_not_modified with (r := max_reg_module m + 6) in X4. + assert (forall ar ar' x, ar ! x = ar' ! x -> ar # x = ar' # x). + { intros. unfold find_assocmap, AssocMapExt.get_default. rewrite H6. auto. } + apply H6 in X2. apply H6 in X4. simplify. rewrite <- X2. rewrite <- X4. + apply int_eq_not. auto. + apply max_reg_stmnt_le_stmnt_tree in H2. + apply expr_lt_max_module_controllogic in H2. simplify. remember (max_reg_module m). lia. + apply max_reg_stmnt_le_stmnt_tree in H2. + apply expr_lt_max_module_controllogic in H2. simplify. remember (max_reg_module m). lia. + } + 2: { + simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. + } + solve [auto]. + simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. + simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. + simplify. auto. + simplify. auto. + unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + unfold_merge. + assert (mod_st (transf_module m) < max_reg_module m + 1). + { unfold max_reg_module, transf_module; repeat destruct_match; try discriminate; simplify; lia. } + remember (max_reg_module m). + repeat rewrite AssocMap.gso by lia. + unfold transf_module; repeat destruct_match; try discriminate; simplify. + replace (AssocMapExt.merge value ran' rab') with (merge_regs ran' rab'); + [|unfold merge_regs; auto]. + pose proof H19 as X. + eapply match_assocmaps_merge in X. + 2: { apply H21. } + inv X. rewrite <- H14. eassumption. unfold transf_module in H6; repeat destruct_match; + try discriminate; simplify. + lia. auto. + + econstructor. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + rewrite AssocMapExt.merge_base_1. + remember (max_reg_module m). + repeat (apply match_assocmaps_gt; [lia|]). + solve [eauto with mgen]. + + apply merge_arr_empty. apply match_empty_size_merge. + apply match_empty_assocmap_set. + eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. + eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. + apply match_arrs_merge_set2; auto. + eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. + eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. + eapply match_arrs_size_stmnt_preserved in H12; mgen_crush. + rewrite empty_stack_transf. mgen_crush. + eapply match_arrs_size_stmnt_preserved in H12; mgen_crush. + rewrite empty_stack_transf. mgen_crush. + auto. + apply merge_arr_empty_match. + apply match_empty_size_merge. apply match_empty_assocmap_set. + eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. + eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. + apply match_empty_size_merge. apply match_empty_assocmap_set. + mgen_crush. eapply match_arrs_size_stmnt_preserved in H12; mgen_crush. + rewrite empty_stack_transf; mgen_crush. + unfold disable_ram. unfold transf_module; repeat destruct_match; try discriminate; simplify. + unfold merge_regs. unfold_merge. + remember (max_reg_module m). + rewrite find_assocmap_gss. + repeat rewrite find_assocmap_gso by lia. + rewrite find_assocmap_gss. apply Int.eq_true. + - unfold alt_load in *; simplify. inv H6. + 2: { match goal with H: context[location_is] |- _ => inv H end. } + match goal with H: context[location_is] |- _ => inv H end. + inv H30. simplify. inv H4. + 2: { match goal with H: context[location_is] |- _ => inv H end. } + inv H27. simplify. + do 2 econstructor. eapply Smallstep.plus_two. + econstructor. mgen_crush. mgen_crush. mgen_crush. eassumption. + eassumption. econstructor. simplify. econstructor. econstructor. + solve [eauto with mgen]. econstructor. econstructor. econstructor. + econstructor. econstructor. auto. auto. auto. + econstructor. econstructor. econstructor. + econstructor. econstructor. econstructor. eapply expr_runp_matches2; auto. eassumption. + 2: { eassumption. } + pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. + apply expr_lt_max_module_datapath in X. simplify. remember (max_reg_module m); lia. + auto. + + simplify. rewrite empty_stack_transf. unfold transf_module; repeat destruct_match; crush. + eapply exec_ram_Some_read; simplify. + 2: { + unfold merge_regs. unfold_merge. repeat rewrite find_assocmap_gso; try (remember (max_reg_module m); lia). + auto. unfold max_reg_module. lia. + } + 2: { + unfold merge_regs. unfold_merge. rewrite AssocMap.gso by lia. rewrite AssocMap.gso by lia. + rewrite AssocMap.gss. auto. + } + { unfold disable_ram, transf_module in DISABLE_RAM; + repeat destruct_match; try discriminate. simplify. apply int_eq_not. auto. } + { unfold merge_regs; unfold_merge. repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. } + { unfold merge_regs; unfold_merge. apply AssocMap.gss. } + { eapply match_arrs_read. eassumption. mgen_crush. } + { crush. } + { crush. } + { unfold merge_regs. unfold_merge. + unfold transf_module; repeat destruct_match; try discriminate; simplify. + assert (mod_st m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + remember (max_reg_module m). repeat rewrite AssocMap.gso by lia. + apply AssocMap.gss. + } + { auto. } + + { econstructor. + { unfold merge_regs. unfold_merge. + assert (mod_reset m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + unfold transf_module; repeat destruct_match; try discriminate; simplify. + assert (mod_st m < mod_reset m). + { pose proof (mod_ordering_wf m); unfold module_ordering in *. simplify. + repeat match goal with + | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H + end; lia. + } + repeat rewrite AssocMap.gso by lia. + inv ASSOC. rewrite <- H19. auto. lia. + } + { unfold merge_regs. unfold_merge. + assert (mod_finish m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + unfold transf_module; repeat destruct_match; try discriminate; simplify. + assert (mod_st m < mod_finish m). + { pose proof (mod_ordering_wf m). unfold module_ordering in *. simplify. + repeat match goal with + | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H + end; lia. + } + repeat rewrite AssocMap.gso by lia. + inv ASSOC. rewrite <- H19. auto. lia. + } + { unfold merge_regs. unfold_merge. + assert (mod_st m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + unfold transf_module; repeat destruct_match; try discriminate; simplify. + repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. + } + { eassumption. } + { eassumption. } + { econstructor. econstructor. simplify. unfold merge_regs. unfold_merge. + eapply expr_runp_matches. eassumption. + assert (max_reg_expr x0 + 1 <= max_reg_module m + 1). + { pose proof H2 as X. apply max_reg_stmnt_le_stmnt_tree in X. + apply expr_lt_max_module_controllogic in X. simplify. remember (max_reg_module m). lia. } + assert (max_reg_expr x0 + 1 <= mod_st m). + { unfold module_ordering in *. simplify. + repeat match goal with + | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H + end. + pose proof H2 as X. apply max_reg_stmnt_le_stmnt_tree in X. + simplify. lia. + } + remember (max_reg_module m). + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_gt; [lia|]. + simplify. + eapply match_assocmaps_ge. eauto. lia. + mgen_crush. + } + { simplify. unfold merge_regs. unfold_merge. + unfold transf_module; repeat destruct_match; try discriminate; simplify. + assert (mod_st m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + remember (max_reg_module m). + repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. + } + { + simplify. econstructor. econstructor. econstructor. simplify. + unfold merge_regs; unfold_merge. + repeat rewrite find_assocmap_gso by lia. apply find_assocmap_gss. + } + { simplify. rewrite empty_stack_transf. + unfold transf_module; repeat destruct_match; try discriminate; simplify. + econstructor. simplify. + unfold merge_regs; unfold_merge. simplify. + assert (r < max_reg_module m + 1). + { pose proof H3 as X. eapply max_reg_module_datapath_gt with (p := max_reg_module m + 1) in X. + unfold max_reg_stmnt in X. simplify. + lia. lia. } + assert (mod_st m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + repeat rewrite find_assocmap_gso by lia. rewrite find_assocmap_gss. + repeat rewrite find_assocmap_gso by lia. rewrite find_assocmap_gss. + apply Int.eq_true. + } + { crush. } + { crush. } + { unfold merge_regs. unfold_merge. simplify. + assert (r < mod_st m). + { unfold module_ordering in *. simplify. + repeat match goal with + | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H + end. + pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. + simplify. lia. + } + unfold merge_regs in H8. repeat rewrite AssocMapExt.merge_add_assoc in H8. + simplify. rewrite AssocMap.gso in H8 by lia. rewrite AssocMap.gss in H8. + unfold transf_module; repeat destruct_match; try discriminate; simplify. + repeat rewrite AssocMap.gso by lia. + apply AssocMap.gss. } + { eassumption. } + } + { eauto. } + { econstructor. + { unfold merge_regs. unfold_merge. simplify. + apply match_assocmaps_gss. + unfold merge_regs in H8. repeat rewrite AssocMapExt.merge_add_assoc in H8. + rewrite AssocMap.gso in H8. rewrite AssocMap.gss in H8. inv H8. + remember (max_reg_module m). + assert (mod_st m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + apply match_assocmaps_switch_neq; [|lia]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_switch_neq; [|lia]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_switch_neq; [|lia]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_switch_neq; [|lia]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_switch_neq; [|lia]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_duplicate. + apply match_assocmaps_gss. auto. + assert (r < mod_st m). + { unfold module_ordering in *. simplify. + repeat match goal with + | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H + end. + pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. + simplify. lia. + } lia. + } + { + apply merge_arr_empty. mgen_crush. + apply merge_arr_empty2. mgen_crush. + apply merge_arr_empty2. mgen_crush. + apply merge_arr_empty2. mgen_crush. + mgen_crush. + } + { auto. } + { mgen_crush. } + { mgen_crush. } + { unfold disable_ram. + unfold transf_module; repeat destruct_match; try discriminate; simplify. + unfold merge_regs. unfold_merge. simplify. + assert (mod_st m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + assert (r < max_reg_module m + 1). + { pose proof H3 as X. eapply max_reg_module_datapath_gt with (p := max_reg_module m + 1) in X. + unfold max_reg_stmnt in X. simplify. + lia. lia. } + repeat rewrite find_assocmap_gso by lia. + rewrite find_assocmap_gss. + repeat rewrite find_assocmap_gso by lia. + rewrite find_assocmap_gss. apply Int.eq_true. + } + } +Qed. + +Lemma exec_ram_resets_en : + forall rs ar rs' ar' r, + exec_ram rs ar (Some r) rs' ar' -> + assoc_nonblocking rs = empty_assocmap -> + Int.eq ((assoc_blocking (merge_reg_assocs rs')) # (ram_en r, 32)) + ((assoc_blocking (merge_reg_assocs rs')) # (ram_u_en r, 32)) = true. +Proof. + inversion 1; intros; subst; unfold merge_reg_assocs; simplify. + - rewrite H6. mgen_crush. + - unfold merge_regs. rewrite H12. unfold_merge. + unfold find_assocmap, AssocMapExt.get_default in *. + rewrite AssocMap.gss; auto. rewrite AssocMap.gso; auto. setoid_rewrite H4. apply Int.eq_true. + pose proof (ram_ordering r); lia. + - unfold merge_regs. rewrite H11. unfold_merge. + unfold find_assocmap, AssocMapExt.get_default in *. + rewrite AssocMap.gss; auto. + repeat rewrite AssocMap.gso by (pose proof (ram_ordering r); lia). + setoid_rewrite H3. apply Int.eq_true. +Qed. + +Lemma disable_ram_set_gso : + forall rs r i v, + disable_ram (Some r) rs -> + i <> (ram_en r) -> i <> (ram_u_en r) -> + disable_ram (Some r) (rs # i <- v). +Proof. + unfold disable_ram, find_assocmap, AssocMapExt.get_default; intros; + repeat rewrite AssocMap.gso by lia; auto. +Qed. +#[local] Hint Resolve disable_ram_set_gso : mgen. + +Lemma disable_ram_None rs : disable_ram None rs. +Proof. unfold disable_ram; auto. Qed. +#[local] Hint Resolve disable_ram_None : mgen. + +Lemma init_regs_equal_empty l st : + Forall (Pos.gt st) l -> (init_regs nil l) ! st = None. +Proof. induction l; simplify; apply AssocMap.gempty. Qed. + +Lemma forall_lt_num : + forall l p p', Forall (Pos.gt p) l -> p < p' -> Forall (Pos.gt p') l. +Proof. induction l; crush; inv H; constructor; [lia | eauto]. Qed. + +Section CORRECTNESS. + + Context (prog tprog: program). + Context (TRANSL: match_prog prog tprog). + + Let ge : genv := Genv.globalenv prog. + Let tge : genv := Genv.globalenv tprog. + + Lemma symbols_preserved: + forall (s: AST.ident), Genv.find_symbol tge s = Genv.find_symbol ge s. + Proof using TRANSL. intros. eapply (Genv.find_symbol_match TRANSL). Qed. + #[local] Hint Resolve symbols_preserved : mgen. + + Lemma function_ptr_translated: + forall (b: Values.block) (f: fundef), + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = tf. + Proof using TRANSL. + intros. exploit (Genv.find_funct_ptr_match TRANSL); eauto. + intros (cu & tf & P & Q & R); exists tf; auto. + Qed. + #[local] Hint Resolve function_ptr_translated : mgen. + + Lemma functions_translated: + forall (v: Values.val) (f: fundef), + Genv.find_funct ge v = Some f -> + exists tf, + Genv.find_funct tge v = Some tf /\ transf_fundef f = tf. + Proof using TRANSL. + intros. exploit (Genv.find_funct_match TRANSL); eauto. + intros (cu & tf & P & Q & R); exists tf; auto. + Qed. + #[local] Hint Resolve functions_translated : mgen. + + Lemma senv_preserved: + Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). + Proof (Genv.senv_transf TRANSL). + #[local] Hint Resolve senv_preserved : mgen. + + Theorem transf_step_correct: + forall (S1 : state) t S2, + step ge S1 t S2 -> + forall R1, + match_states S1 R1 -> + exists R2, Smallstep.plus step tge R1 t R2 /\ match_states S2 R2. + Proof. + Ltac transf_step_correct_assum := + match goal with + | H: match_states _ _ |- _ => let H2 := fresh "MATCH" in learn H as H2; inv H2 + | H: mod_ram ?m = Some ?r |- _ => + let H2 := fresh "RAM" in learn H; + pose proof (transf_module_code_ram m r H) as H2 + | H: mod_ram ?m = None |- _ => + let H2 := fresh "RAM" in learn H; + pose proof (transf_module_code m H) as H2 + end. + Ltac transf_step_correct_tac := + match goal with + | |- Smallstep.plus _ _ _ _ _ => apply Smallstep.plus_one + end. + induction 1; destruct (mod_ram m) eqn:RAM; simplify; repeat transf_step_correct_assum; + repeat transf_step_correct_tac. + - assert (MATCH_SIZE1: match_empty_size m nasa1 /\ match_empty_size m basa1). + { eapply match_arrs_size_stmnt_preserved2; eauto. unfold match_empty_size; mgen_crush. } + simplify. + assert (MATCH_SIZE2: match_empty_size m nasa2 /\ match_empty_size m basa2). + { eapply match_arrs_size_stmnt_preserved2; mgen_crush. } simplify. + assert (MATCH_SIZE2: match_empty_size m nasa3 /\ match_empty_size m basa3). + { eapply match_arrs_size_ram_preserved2; mgen_crush. } simplify. + assert (MATCH_ARR3: match_arrs_size nasa3 basa3) by mgen_crush. + exploit match_states_same. apply H4. eauto with mgen. + econstructor; eauto. econstructor; eauto. econstructor; eauto. econstructor; eauto. + intros. repeat inv_exists. simplify. inv H18. inv H21. + exploit match_states_same. apply H6. eauto with mgen. + econstructor; eauto. econstructor; eauto. intros. repeat inv_exists. simplify. inv H18. inv H23. + exploit exec_ram_same; eauto. eauto with mgen. + econstructor. eapply match_assocmaps_merge; eauto. eauto with mgen. + econstructor. + apply match_arrs_merge; eauto with mgen. eauto with mgen. + intros. repeat inv_exists. simplify. inv H18. inv H28. + econstructor; simplify. apply Smallstep.plus_one. econstructor. + mgen_crush. mgen_crush. mgen_crush. rewrite RAM0; eassumption. rewrite RAM0; eassumption. + rewrite RAM0. eassumption. mgen_crush. eassumption. rewrite RAM0 in H21. rewrite RAM0. + rewrite RAM. eassumption. eauto. eauto. eauto with mgen. eauto. + econstructor. mgen_crush. apply match_arrs_merge; mgen_crush. eauto. + apply match_empty_size_merge; mgen_crush; mgen_crush. + assert (MATCH_SIZE1': match_empty_size m ran'0 /\ match_empty_size m rab'0). + { eapply match_arrs_size_stmnt_preserved2; eauto. unfold match_empty_size; mgen_crush. } + simplify. + assert (MATCH_SIZE2': match_empty_size m ran'2 /\ match_empty_size m rab'2). + { eapply match_arrs_size_stmnt_preserved2; mgen_crush. } simplify. + assert (MATCH_SIZE2': match_empty_size m ran'4 /\ match_empty_size m rab'4). + { eapply match_arrs_size_ram_preserved2; mgen_crush. + unfold match_empty_size, transf_module, empty_stack. + repeat destruct_match; crush. mgen_crush. } + apply match_empty_size_merge; mgen_crush; mgen_crush. + unfold disable_ram. + unfold transf_module; repeat destruct_match; crush. + apply exec_ram_resets_en in H21. unfold merge_reg_assocs in H21. + simplify. auto. auto. + - eapply translation_correct; eauto. + - do 2 econstructor. apply Smallstep.plus_one. + apply step_finish; mgen_crush. constructor; eauto. + - do 2 econstructor. apply Smallstep.plus_one. + apply step_finish; mgen_crush. econstructor; eauto. + - econstructor. econstructor. apply Smallstep.plus_one. econstructor. + replace (mod_entrypoint (transf_module m)) with (mod_entrypoint m) by (rewrite RAM0; auto). + replace (mod_reset (transf_module m)) with (mod_reset m) by (rewrite RAM0; auto). + replace (mod_finish (transf_module m)) with (mod_finish m) by (rewrite RAM0; auto). + replace (empty_stack (transf_module m)) with (empty_stack m) by (rewrite RAM0; auto). + replace (mod_params (transf_module m)) with (mod_params m) by (rewrite RAM0; auto). + replace (mod_st (transf_module m)) with (mod_st m) by (rewrite RAM0; auto). + repeat econstructor; mgen_crush. + unfold disable_ram. unfold transf_module; repeat destruct_match; crush. + pose proof (mod_ordering_wf m); unfold module_ordering in *. + pose proof (mod_params_wf m). + pose proof (mod_ram_wf m r Heqo0). + pose proof (ram_ordering r). + simplify. + repeat rewrite find_assocmap_gso by lia. + assert ((init_regs nil (mod_params m)) ! (ram_en r) = None). + { apply init_regs_equal_empty. eapply forall_lt_num. eassumption. lia. } + assert ((init_regs nil (mod_params m)) ! (ram_u_en r) = None). + { apply init_regs_equal_empty. eapply forall_lt_num. eassumption. lia. } + unfold find_assocmap, AssocMapExt.get_default. rewrite H7. rewrite H14. auto. + - econstructor. econstructor. apply Smallstep.plus_one. econstructor. + replace (mod_entrypoint (transf_module m)) with (mod_entrypoint m). + replace (mod_reset (transf_module m)) with (mod_reset m). + replace (mod_finish (transf_module m)) with (mod_finish m). + replace (empty_stack (transf_module m)) with (empty_stack m). + replace (mod_params (transf_module m)) with (mod_params m). + replace (mod_st (transf_module m)) with (mod_st m). + all: try solve [unfold transf_module; repeat destruct_match; mgen_crush]. + repeat econstructor; mgen_crush. + unfold disable_ram. unfold transf_module; repeat destruct_match; crush. + unfold max_reg_module. + repeat rewrite find_assocmap_gso by lia. + assert (max_reg_module m + 1 > max_list (mod_params m)). + { unfold max_reg_module. lia. } + apply max_list_correct in H0. + unfold find_assocmap, AssocMapExt.get_default. + rewrite init_regs_equal_empty. rewrite init_regs_equal_empty. auto. + eapply forall_lt_num. eassumption. unfold max_reg_module. lia. + eapply forall_lt_num. eassumption. unfold max_reg_module. lia. + - inv STACKS. destruct b1; subst. + econstructor. econstructor. apply Smallstep.plus_one. + econstructor. eauto. + clear Learn. inv H0. inv H3. inv STACKS. inv H3. constructor. + constructor. intros. + rewrite RAM0. + destruct (Pos.eq_dec r res); subst. + rewrite AssocMap.gss. + rewrite AssocMap.gss. auto. + rewrite AssocMap.gso; auto. + symmetry. rewrite AssocMap.gso; auto. + destruct (Pos.eq_dec (mod_st m) r); subst. + rewrite AssocMap.gss. + rewrite AssocMap.gss. auto. + rewrite AssocMap.gso; auto. + symmetry. rewrite AssocMap.gso; auto. inv MATCH_ASSOC0. apply H1. auto. + auto. auto. auto. auto. + rewrite RAM0. rewrite RAM. rewrite RAM0 in DISABLE_RAM. rewrite RAM in DISABLE_RAM. + apply disable_ram_set_gso. + apply disable_ram_set_gso. auto. + pose proof (mod_ordering_wf m); unfold module_ordering in *. + pose proof (ram_ordering r0). simplify. + pose proof (mod_ram_wf m r0 H). lia. + pose proof (mod_ordering_wf m); unfold module_ordering in *. + pose proof (ram_ordering r0). simplify. + pose proof (mod_ram_wf m r0 H). lia. + pose proof (mod_ordering_wf m); unfold module_ordering in *. + pose proof (ram_ordering r0). simplify. + pose proof (mod_ram_wf m r0 H). lia. + pose proof (mod_ordering_wf m); unfold module_ordering in *. + pose proof (ram_ordering r0). simplify. + pose proof (mod_ram_wf m r0 H). lia. + - inv STACKS. destruct b1; subst. + econstructor. econstructor. apply Smallstep.plus_one. + econstructor. eauto. + clear Learn. inv H0. inv H3. inv STACKS. constructor. + constructor. intros. + unfold transf_module. repeat destruct_match; crush. + destruct (Pos.eq_dec r res); subst. + rewrite AssocMap.gss. + rewrite AssocMap.gss. auto. + rewrite AssocMap.gso; auto. + symmetry. rewrite AssocMap.gso; auto. + destruct (Pos.eq_dec (mod_st m) r); subst. + rewrite AssocMap.gss. + rewrite AssocMap.gss. auto. + rewrite AssocMap.gso; auto. + symmetry. rewrite AssocMap.gso; auto. inv MATCH_ASSOC. apply H. auto. + auto. auto. auto. auto. + Opaque disable_ram. + unfold transf_module in *; repeat destruct_match; crush. + apply disable_ram_set_gso. + apply disable_ram_set_gso. + auto. + simplify. unfold max_reg_module. lia. + simplify. unfold max_reg_module. lia. + simplify. unfold max_reg_module. lia. + simplify. unfold max_reg_module. lia. + Qed. + #[local] Hint Resolve transf_step_correct : mgen. + + Lemma transf_initial_states : + forall s1 : state, + initial_state prog s1 -> + exists s2 : state, + initial_state tprog s2 /\ match_states s1 s2. + Proof using TRANSL. + simplify. inv H. + exploit function_ptr_translated. eauto. intros. + inv H. inv H3. + econstructor. econstructor. econstructor. + eapply (Genv.init_mem_match TRANSL); eauto. + setoid_rewrite (Linking.match_program_main TRANSL). + rewrite symbols_preserved. eauto. + eauto. + econstructor. + Qed. + #[local] Hint Resolve transf_initial_states : mgen. + + Lemma transf_final_states : + forall (s1 : state) + (s2 : state) + (r : Int.int), + match_states s1 s2 -> + final_state s1 r -> + final_state s2 r. + Proof using TRANSL. + intros. inv H0. inv H. inv STACKS. unfold valueToInt. constructor. auto. + Qed. + #[local] Hint Resolve transf_final_states : mgen. + + Theorem transf_program_correct: + Smallstep.forward_simulation (semantics prog) (semantics tprog). + Proof using TRANSL. + eapply Smallstep.forward_simulation_plus; mgen_crush. + apply senv_preserved. + Qed. + +End CORRECTNESS. diff --git a/src/hls/Partition.ml b/src/hls/Partition.ml index 270db14..19c6048 100644 --- a/src/hls/Partition.ml +++ b/src/hls/Partition.ml @@ -118,7 +118,6 @@ let function_from_RTL f = fn_stacksize = f.RTL.fn_stacksize; fn_params = f.RTL.fn_params; fn_entrypoint = f.RTL.fn_entrypoint; - fn_funct_units = FunctionalUnits.initial_funct_units; fn_code = c } diff --git a/src/hls/Predicate.v b/src/hls/Predicate.v new file mode 100644 index 0000000..b19ae98 --- /dev/null +++ b/src/hls/Predicate.v @@ -0,0 +1,683 @@ +Require Import Coq.Classes.RelationClasses. +Require Import Coq.Classes.DecidableClass. +Require Import Coq.Setoids.Setoid. +Require Export Coq.Classes.SetoidClass. +Require Export Coq.Classes.SetoidDec. +Require Import Coq.Logic.Decidable. + +Require Import vericert.common.Vericertlib. +Require Import vericert.hls.Sat. + +Definition predicate : Type := positive. + +Inductive pred_op : Type := +| Plit: (bool * predicate) -> pred_op +| Ptrue: pred_op +| Pfalse: pred_op +| Pand: pred_op -> pred_op -> pred_op +| Por: pred_op -> pred_op -> pred_op. + +Declare Scope pred_op. + +Notation "A ∧ B" := (Pand A B) (at level 20) : pred_op. +Notation "A ∨ B" := (Por A B) (at level 25) : pred_op. +Notation "⟂" := (Pfalse) : pred_op. +Notation "'T'" := (Ptrue) : pred_op. + +#[local] Open Scope pred_op. + +Fixpoint sat_predicate (p: pred_op) (a: asgn) : bool := + match p with + | Plit (b, p') => if b then a (Pos.to_nat p') else negb (a (Pos.to_nat p')) + | Ptrue => true + | Pfalse => false + | Pand p1 p2 => sat_predicate p1 a && sat_predicate p2 a + | Por p1 p2 => sat_predicate p1 a || sat_predicate p2 a + end. + +Definition sat_equiv p1 p2 := forall c, sat_predicate p1 c = sat_predicate p2 c. + +Lemma equiv_symm : forall a b, sat_equiv a b -> sat_equiv b a. +Proof. crush. Qed. + +Lemma equiv_trans : forall a b c, sat_equiv a b -> sat_equiv b c -> sat_equiv a c. +Proof. crush. Qed. + +Lemma equiv_refl : forall a, sat_equiv a a. +Proof. crush. Qed. + +#[global] +Instance Equivalence_SAT : Equivalence sat_equiv := + { Equivalence_Reflexive := equiv_refl ; + Equivalence_Symmetric := equiv_symm ; + Equivalence_Transitive := equiv_trans ; + }. + +#[global] +Instance SATSetoid : Setoid pred_op := + { equiv := sat_equiv; }. + +#[global] +Instance PandProper : Proper (equiv ==> equiv ==> equiv) Pand. +Proof. + unfold Proper. simplify. unfold "==>". + intros. + unfold sat_equiv in *. intros. + simplify. rewrite H0. rewrite H. + auto. +Qed. + +#[global] +Instance PorProper : Proper (equiv ==> equiv ==> equiv) Por. +Proof. + unfold Proper, "==>". simplify. + intros. + unfold sat_equiv in *. intros. + simplify. rewrite H0. rewrite H. + auto. +Qed. + +#[global] +Instance sat_predicate_Proper : Proper (equiv ==> eq ==> eq) sat_predicate. +Proof. + unfold Proper, "==>". simplify. + intros. + unfold sat_equiv in *. subst. + apply H. +Qed. + +Fixpoint negate (p: pred_op) := + match p with + | Plit (b, pr) => Plit (negb b, pr) + | T => ⟂ + | ⟂ => T + | A ∧ B => negate A ∨ negate B + | A ∨ B => negate A ∧ negate B + end. + +Notation "¬ A" := (negate A) (at level 15) : pred_op. + +Lemma negate_correct : + forall h a, sat_predicate (negate h) a = negb (sat_predicate h a). +Proof. + induction h; crush. + - repeat destruct_match; subst; crush; symmetry; apply negb_involutive. + - rewrite negb_andb; crush. + - rewrite negb_orb; crush. +Qed. + +Definition unsat p := forall a, sat_predicate p a = false. +Definition sat p := exists a, sat_predicate p a = true. + +Lemma unsat_correct1 : + forall a b c, + unsat (Pand a b) -> + sat_predicate a c = true -> + sat_predicate b c = false. +Proof. + unfold unsat in *. intros. + simplify. specialize (H c). + apply andb_false_iff in H. inv H. rewrite H0 in H1. discriminate. + auto. +Qed. + +Lemma unsat_correct2 : + forall a b c, + unsat (Pand a b) -> + sat_predicate b c = true -> + sat_predicate a c = false. +Proof. + unfold unsat in *. intros. + simplify. specialize (H c). + apply andb_false_iff in H. inv H. auto. rewrite H0 in H1. discriminate. +Qed. + +Lemma unsat_not a: unsat (a ∧ (¬ a)). +Proof. + unfold unsat; simplify. + rewrite negate_correct. + auto with bool. +Qed. + +Lemma unsat_commut a b: unsat (a ∧ b) -> unsat (b ∧ a). +Proof. unfold unsat; simplify; eauto with bool. Qed. + +Lemma sat_imp_equiv : + forall a b, + unsat (a ∧ ¬ b ∨ ¬ a ∧ b) -> a == b. +Proof. + simplify; unfold unsat, sat_equiv. + intros. specialize (H c); simplify. + rewrite negate_correct in *. + destruct (sat_predicate b c) eqn:X; + destruct (sat_predicate a c) eqn:X2; + crush. +Qed. + +Lemma sat_predicate_and : + forall a b c, + sat_predicate (a ∧ b) c = sat_predicate a c && sat_predicate b c. +Proof. crush. Qed. + +Lemma sat_predicate_or : + forall a b c, + sat_predicate (a ∨ b) c = sat_predicate a c || sat_predicate b c. +Proof. crush. Qed. + +Lemma sat_equiv2 : + forall a b, + a == b -> unsat (a ∧ ¬ b ∨ ¬ a ∧ b). +Proof. + unfold unsat, equiv; simplify. + repeat rewrite negate_correct. + repeat rewrite H. + rewrite andb_negb_r. + rewrite andb_negb_l. auto. +Qed. + +Lemma sat_equiv3 : + forall a b, + unsat (a ∧ ¬ b ∨ b ∧ ¬ a) -> a == b. +Proof. + simplify. unfold unsat, sat_equiv in *; intros. + specialize (H c); simplify. + rewrite negate_correct in *. + destruct (sat_predicate b c) eqn:X; + destruct (sat_predicate a c) eqn:X2; + crush. +Qed. + +Lemma sat_equiv4 : + forall a b, + a == b -> unsat (a ∧ ¬ b ∨ b ∧ ¬ a). +Proof. + unfold unsat, equiv; simplify. + repeat rewrite negate_correct. + repeat rewrite H. + rewrite andb_negb_r. auto. +Qed. + +Definition simplify' (p: pred_op) := + match p with + | (Plit (b1, a)) ∧ (Plit (b2, b)) as p' => + if Pos.eqb a b then + if negb (xorb b1 b2) then Plit (b1, a) else ⟂ + else p' + | (Plit (b1, a)) ∨ (Plit (b2, b)) as p' => + if Pos.eqb a b then + if negb (xorb b1 b2) then Plit (b1, a) else T + else p' + | A ∧ T => A + | T ∧ A => A + | _ ∧ ⟂ => ⟂ + | ⟂ ∧ _ => ⟂ + | _ ∨ T => T + | T ∨ _ => T + | A ∨ ⟂ => A + | ⟂ ∨ A => A + | A => A + end. + +Lemma pred_op_dec : + forall p1 p2: pred_op, + { p1 = p2 } + { p1 <> p2 }. +Proof. pose proof Pos.eq_dec. repeat decide equality. Qed. + +Fixpoint simplify (p: pred_op) := + match p with + | A ∧ B => + let A' := simplify A in + let B' := simplify B in + simplify' (A' ∧ B') + | A ∨ B => + let A' := simplify A in + let B' := simplify B in + simplify' (A' ∨ B') + | T => T + | ⟂ => ⟂ + | Plit a => Plit a + end. + +Lemma simplify'_correct : + forall h a, + sat_predicate (simplify' h) a = sat_predicate h a. +Proof. + (*destruct h; crush; repeat destruct_match; crush; + solve [rewrite andb_true_r; auto | rewrite orb_false_r; auto]. +Qed.*) Admitted. + +Lemma simplify_correct : + forall h a, + sat_predicate (simplify h) a = sat_predicate h a. +Proof. + Local Opaque simplify'. + induction h; crush. + - replace (sat_predicate h1 a && sat_predicate h2 a) + with (sat_predicate (simplify h1) a && sat_predicate (simplify h2) a) + by crush. + rewrite simplify'_correct. crush. + - replace (sat_predicate h1 a || sat_predicate h2 a) + with (sat_predicate (simplify h1) a || sat_predicate (simplify h2) a) + by crush. + rewrite simplify'_correct. crush. + Local Transparent simplify'. +Qed. + +Fixpoint mult {A: Type} (a b: list (list A)) : list (list A) := + match a with + | nil => nil + | l :: ls => mult ls b ++ (List.map (fun x => l ++ x) b) + end. + +Lemma satFormula_concat: + forall a b agn, + satFormula a agn -> + satFormula b agn -> + satFormula (a ++ b) agn. +Proof. induction a; crush. Qed. + +Lemma satFormula_concat2: + forall a b agn, + satFormula (a ++ b) agn -> + satFormula a agn /\ satFormula b agn. +Proof. + induction a; simplify; + try apply IHa in H1; crush. +Qed. + +Lemma satClause_concat: + forall a a1 a0, + satClause a a1 -> + satClause (a0 ++ a) a1. +Proof. induction a0; crush. Qed. + +Lemma satClause_concat2: + forall a a1 a0, + satClause a0 a1 -> + satClause (a0 ++ a) a1. +Proof. + induction a0; crush. + inv H; crush. +Qed. + +Lemma satClause_concat3: + forall a b c, + satClause (a ++ b) c -> + satClause a c \/ satClause b c. +Proof. + induction a; crush. + inv H; crush. + apply IHa in H0; crush. + inv H0; crush. +Qed. + +Lemma satFormula_mult': + forall p2 a a0, + satFormula p2 a0 \/ satClause a a0 -> + satFormula (map (fun x : list lit => a ++ x) p2) a0. +Proof. + induction p2; crush. + - inv H. inv H0. apply satClause_concat. auto. + apply satClause_concat2; auto. + - apply IHp2. + inv H; crush; inv H0; crush. +Qed. + +Lemma satFormula_mult2': + forall p2 a a0, + satFormula (map (fun x : list lit => a ++ x) p2) a0 -> + satClause a a0 \/ satFormula p2 a0. +Proof. + induction p2; crush. + apply IHp2 in H1. inv H1; crush. + apply satClause_concat3 in H0. + inv H0; crush. +Qed. + +Lemma satFormula_mult: + forall p1 p2 a, + satFormula p1 a \/ satFormula p2 a -> + satFormula (mult p1 p2) a. +Proof. + induction p1; crush. + apply satFormula_concat; crush. + inv H. inv H0. + apply IHp1. auto. + apply IHp1. auto. + apply satFormula_mult'; + inv H; crush. +Qed. + +Lemma satFormula_mult2: + forall p1 p2 a, + satFormula (mult p1 p2) a -> + satFormula p1 a \/ satFormula p2 a. +Proof. + induction p1; crush. + apply satFormula_concat2 in H; crush. + apply IHp1 in H0. + inv H0; crush. + apply satFormula_mult2' in H1. inv H1; crush. +Qed. + +Fixpoint trans_pred (p: pred_op) : + {fm: formula | forall a, + sat_predicate p a = true <-> satFormula fm a}. + refine + (match p with + | Plit (b, p') => exist _ (((b, Pos.to_nat p') :: nil) :: nil) _ + | Ptrue => exist _ nil _ + | Pfalse => exist _ (nil::nil) _ + | Pand p1 p2 => + match trans_pred p1, trans_pred p2 with + | exist _ p1' _, exist _ p2' _ => exist _ (p1' ++ p2') _ + end + | Por p1 p2 => + match trans_pred p1, trans_pred p2 with + | exist _ p1' _, exist _ p2' _ => exist _ (mult p1' p2') _ + end + end); split; intros; simpl in *; auto; try solve [crush]. + - destruct b; auto. apply negb_true_iff in H. auto. + - destruct b. inv H. inv H0; auto. apply negb_true_iff. inv H. inv H0; eauto. contradiction. + - apply satFormula_concat. + apply andb_prop in H. inv H. apply i in H0. auto. + apply andb_prop in H. inv H. apply i0 in H1. auto. + - apply satFormula_concat2 in H. simplify. apply andb_true_intro. + split. apply i in H0. auto. + apply i0 in H1. auto. + - apply orb_prop in H. inv H; apply satFormula_mult. apply i in H0. auto. + apply i0 in H0. auto. + - apply orb_true_intro. + apply satFormula_mult2 in H. inv H. apply i in H0. auto. + apply i0 in H0. auto. +Defined. + +Definition bar (p1: lit): lit := (negb (fst p1), (snd p1)). + +Definition stseytin_or (cur p1 p2: lit) : formula := + (bar cur :: p1 :: p2 :: nil) + :: (cur :: bar p1 :: nil) + :: (cur :: bar p2 :: nil) :: nil. + +Definition stseytin_and (cur p1 p2: lit) : formula := + (cur :: bar p1 :: bar p2 :: nil) + :: (bar cur :: p1 :: nil) + :: (bar cur :: p2 :: nil) :: nil. + +Fixpoint xtseytin (next: nat) (p: pred_op) {struct p} : (nat * lit * formula) := + match p with + | Plit (b, p') => (next, (b, Pos.to_nat p'), nil) + | Ptrue => + ((next+1)%nat, (true, next), ((true, next)::nil)::nil) + | Pfalse => + ((next+1)%nat, (true, next), ((false, next)::nil)::nil) + | Por p1 p2 => + let '(m1, n1, f1) := xtseytin next p1 in + let '(m2, n2, f2) := xtseytin m1 p2 in + ((m2+1)%nat, (true, m2), stseytin_or (true, m2) n1 n2 ++ f1 ++ f2) + | Pand p1 p2 => + let '(m1, n1, f1) := xtseytin next p1 in + let '(m2, n2, f2) := xtseytin m1 p2 in + ((m2+1)%nat, (true, m2), stseytin_and (true, m2) n1 n2 ++ f1 ++ f2) + end. + +Lemma stseytin_and_correct : + forall cur p1 p2 fm c, + stseytin_and cur p1 p2 = fm -> + satLit cur c -> + satLit p1 c /\ satLit p2 c -> + satFormula fm c. +Proof. + intros. + unfold stseytin_and in *. rewrite <- H. + unfold satLit in *. destruct p1. destruct p2. destruct cur. + simpl in *|-. cbn. unfold satLit. cbn. crush. +Qed. + +Lemma stseytin_and_correct2 : + forall cur p1 p2 fm c, + stseytin_and cur p1 p2 = fm -> + satFormula fm c -> + satLit cur c <-> satLit p1 c /\ satLit p2 c. +Proof. + intros. split. intros. inv H1. unfold stseytin_and in *. + inv H0; try contradiction. Admitted. + +Lemma stseytin_or_correct : + forall cur p1 p2 fm c, + stseytin_or cur p1 p2 = fm -> + satLit cur c -> + satLit p1 c \/ satLit p2 c -> + satFormula fm c. +Proof. + intros. + unfold stseytin_or in *. rewrite <- H. inv H1. + unfold satLit in *. destruct p1. destruct p2. destruct cur. + simpl in *|-. cbn. unfold satLit. cbn. crush. + unfold satLit in *. destruct p1. destruct p2. destruct cur. + simpl in *|-. cbn. unfold satLit. cbn. crush. +Qed. + +Lemma stseytin_or_correct2 : + forall cur p1 p2 fm c, + stseytin_or cur p1 p2 = fm -> + satFormula fm c -> + satLit cur c <-> satLit p1 c \/ satLit p2 c. +Proof. Admitted. + +Lemma xtseytin_correct : + forall p next l n fm c, + xtseytin next p = (n, l, fm) -> + sat_predicate p c = true <-> satFormula ((l::nil)::fm) c. +Proof. + induction p. + - intros. simplify. destruct p. + inv H. split. + intros. destruct b. split; crush. + apply negb_true_iff in H. + split; crush. + intros. inv H. inv H0; try contradiction. + inv H. simplify. rewrite <- H0. + destruct b. + rewrite -> H0; auto. + rewrite -> H0; auto. + - admit. + - admit. + - intros. split. intros. simpl in H0. + apply andb_prop in H0. inv H0. + cbn in H. + repeat destruct_match; try discriminate; []. inv H. eapply IHp1 in Heqp. + eapply IHp2 in Heqp1. apply Heqp1 in H2. + apply Heqp in H1. inv H1. inv H2. + assert + (satFormula + (((true, n1) :: bar l0 :: bar l1 :: nil) + :: (bar (true, n1) :: l0 :: nil) + :: (bar (true, n1) :: l1 :: nil) :: nil) c). + eapply stseytin_and_correct. unfold stseytin_and. eauto. + unfold satLit. simpl. admit. + inv H; try contradiction. inv H1; try contradiction. eauto. +Admitted. + +Fixpoint max_predicate (p: pred_op) : positive := + match p with + | Plit (b, p) => p + | Ptrue => 1 + | Pfalse => 1 + | Pand a b => Pos.max (max_predicate a) (max_predicate b) + | Por a b => Pos.max (max_predicate a) (max_predicate b) + end. + +Definition tseytin (p: pred_op) : + {fm: formula | forall a, + sat_predicate p a = true <-> satFormula fm a}. + refine ( + (match xtseytin (Pos.to_nat (max_predicate p + 1)) p as X + return xtseytin (Pos.to_nat (max_predicate p + 1)) p = X -> + {fm: formula | forall a, sat_predicate p a = true <-> satFormula fm a} + with (m, n, fm) => fun H => exist _ ((n::nil) :: fm) _ + end) (eq_refl (xtseytin (Pos.to_nat (max_predicate p + 1)) p))). + intros. eapply xtseytin_correct; eauto. Defined. + +Definition tseytin_simple (p: pred_op) : formula := + let m := Pos.to_nat (max_predicate p + 1) in + let '(m, n, fm) := xtseytin m p in + (n::nil) :: fm. + +Definition sat_pred_tseytin (p: pred_op) : + ({al : alist | sat_predicate p (interp_alist al) = true} + + {forall a : asgn, sat_predicate p a = false}). + refine + ( match tseytin p with + | exist _ fm _ => + match satSolve fm with + | inleft (exist _ a _) => inleft (exist _ a _) + | inright _ => inright _ + end + end ). + - apply i in s0. auto. + - intros. specialize (n a). specialize (i a). + destruct (sat_predicate p a). exfalso. + apply n. apply i. auto. auto. +Defined. + +Definition sat_pred_simple (p: pred_op) : option alist := + match sat_pred_tseytin p with + | inleft (exist _ a _) => Some a + | inright _ => None + end. + +Definition sat_pred (p: pred_op) : + ({al : alist | sat_predicate p (interp_alist al) = true} + + {forall a : asgn, sat_predicate p a = false}). + refine + ( match trans_pred p with + | exist _ fm _ => + match satSolve fm with + | inleft (exist _ a _) => inleft (exist _ a _) + | inright _ => inright _ + end + end ). + - apply i in s0. auto. + - intros. specialize (n a). specialize (i a). + destruct (sat_predicate p a). exfalso. + apply n. apply i. auto. auto. +Defined. + +#[local] Open Scope positive. + +Compute tseytin_simple (Por (negate (Pand (Por (Plit (true, 1)) (Plit (true, 2))) (Plit (true, 3)))) (Plit (false, 4))). +Compute sat_pred_simple (Por Pfalse (Pand (Plit (true, 1)) (Plit (false, 1)))). + +Lemma sat_dec a: {sat a} + {unsat a}. +Proof. + unfold sat, unsat. + destruct (sat_pred a). + intros. left. destruct s. + exists (Sat.interp_alist x). auto. + intros. tauto. +Qed. + +Definition equiv_check p1 p2 := + match sat_pred_simple (simplify (p1 ∧ ¬ p2 ∨ p2 ∧ ¬ p1)) with + | None => true + | _ => false + end. + +Compute equiv_check Pfalse (Pand (Plit (true, 1%positive)) (Plit (false, 1%positive))). + +Lemma equiv_check_correct : + forall p1 p2, equiv_check p1 p2 = true -> p1 == p2. +Proof. + unfold equiv_check. unfold sat_pred_simple. intros. + destruct_match; try discriminate; []. + destruct_match. destruct_match. discriminate. + eapply sat_equiv3; eauto. + unfold unsat; intros. + rewrite <- simplify_correct. eauto. +Qed. + +Opaque simplify. +Opaque simplify'. + +Lemma equiv_check_correct2 : + forall p1 p2, p1 == p2 -> equiv_check p1 p2 = true. +Proof. + unfold equiv_check, equiv, sat_pred_simple. intros. + destruct_match; auto. destruct_match; try discriminate. + destruct_match. + simplify. + apply sat_equiv4 in H. unfold unsat in H. simplify. + clear Heqs. rewrite simplify_correct in e. + specialize (H (interp_alist a)). simplify. + rewrite H1 in e. rewrite H0 in e. discriminate. +Qed. + +Lemma equiv_check_dec : + forall p1 p2, equiv_check p1 p2 = true <-> p1 == p2. +Proof. + intros; split; eauto using equiv_check_correct, equiv_check_correct2. +Qed. + +Lemma equiv_check_decidable : + forall p1 p2, decidable (p1 == p2). +Proof. + intros. destruct (equiv_check p1 p2) eqn:?. + unfold decidable. + left. apply equiv_check_dec; auto. + unfold decidable, not; right; intros. + apply equiv_check_dec in H. crush. +Qed. + +Lemma equiv_check_decidable2 : + forall p1 p2, {p1 == p2} + {p1 =/= p2}. +Proof. + intros. destruct (equiv_check p1 p2) eqn:?. + unfold decidable. + left. apply equiv_check_dec; auto. + unfold decidable, not; right; intros. + simpl. unfold complement. intros. + apply not_true_iff_false in Heqb. apply Heqb. + apply equiv_check_dec. eauto. +Qed. + +#[global] +Instance DecidableSATSetoid : DecidableSetoid SATSetoid := + { setoid_decidable := equiv_check_decidable }. + +#[global] +Instance SATSetoidEqDec : EqDec SATSetoid := equiv_check_decidable2. + +Definition Pimplies p p' := ¬ p ∨ p'. + +Notation "A → B" := (Pimplies A B) (at level 30) : pred_op. + +Definition implies p p' := + forall c, sat_predicate p c = true -> sat_predicate p' c = true. + +Notation "A ⇒ B" := (implies A B) (at level 35) : pred_op. + +Lemma Pimplies_implies: forall p p', (p → p') ∧ p ⇒ p'. +Proof. + unfold "→", "⇒"; simplify. + apply orb_prop in H0. inv H0; auto. rewrite negate_correct in H. + apply negb_true_iff in H. crush. +Qed. + +#[global] +Instance PimpliesProper : Proper (equiv ==> equiv ==> equiv) Pimplies. +Proof. + unfold Proper, "==>". simplify. unfold "→". + intros. + unfold sat_equiv in *. intros. + simplify. repeat rewrite negate_correct. rewrite H0. rewrite H. + auto. +Qed. + +#[global] +Instance simplifyProper : Proper (equiv ==> equiv) simplify. +Proof. + unfold Proper, "==>". simplify. unfold "→". + intros. unfold sat_equiv; intros. + rewrite ! simplify_correct; auto. +Qed. diff --git a/src/hls/PrintAbstr.ml b/src/hls/PrintAbstr.ml new file mode 100644 index 0000000..c63fa02 --- /dev/null +++ b/src/hls/PrintAbstr.ml @@ -0,0 +1,39 @@ +(**open Camlcoq +open Datatypes +open Maps +open AST +open Abstr +open PrintAST +open Printf + +let rec expr_to_list = function + | Enil -> [] + | Econs (e, el) -> e :: expr_to_list el + +let res pp = function + | Reg r -> fprintf pp "r%d" (P.to_int r) + | Pred r -> fprintf pp "p%d" (P.to_int r) + | Mem -> fprintf pp "M" + +let rec print_expression pp = function + | Ebase r -> fprintf pp "%a'" res r + | Eop (op, el) -> fprintf pp "(%a)" (PrintOp.print_operation print_expression) (op, expr_to_list el) + | Eload (chunk, addr, el, e) -> + fprintf pp "(%s[%a][%a])" + (name_of_chunk chunk) print_expression e + (PrintOp.print_addressing print_expression) (addr, expr_to_list el) + | Estore (e, chunk, addr, el, m) -> + fprintf pp "(%s[%a][%a] = %a)" + (name_of_chunk chunk) print_expression m + (PrintOp.print_addressing print_expression) (addr, expr_to_list el) + print_expression e + | Esetpred (c, el) -> + fprintf pp "(%a)" (PrintOp.print_condition print_expression) (c, expr_to_list el) + +let rec print_predicated pp = function + | NE.Coq_singleton (p, e) -> + fprintf pp "%a %a" PrintRTLBlockInstr.print_pred_option p print_expression e + | NE.Coq_cons ((p, e), pr) -> + fprintf pp "%a %a\n%a" PrintRTLBlockInstr.print_pred_option p print_expression e + print_predicated pr +*) diff --git a/src/hls/PrintExpression.ml b/src/hls/PrintExpression.ml new file mode 100644 index 0000000..df5dc37 --- /dev/null +++ b/src/hls/PrintExpression.ml @@ -0,0 +1,40 @@ +(*open Printf +open Camlcoq +open Datatypes +open Maps +open PrintAST +open RTLPargen + +let reg pp r = + fprintf pp "x%d" (P.to_int r) + +let pred pp r = + fprintf pp "p%d" (P.to_int r) + +let print_resource pp = function + | Reg r -> reg pp r + | Pred r -> pred pp r + | Mem -> fprintf pp "M" + +let rec to_expr_list = function + | Enil -> [] + | Econs (e, elist) -> e :: to_expr_list elist + +let rec print_expression pp = function + | Ebase r -> print_resource pp r + | Eop (op, elist, e) -> + PrintOp.print_operation print_expression pp (op, to_expr_list elist); + Printf.printf "; "; + print_expression pp e + | Eload (chunk, addr, elist, e) -> + fprintf pp "%s[%a]; " (name_of_chunk chunk) (PrintOp.print_addressing print_expression) (addr, to_expr_list elist); + print_expression pp e + | Estore (e, chunk, addr, elist, e') -> + fprintf pp "%s[%a] = %a; " (name_of_chunk chunk) + (PrintOp.print_addressing print_expression) (addr, to_expr_list elist) + print_expression e; + print_expression pp e + | Esetpred (cond, elist, e) -> + fprintf pp "%a; " (PrintOp.print_condition print_expression) (cond, to_expr_list elist); + print_expression pp e +*) diff --git a/src/hls/PrintHTL.ml b/src/hls/PrintHTL.ml index a75d0ee..5963be0 100644 --- a/src/hls/PrintHTL.ml +++ b/src/hls/PrintHTL.ml @@ -71,10 +71,10 @@ let print_program pp prog = let destination : string option ref = ref None -let print_if prog = +let print_if passno prog = match !destination with | None -> () | Some f -> - let oc = open_out f in + let oc = open_out (f ^ "." ^ Z.to_string passno) in print_program oc prog; close_out oc diff --git a/src/hls/PrintRTLBlockInstr.ml b/src/hls/PrintRTLBlockInstr.ml index 808d342..b8e1e2e 100644 --- a/src/hls/PrintRTLBlockInstr.ml +++ b/src/hls/PrintRTLBlockInstr.ml @@ -4,13 +4,14 @@ open Datatypes open Maps open AST open RTLBlockInstr +open Predicate open PrintAST let reg pp r = fprintf pp "x%d" (P.to_int r) let pred pp r = - fprintf pp "p%d" (Nat.to_int r) + fprintf pp "p%d" (P.to_int r) let rec regs pp = function | [] -> () @@ -22,10 +23,11 @@ let ros pp = function | Coq_inr s -> fprintf pp "\"%s\"" (extern_atom s) let rec print_pred_op pp = function - | Pvar p -> pred pp p - | Pnot p -> fprintf pp "(~ %a)" print_pred_op p - | Pand (p1, p2) -> fprintf pp "(%a & %a)" print_pred_op p1 print_pred_op p2 - | Por (p1, p2) -> fprintf pp "(%a | %a)" print_pred_op p1 print_pred_op p2 + | Plit p -> if fst p then pred pp (snd p) else fprintf pp "~%a" pred (snd p) + | Pand (p1, p2) -> fprintf pp "(%a ∧ %a)" print_pred_op p1 print_pred_op p2 + | Por (p1, p2) -> fprintf pp "(%a ∨ %a)" print_pred_op p1 print_pred_op p2 + | Ptrue -> fprintf pp "T" + | Pfalse -> fprintf pp "⟂" let print_pred_option pp = function | Some x -> fprintf pp "(%a)" print_pred_op x @@ -48,15 +50,11 @@ let print_bblock_body pp i = (name_of_chunk chunk) (PrintOp.print_addressing reg) (addr, args) reg src - | RBsetpred (c, args, p) -> - fprintf pp "%a = %a\n" + | RBsetpred (p', c, args, p) -> + fprintf pp "%a %a = %a\n" + print_pred_option p' pred p (PrintOp.print_condition reg) (c, args) - | RBpiped (p, fu, args) -> - fprintf pp "%a piped\n" print_pred_option p - | RBassign (p, fu, src, dst) -> - fprintf pp "%a %a = %a" print_pred_option p - reg src reg dst let rec print_bblock_exit pp i = fprintf pp "\t\t"; diff --git a/src/hls/printRTLPar.ml b/src/hls/PrintRTLPar.ml index 7fac0de..ab93fa5 100644 --- a/src/hls/printRTLPar.ml +++ b/src/hls/PrintRTLPar.ml @@ -38,9 +38,9 @@ let ros pp = function let print_bblock pp (pc, i) = fprintf pp "%5d:{\n" pc; - List.iter (fun x -> fprintf pp "["; - List.iter (fun x' -> fprintf pp "["; List.iter (print_bblock_body pp) x'; fprintf pp "]\n") x; - fprintf pp "]\n") i.bb_body; + List.iter (fun x -> fprintf pp "{\n"; + List.iter (fun x -> fprintf pp "( "; List.iter (print_bblock_body pp) x; fprintf pp " )") x; + fprintf pp "}\n") i.bb_body; print_bblock_exit pp i.bb_exit; fprintf pp "\t}\n\n" diff --git a/src/hls/PrintVerilog.ml b/src/hls/PrintVerilog.ml index da3bd6e..46b001e 100644 --- a/src/hls/PrintVerilog.ml +++ b/src/hls/PrintVerilog.ml @@ -76,14 +76,14 @@ let pprint_binop l r = let unop = function | Vneg -> " - " - | Vnot -> " ! " + | Vnot -> " ~ " let register a = match PMap.find_opt a !name_map with | Some s -> s | None -> sprintf "reg_%d" (P.to_int a) -(*let literal l = sprintf "%d'd%d" (Nat.to_int l.vsize) (Z.to_int (uvalueToZ l))*) +(*let literal l = s printf "%d'd%d" (Nat.to_int l.vsize) (Z.to_int (uvalueToZ l))*) let literal l = let l' = camlint_of_coqint l in @@ -119,7 +119,9 @@ let rec pprint_stmnt i = indent i; "end\n" ] | Vcase (e, es, d) -> concat [ indent i; "case ("; pprint_expr e; ")\n"; - fold_map pprint_case (List.sort compare_expr es |> List.rev); + fold_map pprint_case (stmnt_to_list es + |> List.sort compare_expr + |> List.rev); indent (i+1); "default:;\n"; indent i; "endcase\n" ] @@ -138,22 +140,22 @@ let pprint_edge_top i = function | Valledge -> "@*" | Voredge (e1, e2) -> concat ["@("; pprint_edge e1; " or "; pprint_edge e2; ")"] -let declare t = +let declare (t, i) = function (r, sz) -> concat [ t; " ["; sprintf "%d" (Nat.to_int sz - 1); ":0] "; - register r; ";\n" ] + register r; if i then " = 0;\n" else ";\n" ] -let declarearr t = +let declarearr (t, _) = function (r, sz, ln) -> concat [ t; " ["; sprintf "%d" (Nat.to_int sz - 1); ":0] "; register r; " ["; sprintf "%d" (Nat.to_int ln - 1); ":0];\n" ] let print_io = function - | Some Vinput -> "input logic" - | Some Voutput -> "output logic" - | Some Vinout -> "inout logic" - | None -> "logic" + | Some Vinput -> "input", false + | Some Voutput -> "output logic", true + | Some Vinout -> "inout", false + | None -> "logic", true let decl i = function | Vdecl (io, r, sz) -> concat [indent i; declare (print_io io) (r, sz)] @@ -163,11 +165,14 @@ let decl i = function let pprint_module_item i = function | Vdeclaration d -> decl i d | Valways (e, s) -> - concat [indent i; "always "; pprint_edge_top i e; "\n"; pprint_stmnt (i+1) s] + concat [indent i; "always "; pprint_edge_top i e; " begin\n"; + pprint_stmnt (i+1) s; indent i; "end\n"] | Valways_ff (e, s) -> - concat [indent i; "always "; pprint_edge_top i e; "\n"; pprint_stmnt (i+1) s] + concat [indent i; "always "; pprint_edge_top i e; " begin\n"; + pprint_stmnt (i+1) s; indent i; "end\n"] | Valways_comb (e, s) -> - concat [indent i; "always "; pprint_edge_top i e; "\n"; pprint_stmnt (i+1) s] + concat [indent i; "always "; pprint_edge_top i e; " begin\n"; + pprint_stmnt (i+1) s; indent i; "end\n"] let rec intersperse c = function | [] -> [] @@ -176,7 +181,7 @@ let rec intersperse c = function let make_io i io r = concat [indent i; io; " "; register r; ";\n"] -let print_funct_units clk = function +(**let print_funct_units clk = function | SignedDiv (stages, numer, denom, quot, rem) -> sprintf ("div_signed #(.stages(%d)) divs(.clk(%s), " ^^ ".clken(1'b1), .numer(%s), .denom(%s), " ^^ @@ -188,7 +193,7 @@ let print_funct_units clk = function ".clken(1'b1), .numer(%s), .denom(%s), " ^^ ".quotient(%s), .remain(%s))\n") (P.to_int stages) - (register clk) (register numer) (register denom) (register quot) (register rem) + (register clk) (register numer) (register denom) (register quot) (register rem)*) let compose f g x = g x |> f @@ -260,10 +265,7 @@ let pprint_module debug i n m = ]; concat [ indent i; "module "; (extern_atom n); "("; concat (intersperse ", " (List.map register (inputs @ outputs))); ");\n"; - fold_map (pprint_module_item (i+1)) m.mod_body; - concat (List.map (print_funct_units m.mod_clk) - (Maps.PTree.elements m.mod_funct_units.avail_units - |> List.map snd)); + fold_map (pprint_module_item (i+1)) (List.rev m.mod_body); if !option_initial then print_initial i (Nat.to_int m.mod_stk_len) m.mod_stk else ""; if debug then debug_always_verbose i m.mod_clk m.mod_st else ""; indent i; "endmodule\n\n" diff --git a/src/hls/RTLBlock.v b/src/hls/RTLBlock.v index 6a3487a..bf5c37a 100644 --- a/src/hls/RTLBlock.v +++ b/src/hls/RTLBlock.v @@ -58,11 +58,11 @@ Section RELSEM. Inductive step: state -> trace -> state -> Prop := | exec_bblock: - forall s f sp pc rs rs' m m' t s' bb, + forall s f sp pc rs rs' m m' t s' bb pr pr', f.(fn_code)!pc = Some bb -> - step_instr_list sp (InstrState rs m) bb.(bb_body) (InstrState rs' m') -> - step_cf_instr ge (State s f sp pc rs' m') bb.(bb_exit) t s' -> - step (State s f sp pc rs m) t s' + step_instr_list sp (mk_instr_state rs pr m) bb.(bb_body) (mk_instr_state rs' pr' m') -> + step_cf_instr ge (State s f sp pc rs' pr' m') bb.(bb_exit) t s' -> + step (State s f sp pc rs pr m) t s' | exec_function_internal: forall s f args m m' stk, Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> @@ -72,6 +72,7 @@ Section RELSEM. (Vptr stk Ptrofs.zero) f.(fn_entrypoint) (init_regs args f.(fn_params)) + (PMap.init false) m') | exec_function_external: forall s ef args res t m m', @@ -79,9 +80,9 @@ Section RELSEM. step (Callstate s (External ef) args m) t (Returnstate s res m') | exec_return: - forall res f sp pc rs s vres m, - step (Returnstate (Stackframe res f sp pc rs :: s) vres m) - E0 (State s f sp pc (rs#res <- vres) m). + forall res f sp pc rs s vres m pr, + step (Returnstate (Stackframe res f sp pc rs pr :: s) vres m) + E0 (State s f sp pc (rs#res <- vres) pr m). End RELSEM. diff --git a/src/hls/RTLBlockInstr.v b/src/hls/RTLBlockInstr.v index 69cc709..d9f3e74 100644 --- a/src/hls/RTLBlockInstr.v +++ b/src/hls/RTLBlockInstr.v @@ -28,232 +28,42 @@ Require Import compcert.lib.Integers. Require Import compcert.lib.Maps. Require Import compcert.verilog.Op. -Require Import vericert.common.Vericertlib. -Require Import vericert.hls.Sat. -Require Import vericert.hls.FunctionalUnits. +Require Import Predicate. +Require Import Vericertlib. -Local Open Scope rtl. +(*| +===================== +RTLBlock Instructions +===================== -Definition node := positive. -Definition predicate := nat. - -Inductive pred_op : Type := -| Pvar: predicate -> pred_op -| Pnot: pred_op -> pred_op -| Pand: pred_op -> pred_op -> pred_op -| Por: pred_op -> pred_op -> pred_op. - -Fixpoint sat_predicate (p: pred_op) (a: asgn) : bool := - match p with - | Pvar p' => a p' - | Pnot p' => negb (sat_predicate p' a) - | Pand p1 p2 => sat_predicate p1 a && sat_predicate p2 a - | Por p1 p2 => sat_predicate p1 a || sat_predicate p2 a - end. - -Fixpoint mult {A: Type} (a b: list (list A)) : list (list A) := - match a with - | nil => nil - | l :: ls => mult ls b ++ (List.map (fun x => l ++ x) b) - end. - -Lemma satFormula_concat: - forall a b agn, - satFormula a agn -> - satFormula b agn -> - satFormula (a ++ b) agn. -Proof. induction a; crush. Qed. - -Lemma satFormula_concat2: - forall a b agn, - satFormula (a ++ b) agn -> - satFormula a agn /\ satFormula b agn. -Proof. - induction a; simplify; - try apply IHa in H1; crush. -Qed. - -Lemma satClause_concat: - forall a a1 a0, - satClause a a1 -> - satClause (a0 ++ a) a1. -Proof. induction a0; crush. Qed. - -Lemma satClause_concat2: - forall a a1 a0, - satClause a0 a1 -> - satClause (a0 ++ a) a1. -Proof. - induction a0; crush. - inv H; crush. -Qed. - -Lemma satClause_concat3: - forall a b c, - satClause (a ++ b) c -> - satClause a c \/ satClause b c. -Proof. - induction a; crush. - inv H; crush. - apply IHa in H0; crush. - inv H0; crush. -Qed. - -Lemma satFormula_mult': - forall p2 a a0, - satFormula p2 a0 \/ satClause a a0 -> - satFormula (map (fun x : list lit => a ++ x) p2) a0. -Proof. - induction p2; crush. - - inv H. inv H0. apply satClause_concat. auto. - apply satClause_concat2; auto. - - apply IHp2. - inv H; crush; inv H0; crush. -Qed. - -Lemma satFormula_mult2': - forall p2 a a0, - satFormula (map (fun x : list lit => a ++ x) p2) a0 -> - satClause a a0 \/ satFormula p2 a0. -Proof. - induction p2; crush. - apply IHp2 in H1. inv H1; crush. - apply satClause_concat3 in H0. - inv H0; crush. -Qed. - -Lemma satFormula_mult: - forall p1 p2 a, - satFormula p1 a \/ satFormula p2 a -> - satFormula (mult p1 p2) a. -Proof. - induction p1; crush. - apply satFormula_concat; crush. - inv H. inv H0. - apply IHp1. auto. - apply IHp1. auto. - apply satFormula_mult'; - inv H; crush. -Qed. - -Lemma satFormula_mult2: - forall p1 p2 a, - satFormula (mult p1 p2) a -> - satFormula p1 a \/ satFormula p2 a. -Proof. - induction p1; crush. - apply satFormula_concat2 in H; crush. - apply IHp1 in H0. - inv H0; crush. - apply satFormula_mult2' in H1. inv H1; crush. -Qed. - -Fixpoint trans_pred_temp (bound: nat) (p: pred_op) : option formula := - match bound with - | O => None - | S n => - match p with - | Pvar p' => Some (((true, p') :: nil) :: nil) - | Pand p1 p2 => - match trans_pred_temp n p1, trans_pred_temp n p2 with - | Some p1', Some p2' => - Some (p1' ++ p2') - | _, _ => None - end - | Por p1 p2 => - match trans_pred_temp n p1, trans_pred_temp n p2 with - | Some p1', Some p2' => - Some (mult p1' p2') - | _, _ => None - end - | Pnot (Pvar p') => Some (((false, p') :: nil) :: nil) - | Pnot (Pnot p) => trans_pred_temp n p - | Pnot (Pand p1 p2) => trans_pred_temp n (Por (Pnot p1) (Pnot p2)) - | Pnot (Por p1 p2) => trans_pred_temp n (Pand (Pnot p1) (Pnot p2)) - end - end. +These instructions are used for ``RTLBlock`` and ``RTLPar``, so that they have consistent +instructions, which greatly simplifies the proofs, as they will by default have the same instruction +syntax and semantics. The only changes are therefore at the top-level of the instructions. -Fixpoint trans_pred (bound: nat) (p: pred_op) : - option {fm: formula | forall a, - sat_predicate p a = true <-> satFormula fm a}. - refine - (match bound with - | O => None - | S n => - match p with - | Pvar p' => Some (exist _ (((true, p') :: nil) :: nil) _) - | Pand p1 p2 => - match trans_pred n p1, trans_pred n p2 with - | Some (exist p1' _), Some (exist p2' _) => - Some (exist _ (p1' ++ p2') _) - | _, _ => None - end - | Por p1 p2 => - match trans_pred n p1, trans_pred n p2 with - | Some (exist p1' _), Some (exist p2' _) => - Some (exist _ (mult p1' p2') _) - | _, _ => None - end - | Pnot (Pvar p') => Some (exist _ (((false, p') :: nil) :: nil) _) - | _ => None - end - end); split; intros; simpl in *; auto. - - inv H. inv H0; auto. - - admit. - - admit. - - apply satFormula_concat. - apply andb_prop in H. inv H. apply i in H0. auto. - apply andb_prop in H. inv H. apply i0 in H1. auto. - - apply satFormula_concat2 in H. simplify. apply andb_true_intro. - split. apply i in H0. auto. - apply i0 in H1. auto. - - apply orb_prop in H. inv H; apply satFormula_mult. apply i in H0. auto. - apply i0 in H0. auto. - - apply orb_true_intro. - apply satFormula_mult2 in H. inv H. apply i in H0. auto. - apply i0 in H0. auto. -Admitted. - -Definition sat_pred (bound: nat) (p: pred_op) : - option ({al : alist | sat_predicate p (interp_alist al) = true} - + {forall a : asgn, sat_predicate p a = false}). - refine - ( match trans_pred bound p with - | Some (exist fm _) => - match boundedSat bound fm with - | Some (inleft (exist a _)) => Some (inleft (exist _ a _)) - | Some (inright _) => Some (inright _) - | None => None - end - | None => None - end ). - - apply i in s2. auto. - - intros. specialize (n a). specialize (i a). - destruct (sat_predicate p a). exfalso. - apply n. apply i. auto. auto. -Qed. +Instruction Definition +====================== -Definition sat_pred_simple (bound: nat) (p: pred_op) := - match sat_pred bound p with - | Some (inleft (exist al _)) => Some (Some al) - | Some (inright _) => Some None - | None => None - end. +First, we define the instructions that can be placed into a basic block, meaning they won't branch. +The main changes to how instructions are defined in ``RTL``, is that these instructions don't have a +next node, as they will be in a basic block, and they also have an optional predicate (``pred_op``). +|*) -Definition sat_pred_temp (bound: nat) (p: pred_op) := - match trans_pred_temp bound p with - | Some fm => boundedSatSimple bound fm - | None => None - end. +Definition node := positive. Inductive instr : Type := | RBnop : instr | RBop : option pred_op -> operation -> list reg -> reg -> instr | RBload : option pred_op -> memory_chunk -> addressing -> list reg -> reg -> instr | RBstore : option pred_op -> memory_chunk -> addressing -> list reg -> reg -> instr -| RBpiped : option pred_op -> funct_node -> list reg -> instr -| RBassign : option pred_op -> funct_node -> reg -> reg -> instr -| RBsetpred : condition -> list reg -> predicate -> instr. +| RBsetpred : option pred_op -> condition -> list reg -> predicate -> instr. + +(*| +Control-Flow Instruction Definition +=================================== + +These are the instructions that count as control-flow, and will be placed at the end of the basic +blocks. +|*) Inductive cf_instr : Type := | RBcall : signature -> reg + ident -> list reg -> reg -> node -> cf_instr @@ -266,6 +76,11 @@ Inductive cf_instr : Type := | RBgoto : node -> cf_instr | RBpred_cf : pred_op -> cf_instr -> cf_instr -> cf_instr. +(*| +Helper functions +================ +|*) + Fixpoint successors_instr (i : cf_instr) : list node := match i with | RBcall sig ros args res s => s :: nil @@ -287,11 +102,7 @@ Definition max_reg_instr (m: positive) (i: instr) := fold_left Pos.max args (Pos.max dst m) | RBstore p chunk addr args src => fold_left Pos.max args (Pos.max src m) - | RBpiped p f args => - fold_left Pos.max args m - | RBassign p f src dst => - Pos.max src (Pos.max dst m) - | RBsetpred c args p => + | RBsetpred p' c args p => fold_left Pos.max args m end. @@ -317,6 +128,41 @@ Fixpoint max_reg_cfi (m : positive) (i : cf_instr) := end. Definition regset := Regmap.t val. +Definition predset := PMap.t bool. + +Definition eval_predf (pr: predset) (p: pred_op) := + sat_predicate p (fun x => pr !! (Pos.of_nat x)). + +#[global] +Instance eval_predf_Proper : Proper (eq ==> equiv ==> eq) eval_predf. +Proof. + unfold Proper. simplify. unfold "==>". + intros. + unfold sat_equiv in *. intros. unfold eval_predf. subst. apply H0. +Qed. + +#[local] Open Scope pred_op. + +Lemma eval_predf_Pand : + forall ps p p', + eval_predf ps (p ∧ p') = eval_predf ps p && eval_predf ps p'. +Proof. unfold eval_predf; split; simplify; auto with bool. Qed. + +Lemma eval_predf_Por : + forall ps p p', + eval_predf ps (p ∨ p') = eval_predf ps p || eval_predf ps p'. +Proof. unfold eval_predf; split; simplify; auto with bool. Qed. + +Lemma eval_predf_pr_equiv : + forall p ps ps', + (forall x, ps !! x = ps' !! x) -> + eval_predf ps p = eval_predf ps' p. +Proof. + induction p; simplify; auto; + try (unfold eval_predf; simplify; repeat (destruct_match; []); inv Heqp0; rewrite <- H; auto); + [repeat rewrite eval_predf_Pand|repeat rewrite eval_predf_Por]; + erewrite IHp1; try eassumption; erewrite IHp2; eauto. +Qed. Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset := match rl, vl with @@ -324,11 +170,28 @@ Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset := | _, _ => Regmap.init Vundef end. -Inductive instr_state : Type := -| InstrState: - forall (rs: regset) - (m: mem), - instr_state. +(*| +Instruction State +----------------- + +Definition of the instruction state, which contains the following: + +:is_rs: This is the current state of the registers. +:is_ps: This is the current state of the predicate registers, which is in a separate namespace and + area compared to the standard registers in ``is_rs``. +:is_mem: The current state of the memory. +|*) + +Record instr_state := mk_instr_state { + is_rs: regset; + is_ps: predset; + is_mem: mem; +}. + +(*| +Top-Level Type Definitions +========================== +|*) Section DEFINITION. @@ -346,7 +209,6 @@ Section DEFINITION. fn_params: list reg; fn_stacksize: Z; fn_code: code; - fn_funct_units: funct_units; fn_entrypoint: node }. @@ -366,7 +228,8 @@ Section DEFINITION. (f: function) (**r calling function *) (sp: val) (**r stack pointer in calling function *) (pc: node) (**r program point in calling function *) - (rs: regset), (**r register state in calling function *) + (rs: regset) (**r register state in calling function *) + (pr: predset), (**r predicate state of the calling function *) stackframe. Inductive state : Type := @@ -376,6 +239,7 @@ Section DEFINITION. (sp: val) (**r stack pointer *) (pc: node) (**r current program point in [c] *) (rs: regset) (**r register state *) + (pr: predset) (**r predicate register state *) (m: mem), (**r memory state *) state | Callstate: @@ -392,6 +256,11 @@ Section DEFINITION. End DEFINITION. +(*| +Semantics +========= +|*) + Section RELSEM. Context {bblock_body : Type}. @@ -411,67 +280,88 @@ Section RELSEM. end end. + Inductive eval_pred: option pred_op -> instr_state -> instr_state -> instr_state -> Prop := + | eval_pred_true: + forall i i' p, + eval_predf (is_ps i) p = true -> + eval_pred (Some p) i i' i' + | eval_pred_false: + forall i i' p, + eval_predf (is_ps i) p = false -> + eval_pred (Some p) i i' i + | eval_pred_none: + forall i i', eval_pred None i i' i. + Inductive step_instr: val -> instr_state -> instr -> instr_state -> Prop := | exec_RBnop: - forall rs m sp, - step_instr sp (InstrState rs m) RBnop (InstrState rs m) + forall sp ist, + step_instr sp ist RBnop ist | exec_RBop: - forall op v res args rs m sp p, - eval_operation ge sp op rs##args m = Some v -> - step_instr sp (InstrState rs m) - (RBop p op args res) - (InstrState (rs#res <- v) m) + forall op v res args rs m sp p ist pr, + eval_operation ge sp op rs##args m = Some v -> + eval_pred p (mk_instr_state rs pr m) (mk_instr_state (rs#res <- v) pr m) ist -> + step_instr sp (mk_instr_state rs pr m) (RBop p op args res) ist | exec_RBload: - forall addr rs args a chunk m v dst sp p, - eval_addressing ge sp addr rs##args = Some a -> - Mem.loadv chunk m a = Some v -> - step_instr sp (InstrState rs m) - (RBload p chunk addr args dst) - (InstrState (rs#dst <- v) m) + forall addr rs args a chunk m v dst sp p pr ist, + eval_addressing ge sp addr rs##args = Some a -> + Mem.loadv chunk m a = Some v -> + eval_pred p (mk_instr_state rs pr m) (mk_instr_state (rs#dst <- v) pr m) ist -> + step_instr sp (mk_instr_state rs pr m) (RBload p chunk addr args dst) ist | exec_RBstore: - forall addr rs args a chunk m src m' sp p, - eval_addressing ge sp addr rs##args = Some a -> - Mem.storev chunk m a rs#src = Some m' -> - step_instr sp (InstrState rs m) - (RBstore p chunk addr args src) - (InstrState rs m'). + forall addr rs args a chunk m src m' sp p pr ist, + eval_addressing ge sp addr rs##args = Some a -> + Mem.storev chunk m a rs#src = Some m' -> + eval_pred p (mk_instr_state rs pr m) (mk_instr_state rs pr m') ist -> + step_instr sp (mk_instr_state rs pr m) (RBstore p chunk addr args src) ist + | exec_RBsetpred: + forall sp rs pr m p c b args p' ist, + Op.eval_condition c rs##args m = Some b -> + eval_pred p' (mk_instr_state rs pr m) (mk_instr_state rs (pr#p <- b) m) ist -> + step_instr sp (mk_instr_state rs pr m) (RBsetpred p' c args p) ist. Inductive step_cf_instr: state -> cf_instr -> trace -> state -> Prop := | exec_RBcall: - forall s f sp rs m res fd ros sig args pc pc', + forall s f sp rs m res fd ros sig args pc pc' pr, find_function ros rs = Some fd -> funsig fd = sig -> - step_cf_instr (State s f sp pc rs m) (RBcall sig ros args res pc') - E0 (Callstate (Stackframe res f sp pc' rs :: s) fd rs##args m) + step_cf_instr (State s f sp pc rs pr m) (RBcall sig ros args res pc') + E0 (Callstate (Stackframe res f sp pc' rs pr :: s) fd rs##args m) | exec_RBtailcall: - forall s f stk rs m sig ros args fd m' pc, + forall s f stk rs m sig ros args fd m' pc pr, find_function ros rs = Some fd -> funsig fd = sig -> Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - step_cf_instr (State s f (Vptr stk Ptrofs.zero) pc rs m) (RBtailcall sig ros args) + step_cf_instr (State s f (Vptr stk Ptrofs.zero) pc rs pr m) (RBtailcall sig ros args) E0 (Callstate s fd rs##args m') | exec_RBbuiltin: - forall s f sp rs m ef args res pc' vargs t vres m' pc, + forall s f sp rs m ef args res pc' vargs t vres m' pc pr, eval_builtin_args ge (fun r => rs#r) sp m args vargs -> external_call ef ge vargs m t vres m' -> - step_cf_instr (State s f sp pc rs m) (RBbuiltin ef args res pc') - t (State s f sp pc' (regmap_setres res vres rs) m') + step_cf_instr (State s f sp pc rs pr m) (RBbuiltin ef args res pc') + t (State s f sp pc' (regmap_setres res vres rs) pr m') | exec_RBcond: - forall s f sp rs m cond args ifso ifnot b pc pc', + forall s f sp rs m cond args ifso ifnot b pc pc' pr, eval_condition cond rs##args m = Some b -> pc' = (if b then ifso else ifnot) -> - step_cf_instr (State s f sp pc rs m) (RBcond cond args ifso ifnot) - E0 (State s f sp pc' rs m) + step_cf_instr (State s f sp pc rs pr m) (RBcond cond args ifso ifnot) + E0 (State s f sp pc' rs pr m) | exec_RBjumptable: - forall s f sp rs m arg tbl n pc pc', + forall s f sp rs m arg tbl n pc pc' pr, rs#arg = Vint n -> list_nth_z tbl (Int.unsigned n) = Some pc' -> - step_cf_instr (State s f sp pc rs m) (RBjumptable arg tbl) - E0 (State s f sp pc' rs m) - | exec_Ireturn: - forall s f stk rs m or pc m', + step_cf_instr (State s f sp pc rs pr m) (RBjumptable arg tbl) + E0 (State s f sp pc' rs pr m) + | exec_RBreturn: + forall s f stk rs m or pc m' pr, Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - step_cf_instr (State s f (Vptr stk Ptrofs.zero) pc rs m) (RBreturn or) - E0 (Returnstate s (regmap_optget or Vundef rs) m'). + step_cf_instr (State s f (Vptr stk Ptrofs.zero) pc rs pr m) (RBreturn or) + E0 (Returnstate s (regmap_optget or Vundef rs) m') + | exec_RBgoto: + forall s f sp pc rs pr m pc', + step_cf_instr (State s f sp pc rs pr m) (RBgoto pc') E0 (State s f sp pc' rs pr m) + | exec_RBpred_cf: + forall s f sp pc rs pr m cf1 cf2 st' p t, + step_cf_instr (State s f sp pc rs pr m) (if eval_predf pr p then cf1 else cf2) t st' -> + step_cf_instr (State s f sp pc rs pr m) (RBpred_cf p cf1 cf2) t st'. End RELSEM. diff --git a/src/hls/RTLPar.v b/src/hls/RTLPar.v index 2e78d36..4986cff 100644 --- a/src/hls/RTLPar.v +++ b/src/hls/RTLPar.v @@ -80,11 +80,11 @@ Section RELSEM. Inductive step: state -> trace -> state -> Prop := | exec_bblock: - forall s f sp pc rs rs' m m' t s' bb, + forall s f sp pc rs rs' m m' t s' bb pr pr', f.(fn_code)!pc = Some bb -> - step_instr_block sp (InstrState rs m) bb.(bb_body) (InstrState rs' m') -> - step_cf_instr ge (State s f sp pc rs' m') bb.(bb_exit) t s' -> - step (State s f sp pc rs m) t s' + step_instr_block sp (mk_instr_state rs pr m) bb.(bb_body) (mk_instr_state rs' pr' m') -> + step_cf_instr ge (State s f sp pc rs' pr' m') bb.(bb_exit) t s' -> + step (State s f sp pc rs pr m) t s' | exec_function_internal: forall s f args m m' stk, Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> @@ -94,6 +94,7 @@ Section RELSEM. (Vptr stk Ptrofs.zero) f.(fn_entrypoint) (init_regs args f.(fn_params)) + (PMap.init false) m') | exec_function_external: forall s ef args res t m m', @@ -101,9 +102,9 @@ Section RELSEM. step (Callstate s (External ef) args m) t (Returnstate s res m') | exec_return: - forall res f sp pc rs s vres m, - step (Returnstate (Stackframe res f sp pc rs :: s) vres m) - E0 (State s f sp pc (rs#res <- vres) m). + forall res f sp pc rs s vres m pr, + step (Returnstate (Stackframe res f sp pc rs pr :: s) vres m) + E0 (State s f sp pc (rs#res <- vres) pr m). End RELSEM. diff --git a/src/hls/RTLParFU.v b/src/hls/RTLParFU.v new file mode 100644 index 0000000..f0ceafd --- /dev/null +++ b/src/hls/RTLParFU.v @@ -0,0 +1,389 @@ +(* + * Vericert: Verified high-level synthesis. + * Copyright (C) 2020-2021 Yann Herklotz <yann@yannherklotz.com> + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see <https://www.gnu.org/licenses/>. + *) + +Require Import compcert.backend.Registers. +Require Import compcert.common.AST. +Require Import compcert.common.Events. +Require Import compcert.common.Globalenvs. +Require Import compcert.common.Memory. +Require Import compcert.common.Smallstep. +Require Import compcert.common.Values. +Require Import compcert.lib.Coqlib. +Require Import compcert.lib.Integers. +Require Import compcert.lib.Maps. +Require Import compcert.verilog.Op. + +Require Import vericert.hls.FunctionalUnits. +Require Import Predicate. +Require Import Vericertlib. + +Definition node := positive. + +Inductive instr : Type := +| FUnop : instr +| FUop : option pred_op -> operation -> list reg -> reg -> instr +| FUread : positive -> positive -> reg -> instr +| FUwrite : positive -> positive -> reg -> instr +| FUsetpred : option pred_op -> condition -> list reg -> predicate -> instr. + +Inductive cf_instr : Type := +| FUcall : signature -> reg + ident -> list reg -> reg -> node -> cf_instr +| FUtailcall : signature -> reg + ident -> list reg -> cf_instr +| FUbuiltin : external_function -> list (builtin_arg reg) -> + builtin_res reg -> node -> cf_instr +| FUcond : condition -> list reg -> node -> node -> cf_instr +| FUjumptable : reg -> list node -> cf_instr +| FUreturn : option reg -> cf_instr +| FUgoto : node -> cf_instr +| FUpred_cf : pred_op -> cf_instr -> cf_instr -> cf_instr. + +Fixpoint successors_instr (i : cf_instr) : list node := + match i with + | FUcall sig ros args res s => s :: nil + | FUtailcall sig ros args => nil + | FUbuiltin ef args res s => s :: nil + | FUcond cond args ifso ifnot => ifso :: ifnot :: nil + | FUjumptable arg tbl => tbl + | FUreturn optarg => nil + | FUgoto n => n :: nil + | FUpred_cf p c1 c2 => concat (successors_instr c1 :: successors_instr c2 :: nil) + end. + +Definition max_reg_instr (m: positive) (i: instr) := + match i with + | FUnop => m + | FUop p op args res => + fold_left Pos.max args (Pos.max res m) + | FUread p1 p2 r => Pos.max m r + | FUwrite p1 p2 r => Pos.max m r + | FUsetpred p' c args p => + fold_left Pos.max args m + end. + +Fixpoint max_reg_cfi (m : positive) (i : cf_instr) := + match i with + | FUcall sig (inl r) args res s => + fold_left Pos.max args (Pos.max r (Pos.max res m)) + | FUcall sig (inr id) args res s => + fold_left Pos.max args (Pos.max res m) + | FUtailcall sig (inl r) args => + fold_left Pos.max args (Pos.max r m) + | FUtailcall sig (inr id) args => + fold_left Pos.max args m + | FUbuiltin ef args res s => + fold_left Pos.max (params_of_builtin_args args) + (fold_left Pos.max (params_of_builtin_res res) m) + | FUcond cond args ifso ifnot => fold_left Pos.max args m + | FUjumptable arg tbl => Pos.max arg m + | FUreturn None => m + | FUreturn (Some arg) => Pos.max arg m + | FUgoto n => m + | FUpred_cf p c1 c2 => Pos.max (max_reg_cfi m c1) (max_reg_cfi m c2) + end. + +Definition regset := Regmap.t val. +Definition predset := PMap.t bool. + +Definition eval_predf (pr: predset) (p: pred_op) := + sat_predicate p (fun x => pr !! (Pos.of_nat x)). + +#[global] + Instance eval_predf_Proper : Proper (eq ==> equiv ==> eq) eval_predf. +Proof. + unfold Proper. simplify. unfold "==>". + intros. + unfold sat_equiv in *. intros. unfold eval_predf. subst. apply H0. +Qed. + +#[local] Open Scope pred_op. + +Lemma eval_predf_Pand : + forall ps p p', + eval_predf ps (p ∧ p') = eval_predf ps p && eval_predf ps p'. +Proof. unfold eval_predf; split; simplify; auto with bool. Qed. + +Lemma eval_predf_Por : + forall ps p p', + eval_predf ps (p ∨ p') = eval_predf ps p || eval_predf ps p'. +Proof. unfold eval_predf; split; simplify; auto with bool. Qed. + +Lemma eval_predf_pr_equiv : + forall p ps ps', + (forall x, ps !! x = ps' !! x) -> + eval_predf ps p = eval_predf ps' p. +Proof. + induction p; simplify; auto; + try (unfold eval_predf; simplify; repeat (destruct_match; []); inv Heqp0; rewrite <- H; auto); + [repeat rewrite eval_predf_Pand|repeat rewrite eval_predf_Por]; + erewrite IHp1; try eassumption; erewrite IHp2; eauto. +Qed. + +Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset := + match rl, vl with + | r1 :: rs, v1 :: vs => Regmap.set r1 v1 (init_regs vs rs) + | _, _ => Regmap.init Vundef + end. + +Definition bblock_body := list (list (list instr)). + +Record bblock : Type := + mk_bblock { + bb_body: bblock_body; + bb_exit: cf_instr + }. + +Definition code: Type := PTree.t bblock. + +Record function: Type := + mkfunction { + fn_sig: signature; + fn_params: list reg; + fn_stacksize: Z; + fn_code: code; + fn_funct_units: resources; + fn_entrypoint: node; + }. + +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. + +Definition funsig (fd: fundef) := + match fd with + | Internal f => fn_sig f + | External ef => ef_sig ef + end. + +Inductive stackframe : Type := +| Stackframe: + forall (res: reg) (**r where to store the result *) + (f: function) (**r calling function *) + (sp: val) (**r stack pointer in calling function *) + (pc: node) (**r program point in calling function *) + (rs: regset) (**r register state in calling function *) + (pr: predset), (**r predicate state of the calling function *) + stackframe. + +Inductive state : Type := +| State: + forall (stack: list stackframe) (**r call stack *) + (f: function) (**r current function *) + (sp: val) (**r stack pointer *) + (pc: node) (**r current program point in [c] *) + (rs: regset) (**r register state *) + (pr: predset) (**r predicate register state *) + (m: mem), (**r memory state *) + state +| Callstate: + forall (stack: list stackframe) (**r call stack *) + (f: fundef) (**r function to call *) + (args: list val) (**r arguments to the call *) + (m: mem), (**r memory state *) + state +| Returnstate: + forall (stack: list stackframe) (**r call stack *) + (v: val) (**r return value for the call *) + (m: mem), (**r memory state *) + state. + +Record instr_state := mk_instr_state { + is_rs: regset; + is_ps: predset; + is_mem: mem; + }. + +Definition genv := Genv.t fundef unit. + +Section RELSEM. + + Context (ge: genv). + + Definition find_function + (ros: reg + ident) (rs: regset) : option fundef := + match ros with + | inl r => Genv.find_funct ge rs#r + | inr symb => + match Genv.find_symbol ge symb with + | None => None + | Some b => Genv.find_funct_ptr ge b + end + end. + + Inductive eval_pred: option pred_op -> instr_state -> instr_state -> instr_state -> Prop := + | eval_pred_true: + forall i i' p, + eval_predf (is_ps i) p = true -> + eval_pred (Some p) i i' i' + | eval_pred_false: + forall i i' p, + eval_predf (is_ps i) p = false -> + eval_pred (Some p) i i' i + | eval_pred_none: + forall i i', eval_pred None i i' i. + + Inductive step_instr: val -> instr_state -> instr -> instr_state -> Prop := + | exec_FUnop: + forall sp ist, + step_instr sp ist FUnop ist + | exec_FUop: + forall op v res args rs m sp p ist pr, + eval_operation ge sp op rs##args m = Some v -> + eval_pred p (mk_instr_state rs pr m) (mk_instr_state (rs#res <- v) pr m) ist -> + step_instr sp (mk_instr_state rs pr m) (FUop p op args res) ist + | exec_FUsetpred: + forall sp rs pr m p c b args p' ist, + Op.eval_condition c rs##args m = Some b -> + eval_pred p' (mk_instr_state rs pr m) (mk_instr_state rs (pr#p <- b) m) ist -> + step_instr sp (mk_instr_state rs pr m) (FUsetpred p' c args p) ist. + + Inductive step_instr_list: val -> instr_state -> list instr -> instr_state -> Prop := + | exec_RBcons: + forall state i state' state'' instrs sp, + step_instr sp state i state' -> + step_instr_list sp state' instrs state'' -> + step_instr_list sp state (i :: instrs) state'' + | exec_RBnil: + forall state sp, + step_instr_list sp state nil state. + + Inductive step_instr_seq (sp : val) + : instr_state -> list (list instr) -> instr_state -> Prop := + | exec_instr_seq_cons: + forall state i state' state'' instrs, + step_instr_list sp state i state' -> + step_instr_seq sp state' instrs state'' -> + step_instr_seq sp state (i :: instrs) state'' + | exec_instr_seq_nil: + forall state, + step_instr_seq sp state nil state. + + Inductive step_instr_block (sp : val) + : instr_state -> bblock_body -> instr_state -> Prop := + | exec_instr_block_cons: + forall state i state' state'' instrs, + step_instr_seq sp state i state' -> + step_instr_block sp state' instrs state'' -> + step_instr_block sp state (i :: instrs) state'' + | exec_instr_block_nil: + forall state, + step_instr_block sp state nil state. + + Inductive step_cf_instr: state -> cf_instr -> trace -> state -> Prop := + | exec_FUcall: + forall s f sp rs m res fd ros sig args pc pc' pr, + find_function ros rs = Some fd -> + funsig fd = sig -> + step_cf_instr (State s f sp pc rs pr m) (FUcall sig ros args res pc') + E0 (Callstate (Stackframe res f sp pc' rs pr :: s) fd rs##args m) + | exec_FUtailcall: + forall s f stk rs m sig ros args fd m' pc pr, + find_function ros rs = Some fd -> + funsig fd = sig -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + step_cf_instr (State s f (Vptr stk Ptrofs.zero) pc rs pr m) (FUtailcall sig ros args) + E0 (Callstate s fd rs##args m') + | exec_FUbuiltin: + forall s f sp rs m ef args res pc' vargs t vres m' pc pr, + eval_builtin_args ge (fun r => rs#r) sp m args vargs -> + external_call ef ge vargs m t vres m' -> + step_cf_instr (State s f sp pc rs pr m) (FUbuiltin ef args res pc') + t (State s f sp pc' (regmap_setres res vres rs) pr m') + | exec_FUcond: + forall s f sp rs m cond args ifso ifnot b pc pc' pr, + eval_condition cond rs##args m = Some b -> + pc' = (if b then ifso else ifnot) -> + step_cf_instr (State s f sp pc rs pr m) (FUcond cond args ifso ifnot) + E0 (State s f sp pc' rs pr m) + | exec_FUjumptable: + forall s f sp rs m arg tbl n pc pc' pr, + rs#arg = Vint n -> + list_nth_z tbl (Int.unsigned n) = Some pc' -> + step_cf_instr (State s f sp pc rs pr m) (FUjumptable arg tbl) + E0 (State s f sp pc' rs pr m) + | exec_FUreturn: + forall s f stk rs m or pc m' pr, + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + step_cf_instr (State s f (Vptr stk Ptrofs.zero) pc rs pr m) (FUreturn or) + E0 (Returnstate s (regmap_optget or Vundef rs) m') + | exec_FUgoto: + forall s f sp pc rs pr m pc', + step_cf_instr (State s f sp pc rs pr m) (FUgoto pc') E0 (State s f sp pc' rs pr m) + | exec_FUpred_cf: + forall s f sp pc rs pr m cf1 cf2 st' p t, + step_cf_instr (State s f sp pc rs pr m) (if eval_predf pr p then cf1 else cf2) t st' -> + step_cf_instr (State s f sp pc rs pr m) (FUpred_cf p cf1 cf2) t st'. + + Inductive step: state -> trace -> state -> Prop := + | exec_bblock: + forall s f sp pc rs rs' m m' t s' bb pr pr', + f.(fn_code)!pc = Some bb -> + step_instr_block sp (mk_instr_state rs pr m) bb.(bb_body) (mk_instr_state rs' pr' m') -> + step_cf_instr (State s f sp pc rs' pr' m') bb.(bb_exit) t s' -> + step (State s f sp pc rs pr m) t s' + | exec_function_internal: + forall s f args m m' stk, + Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> + step (Callstate s (Internal f) args m) + E0 (State s + f + (Vptr stk Ptrofs.zero) + f.(fn_entrypoint) + (init_regs args f.(fn_params)) + (PMap.init false) m') + | exec_function_external: + forall s ef args res t m m', + external_call ef ge args m t res m' -> + step (Callstate s (External ef) args m) + t (Returnstate s res m') + | exec_return: + forall res f sp pc rs s vres m pr, + step (Returnstate (Stackframe res f sp pc rs pr :: s) vres m) + E0 (State s f sp pc (rs#res <- vres) pr m). + +End RELSEM. + +Inductive initial_state (p: program): state -> Prop := +| initial_state_intro: forall b f m0, + let ge := Genv.globalenv p in + Genv.init_mem p = Some m0 -> + Genv.find_symbol ge p.(prog_main) = Some b -> + Genv.find_funct_ptr ge b = Some f -> + funsig f = signature_main -> + initial_state p (Callstate nil f nil m0). + +Inductive final_state: state -> int -> Prop := +| final_state_intro: forall r m, + final_state (Returnstate nil (Vint r) m) r. + +Definition semantics (p: program) := + Semantics step (initial_state p) final_state (Genv.globalenv p). + +Definition max_reg_bblock (m : positive) (pc : node) (bb : bblock) := + let max_body := fold_left (fun x l => fold_left (fun x' l' => fold_left max_reg_instr l' x') l x) bb.(bb_body) m in + max_reg_cfi max_body bb.(bb_exit). + +Definition max_reg_function (f: function) := + Pos.max + (PTree.fold max_reg_bblock f.(fn_code) 1%positive) + (Pos.max (fold_left Pos.max f.(fn_params) 1%positive) + (max_reg_resources f.(fn_funct_units))). + +Definition max_pc_function (f: function) : positive := + PTree.fold (fun m pc i => (Pos.max m + (pc + match Zlength i.(bb_body) + with Z.pos p => p | _ => 1 end))%positive) + f.(fn_code) 1%positive. diff --git a/src/hls/RTLParFUgen.v b/src/hls/RTLParFUgen.v new file mode 100644 index 0000000..55fe4e7 --- /dev/null +++ b/src/hls/RTLParFUgen.v @@ -0,0 +1,178 @@ +(* + * Vericert: Verified high-level synthesis. + * Copyright (C) 2021 Yann Herklotz <yann@yannherklotz.com> + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see <https://www.gnu.org/licenses/>. + *) + +Require Import Coq.micromega.Lia. + +Require Import compcert.common.AST. +Require Import compcert.common.Errors. +Require compcert.common.Globalenvs. +Require Import compcert.lib.Integers. +Require Import compcert.lib.Maps. + +Require Import vericert.common.Statemonad. +Require Import vericert.common.Vericertlib. +Require Import vericert.hls.AssocMap. +Require Import vericert.hls.Predicate. +Require Import vericert.hls.ValueInt. +Require Import vericert.hls.Verilog. +Require Import vericert.hls.RTLBlockInstr. +Require Import vericert.hls.RTLPar. +Require Import vericert.hls.RTLParFU. +Require Import vericert.hls.FunctionalUnits. + +#[local] Open Scope error_monad_scope. + +Definition update {A: Type} (i: positive) (f: option A -> A) (pt: PTree.t A) := + PTree.set i (f (pt ! i)) pt. + +Definition add_instr (instr_: instr) x := + match x with Some i => instr_ :: i | None => instr_ :: nil end. + +Definition transl_instr (res: resources) (cycle: positive) (i: RTLBlockInstr.instr) + (li: Errors.res (list instr * PTree.t (list instr))): + Errors.res (list instr * PTree.t (list instr)) := + do (instr_list, d_tree) <- li; + match i with + | RBnop => Errors.OK (FUnop :: instr_list, d_tree) + | RBop po op args d => Errors.OK (FUop po op args d :: instr_list, d_tree) + | RBload po chunk addr args d => + match get_ram 0 res with + | Some (ri, r) => + Errors.OK (FUop po Op.Onot (ram_u_en r::nil) (ram_u_en r) + :: FUop po (Op.Ointconst (Int.repr 0)) nil (ram_wr_en r) + :: FUop po (Op.Olea addr) args (ram_addr r) + :: FUop po (Op.Oshruimm (Int.repr 2)) ((ram_addr r)::nil) (ram_addr r) + :: instr_list, update (cycle+1) + (add_instr (FUop po Op.Omove (ram_d_out r::nil) d)) + d_tree) + | _ => Errors.Error (Errors.msg "Could not find RAM") + end + | RBstore po chunk addr args d => + match get_ram 0 res with + | Some (ri, r) => + Errors.OK (FUop po Op.Onot (ram_u_en r::nil) (ram_u_en r) + :: FUop po (Op.Ointconst (Int.repr 1)) nil (ram_wr_en r) + :: FUop po Op.Omove (d::nil) (ram_d_in r) + :: FUop po (Op.Olea addr) args (ram_addr r) + :: FUop po (Op.Oshruimm (Int.repr 2)) ((ram_addr r)::nil) (ram_addr r) + :: instr_list, d_tree) + | _ => Errors.Error (Errors.msg "Could not find RAM") + end + | RBsetpred op c args p => Errors.OK (FUsetpred op c args p :: instr_list, d_tree) + end. + +Fixpoint transl_cf_instr (i: RTLBlockInstr.cf_instr): RTLParFU.cf_instr := + match i with + | RBcall sig r args d n => FUcall sig r args d n + | RBtailcall sig r args => FUtailcall sig r args + | RBbuiltin ef args r n => FUbuiltin ef args r n + | RBcond c args n1 n2 => FUcond c args n1 n2 + | RBjumptable r ns => FUjumptable r ns + | RBreturn r => FUreturn r + | RBgoto n => FUgoto n + | RBpred_cf po c1 c2 => FUpred_cf po (transl_cf_instr c1) (transl_cf_instr c2) + end. + +Definition list_split {A:Type} (l: list (Z * A)) : (list (Z * A)) * (list (Z * A)) := + (filter (fun x => Z.eqb 0 (fst x)) l, + map (fun x => (Z.pred (fst x), snd x)) (filter (fun x => negb (Z.eqb 0 (fst x))) l)). + +Fixpoint map_error {A B : Type} (f : A -> res B) (l : list A) {struct l} : res (list B) := + match l with + | nil => OK nil + | x::xs => + do y <- f x ; + do ys <- map_error f xs ; + OK (y::ys) + end. + +Definition transl_op_chain_block (res: resources) (cycle: positive) (instrs: list RTLBlockInstr.instr) + (state: Errors.res (list (list instr) * PTree.t (list instr))) + : Errors.res (list (list instr) * PTree.t (list instr)) := + do (li, tr) <- state; + do (li', tr') <- fold_right (transl_instr res cycle) (OK (nil, tr)) instrs; + OK (li' :: li, tr'). + +(*Compute transl_op_chain_block initial_resources 10%nat (RBop None (Op.Ointconst (Int.repr 1)) nil 1%positive::RBnop::RBnop::RBnop::nil) (OK (nil, PTree.empty _)).*) + +Definition transl_par_block (res: resources) (cycle: positive) (instrs: list (list RTLBlockInstr.instr)) + (state: Errors.res (list (list (list instr)) * PTree.t (list instr))) + : Errors.res (list (list (list instr)) * PTree.t (list instr)) := + do (li, tr) <- state; + do (li', tr') <- fold_right (transl_op_chain_block res cycle) (OK (nil, tr)) instrs; + OK (li' :: li, tr'). + +(*Compute transl_par_block initial_resources 10%nat ((RBop None (Op.Ointconst (Int.repr 1)) nil 1%positive::RBnop::nil)::(RBop None (Op.Ointconst (Int.repr 2)) nil 2%positive::RBnop::nil)::nil) (OK (((FUnop::nil)::nil)::nil, PTree.empty _)).*) + +Definition transl_seq_block (res: resources) (b: list (list RTLBlockInstr.instr)) + (a: Errors.res (list (list (list instr)) * PTree.t (list instr) * positive)) := + do (litr, n) <- a; + let (li, tr) := litr in + do (li', tr') <- transl_par_block res n b (OK (li, tr)); + OK (li', tr', (n+1)%positive). + +Definition insert_extra (pt: PTree.t (list instr)) (curr: list (list instr)) + (cycle_bb: (positive * list (list (list instr)))) := + let (cycle, bb) := cycle_bb in + match pt ! cycle with + | Some instrs => ((cycle + 1)%positive, (curr ++ (map (fun x => x :: nil) instrs)) :: bb) + | None => ((cycle + 1)%positive, curr :: bb) + end. + +Definition transl_bb (res: resources) (bb: RTLPar.bb): Errors.res RTLParFU.bblock_body := + do (litr, n) <- fold_right (transl_seq_block res) (OK (nil, PTree.empty _, 1%positive)) bb; + let (li, tr) := litr in + OK (snd (fold_right (insert_extra tr) (1%positive, nil) li)). + +Definition transl_bblock (res: resources) (bb: RTLPar.bblock): Errors.res bblock := + do bb' <- transl_bb res (RTLBlockInstr.bb_body bb); + OK (mk_bblock bb' (transl_cf_instr (RTLBlockInstr.bb_exit bb))). + +Definition error_map_ptree {A B: Type} (f: positive -> A -> res B) (pt: PTree.t A) := + do ptl' <- map_error (fun x => do x' <- uncurry f x; OK (fst x, x')) (PTree.elements pt); + OK (PTree_Properties.of_list ptl'). + +Definition transl_code (fu: resources) (c: RTLPar.code): res code := + error_map_ptree (fun _ => transl_bblock fu) c. + +Definition transl_function (f: RTLPar.function): Errors.res RTLParFU.function := + let max := RTLPar.max_reg_function f in + let fu := set_res (Ram (mk_ram + (Z.to_nat (RTLBlockInstr.fn_stacksize f)) + (max+1)%positive + (max+3)%positive + (max+7)%positive + (max+2)%positive + (max+6)%positive + (max+4)%positive + (max+5)%positive + ltac:(lia) + )) initial_resources in + do c' <- transl_code fu (RTLBlockInstr.fn_code f); + Errors.OK (mkfunction (RTLBlockInstr.fn_sig f) + (RTLBlockInstr.fn_params f) + (RTLBlockInstr.fn_stacksize f) + c' + fu + (RTLBlockInstr.fn_entrypoint f)). + +Definition transl_fundef p := + transf_partial_fundef transl_function p. + +Definition transl_program (p : RTLPar.program) : Errors.res RTLParFU.program := + transform_partial_program transl_fundef p. diff --git a/src/hls/RTLPargen.v b/src/hls/RTLPargen.v index aaabe5d..58b048c 100644 --- a/src/hls/RTLPargen.v +++ b/src/hls/RTLPargen.v @@ -1,6 +1,6 @@ (* * Vericert: Verified high-level synthesis. - * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com> + * Copyright (C) 2020-2021 Yann Herklotz <yann@yannherklotz.com> * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -19,7 +19,7 @@ Require Import compcert.backend.Registers. Require Import compcert.common.AST. Require Import compcert.common.Globalenvs. -Require compcert.common.Memory. +Require Import compcert.common.Memory. Require Import compcert.common.Values. Require Import compcert.lib.Floats. Require Import compcert.lib.Integers. @@ -30,554 +30,165 @@ Require Import vericert.common.Vericertlib. Require Import vericert.hls.RTLBlock. Require Import vericert.hls.RTLPar. Require Import vericert.hls.RTLBlockInstr. +Require Import vericert.hls.Predicate. +Require Import vericert.hls.Abstr. +Import NE.NonEmptyNotation. (*| -Schedule Oracle -=============== - -This oracle determines if a schedule was valid by performing symbolic execution on the input and -output and showing that these behave the same. This acts on each basic block separately, as the -rest of the functions should be equivalent. +================= +RTLPar Generation +================= |*) -Definition reg := positive. - -Inductive resource : Set := -| Reg : reg -> resource -| Mem : resource. +#[local] Open Scope positive. +#[local] Open Scope forest. +#[local] Open Scope pred_op. (*| -The following defines quite a few equality comparisons automatically, however, these can be -optimised heavily if written manually, as their proofs are not needed. +Abstract Computations +===================== + +Define the abstract computation using the ``update`` function, which will set each register to its +symbolic value. First we need to define a few helper functions to correctly translate the +predicates. |*) -Lemma resource_eq : forall (r1 r2 : resource), {r1 = r2} + {r1 <> r2}. -Proof. - decide equality. apply Pos.eq_dec. -Defined. - -Lemma comparison_eq: forall (x y : comparison), {x = y} + {x <> y}. -Proof. - decide equality. -Defined. - -Lemma condition_eq: forall (x y : Op.condition), {x = y} + {x <> y}. -Proof. - generalize comparison_eq; intro. - generalize Int.eq_dec; intro. - generalize Int64.eq_dec; intro. - decide equality. -Defined. - -Lemma addressing_eq : forall (x y : Op.addressing), {x = y} + {x <> y}. -Proof. - generalize Int.eq_dec; intro. - generalize AST.ident_eq; intro. - generalize Z.eq_dec; intro. - generalize Ptrofs.eq_dec; intro. - decide equality. -Defined. - -Lemma typ_eq : forall (x y : AST.typ), {x = y} + {x <> y}. -Proof. - decide equality. -Defined. - -Lemma operation_eq: forall (x y : Op.operation), {x = y} + {x <> y}. -Proof. - generalize Int.eq_dec; intro. - generalize Int64.eq_dec; intro. - generalize Float.eq_dec; intro. - generalize Float32.eq_dec; intro. - generalize AST.ident_eq; intro. - generalize condition_eq; intro. - generalize addressing_eq; intro. - generalize typ_eq; intro. - decide equality. -Defined. - -Lemma memory_chunk_eq : forall (x y : AST.memory_chunk), {x = y} + {x <> y}. -Proof. - decide equality. -Defined. - -Lemma list_typ_eq: forall (x y : list AST.typ), {x = y} + {x <> y}. -Proof. - generalize typ_eq; intro. - decide equality. -Defined. - -Lemma option_typ_eq : forall (x y : option AST.typ), {x = y} + {x <> y}. -Proof. - generalize typ_eq; intro. - decide equality. -Defined. - -Lemma signature_eq: forall (x y : AST.signature), {x = y} + {x <> y}. -Proof. - repeat decide equality. -Defined. - -Lemma list_operation_eq : forall (x y : list Op.operation), {x = y} + {x <> y}. -Proof. - generalize operation_eq; intro. - decide equality. -Defined. - -Lemma list_reg_eq : forall (x y : list reg), {x = y} + {x <> y}. -Proof. - generalize Pos.eq_dec; intros. - decide equality. -Defined. - -Lemma sig_eq : forall (x y : AST.signature), {x = y} + {x <> y}. -Proof. - repeat decide equality. -Defined. - -Lemma instr_eq: forall (x y : instr), {x = y} + {x <> y}. -Proof. - generalize Pos.eq_dec; intro. - generalize typ_eq; intro. - generalize Int.eq_dec; intro. - generalize memory_chunk_eq; intro. - generalize addressing_eq; intro. - generalize operation_eq; intro. - generalize condition_eq; intro. - generalize signature_eq; intro. - generalize list_operation_eq; intro. - generalize list_reg_eq; intro. - generalize AST.ident_eq; intro. - repeat decide equality. -Defined. - -Lemma cf_instr_eq: forall (x y : cf_instr), {x = y} + {x <> y}. -Proof. - generalize Pos.eq_dec; intro. - generalize typ_eq; intro. - generalize Int.eq_dec; intro. - generalize Int64.eq_dec; intro. - generalize Float.eq_dec; intro. - generalize Float32.eq_dec; intro. - generalize Ptrofs.eq_dec; intro. - generalize memory_chunk_eq; intro. - generalize addressing_eq; intro. - generalize operation_eq; intro. - generalize condition_eq; intro. - generalize signature_eq; intro. - generalize list_operation_eq; intro. - generalize list_reg_eq; intro. - generalize AST.ident_eq; intro. - repeat decide equality. -Defined. +Fixpoint list_translation (l : list reg) (f : forest) {struct l} : list pred_expr := + match l with + | nil => nil + | i :: l => (f # (Reg i)) :: (list_translation l f) + end. -(*| -We then create equality lemmas for a resource and a module to index resources uniquely. The -indexing is done by setting Mem to 1, whereas all other infinitely many registers will all be -shifted right by 1. This means that they will never overlap. -|*) +Fixpoint replicate {A} (n: nat) (l: A) := + match n with + | O => nil + | S n => l :: replicate n l + end. -Module R_indexed. - Definition t := resource. - Definition index (rs: resource) : positive := - match rs with - | Reg r => xO r - | Mem => 1%positive - end. +Definition merge''' x y := + match x, y with + | Some p1, Some p2 => Some (Pand p1 p2) + | Some p, None | None, Some p => Some p + | None, None => None + end. - Lemma index_inj: forall (x y: t), index x = index y -> x = y. - Proof. destruct x; destruct y; crush. Qed. +Definition merge'' x := + match x with + | ((a, e), (b, el)) => (merge''' a b, Econs e el) + end. - Definition eq := resource_eq. -End R_indexed. +Definition map_pred_op {A B} (pf: option pred_op * (A -> B)) (pa: option pred_op * A): option pred_op * B := + match pa, pf with + | (p, a), (p', f) => (merge''' p p', f a) + end. -(*| -We can then create expressions that mimic the expressions defined in RTLBlock and RTLPar, which use -expressions instead of registers as their inputs and outputs. This means that we can accumulate all -the results of the operations as general expressions that will be present in those registers. +Definition predicated_prod {A B: Type} (p1: predicated A) (p2: predicated B) := + NE.map (fun x => match x with ((a, b), (c, d)) => (Pand a c, (b, d)) end) + (NE.non_empty_prod p1 p2). -- Ebase: the starting value of the register. -- Eop: Some arithmetic operation on a number of registers. -- Eload: A load from a memory location into a register. -- Estore: A store from a register to a memory location. +Definition predicated_map {A B: Type} (f: A -> B) (p: predicated A): predicated B := + NE.map (fun x => (fst x, f (snd x))) p. -Then, to make recursion over expressions easier, expression_list is also defined in the datatype, as -that enables mutual recursive definitions over the datatypes. -|*) +(*map (fun x => (fst x, Econs (snd x) Enil)) pel*) +Definition merge' (pel: pred_expr) (tpel: predicated expression_list) := + predicated_map (uncurry Econs) (predicated_prod pel tpel). -Inductive expression : Set := -| Ebase : resource -> expression -| Eop : Op.operation -> expression_list -> expression -| Eload : AST.memory_chunk -> Op.addressing -> expression_list -> expression -> expression -| Estore : expression -> AST.memory_chunk -> Op.addressing -> expression_list -> expression -> expression -with expression_list : Set := -| Enil : expression_list -| Econs : expression -> expression_list -> expression_list. +Fixpoint merge (pel: list pred_expr): predicated expression_list := + match pel with + | nil => NE.singleton (T, Enil) + | a :: b => merge' a (merge b) + end. -(*| -Using IMap we can create a map from resources to any other type, as resources can be uniquely -identified as positive numbers. -|*) +Definition map_predicated {A B} (pf: predicated (A -> B)) (pa: predicated A): predicated B := + predicated_map (fun x => (fst x) (snd x)) (predicated_prod pf pa). -Module Rtree := ITree(R_indexed). +Definition predicated_apply1 {A B} (pf: predicated (A -> B)) (pa: A): predicated B := + NE.map (fun x => (fst x, (snd x) pa)) pf. -Definition forest : Type := Rtree.t expression. +Definition predicated_apply2 {A B C} (pf: predicated (A -> B -> C)) (pa: A) (pb: B): predicated C := + NE.map (fun x => (fst x, (snd x) pa pb)) pf. -Definition regset := Registers.Regmap.t val. +Definition predicated_apply3 {A B C D} (pf: predicated (A -> B -> C -> D)) (pa: A) (pb: B) (pc: C): predicated D := + NE.map (fun x => (fst x, (snd x) pa pb pc)) pf. -Definition get_forest v f := - match Rtree.get v f with - | None => Ebase v - | Some v' => v' +Definition predicated_from_opt {A: Type} (p: option pred_op) (a: A) := + match p with + | Some p' => NE.singleton (p', a) + | None => NE.singleton (T, a) end. -Notation "a # b" := (get_forest b a) (at level 1). -Notation "a # b <- c" := (Rtree.set b c a) (at level 1, b at next level). +#[local] Open Scope non_empty_scope. +#[local] Open Scope pred_op. -Record sem_state := mk_sem_state { - sem_state_regset : regset; - sem_state_memory : Memory.mem - }. +Fixpoint NEfold_left {A B} (f: A -> B -> A) (l: NE.non_empty B) (a: A) : A := + match l with + | NE.singleton a' => f a a' + | a' ::| b => NEfold_left f b (f a a') + end. -(*| -Finally we want to define the semantics of execution for the expressions with symbolic values, so -the result of executing the expressions will be an expressions. -|*) +Fixpoint NEapp {A} (l m: NE.non_empty A) := + match l with + | NE.singleton a => a ::| m + | a ::| b => a ::| NEapp b m + end. -Section SEMANTICS. - -Context (A : Set) (genv : Genv.t A unit). - -Inductive sem_value : - val -> sem_state -> expression -> val -> Prop := - | Sbase_reg: - forall sp st r, - sem_value sp st (Ebase (Reg r)) (Registers.Regmap.get r (sem_state_regset st)) - | Sop: - forall st op args v lv sp, - sem_val_list sp st args lv -> - Op.eval_operation genv sp op lv (sem_state_memory st) = Some v -> - sem_value sp st (Eop op args) v - | Sload : - forall st mem_exp addr chunk args a v m' lv sp, - sem_mem sp st mem_exp m' -> - sem_val_list sp st args lv -> - Op.eval_addressing genv sp addr lv = Some a -> - Memory.Mem.loadv chunk m' a = Some v -> - sem_value sp st (Eload chunk addr args mem_exp) v -with sem_mem : - val -> sem_state -> expression -> Memory.mem -> Prop := - | Sstore : - forall st mem_exp val_exp m'' addr v a m' chunk args lv sp, - sem_mem sp st mem_exp m' -> - sem_value sp st val_exp v -> - sem_val_list sp st args lv -> - Op.eval_addressing genv sp addr lv = Some a -> - Memory.Mem.storev chunk m' a v = Some m'' -> - sem_mem sp st (Estore mem_exp chunk addr args val_exp) m'' - | Sbase_mem : - forall st m sp, - sem_mem sp st (Ebase Mem) m -with sem_val_list : - val -> sem_state -> expression_list -> list val -> Prop := - | Snil : - forall st sp, - sem_val_list sp st Enil nil - | Scons : - forall st e v l lv sp, - sem_value sp st e v -> - sem_val_list sp st l lv -> - sem_val_list sp st (Econs e l) (v :: lv). - -Inductive sem_regset : - val -> sem_state -> forest -> regset -> Prop := - | Sregset: - forall st f rs' sp, - (forall x, sem_value sp st (f # (Reg x)) (Registers.Regmap.get x rs')) -> - sem_regset sp st f rs'. - -Inductive sem : - val -> sem_state -> forest -> sem_state -> Prop := - | Sem: - forall st rs' m' f sp, - sem_regset sp st f rs' -> - sem_mem sp st (f # Mem) m' -> - sem sp st f (mk_sem_state rs' m'). - -End SEMANTICS. - -Fixpoint beq_expression (e1 e2: expression) {struct e1}: bool := - match e1, e2 with - | Ebase r1, Ebase r2 => if resource_eq r1 r2 then true else false - | Eop op1 el1, Eop op2 el2 => - if operation_eq op1 op2 then beq_expression_list el1 el2 else false - | Eload chk1 addr1 el1 e1, Eload chk2 addr2 el2 e2 => - if memory_chunk_eq chk1 chk2 - then if addressing_eq addr1 addr2 - then if beq_expression_list el1 el2 - then beq_expression e1 e2 else false else false else false - | Estore m1 chk1 addr1 el1 e1, Estore m2 chk2 addr2 el2 e2=> - if memory_chunk_eq chk1 chk2 - then if addressing_eq addr1 addr2 - then if beq_expression_list el1 el2 - then if beq_expression m1 m2 - then beq_expression e1 e2 else false else false else false else false - | _, _ => false - end -with beq_expression_list (el1 el2: expression_list) {struct el1} : bool := - match el1, el2 with - | Enil, Enil => true - | Econs e1 t1, Econs e2 t2 => beq_expression e1 e2 && beq_expression_list t1 t2 - | _, _ => false +Definition app_predicated' {A: Type} (a b: predicated A) := + let negation := ¬ (NEfold_left (fun a b => a ∨ (fst b)) b ⟂) in + NEapp (NE.map (fun x => (negation ∧ fst x, snd x)) a) b. + +Definition app_predicated {A: Type} (p: option pred_op) (a b: predicated A) := + match p with + | Some p' => NEapp (NE.map (fun x => (¬ p' ∧ fst x, snd x)) a) + (NE.map (fun x => (p' ∧ fst x, snd x)) b) + | None => b end. -Scheme expression_ind2 := Induction for expression Sort Prop - with expression_list_ind2 := Induction for expression_list Sort Prop. - -Lemma beq_expression_correct: - forall e1 e2, beq_expression e1 e2 = true -> e1 = e2. -Proof. - intro e1; - apply expression_ind2 with - (P := fun (e1 : expression) => - forall e2, beq_expression e1 e2 = true -> e1 = e2) - (P0 := fun (e1 : expression_list) => - forall e2, beq_expression_list e1 e2 = true -> e1 = e2); simplify; - repeat match goal with - | [ H : context[match ?x with _ => _ end] |- _ ] => destruct x eqn:? - | [ H : context[if ?x then _ else _] |- _ ] => destruct x eqn:? - end; subst; f_equal; crush. -Qed. - -Definition empty : forest := Rtree.empty _. +Definition pred_ret {A: Type} (a: A) : predicated A := + NE.singleton (T, a). (*| -This function checks if all the elements in [fa] are in [fb], but not the other way round. -|*) +Update Function +--------------- -Definition check := Rtree.beq beq_expression. +The ``update`` function will generate a new forest given an existing forest and a new instruction, +so that it can evaluate a symbolic expression by folding over a list of instructions. The main +problem is that predicates need to be merged as well, so that: -Lemma check_correct: forall (fa fb : forest) (x : resource), - check fa fb = true -> (forall x, fa # x = fb # x). -Proof. - unfold check, get_forest; intros; - pose proof beq_expression_correct; - match goal with - [ Hbeq : context[Rtree.beq], y : Rtree.elt |- _ ] => - apply (Rtree.beq_sound beq_expression fa fb) with (x := y) in Hbeq - end; - repeat destruct_match; crush. -Qed. - -Lemma get_empty: - forall r, empty#r = Ebase r. -Proof. - intros; unfold get_forest; - destruct_match; auto; [ ]; - match goal with - [ H : context[Rtree.get _ empty] |- _ ] => rewrite Rtree.gempty in H - end; discriminate. -Qed. - -Fixpoint beq2 {A B : Type} (beqA : A -> B -> bool) (m1 : PTree.t A) (m2 : PTree.t B) {struct m1} : bool := - match m1, m2 with - | PTree.Leaf, _ => PTree.bempty m2 - | _, PTree.Leaf => PTree.bempty m1 - | PTree.Node l1 o1 r1, PTree.Node l2 o2 r2 => - match o1, o2 with - | None, None => true - | Some y1, Some y2 => beqA y1 y2 - | _, _ => false - end - && beq2 beqA l1 l2 && beq2 beqA r1 r2 - end. +1. The predicates are *independent*. +2. The expression assigned to the register should still be correct. -Lemma beq2_correct: - forall A B beqA m1 m2, - @beq2 A B beqA m1 m2 = true <-> - (forall (x: PTree.elt), - match PTree.get x m1, PTree.get x m2 with - | None, None => True - | Some y1, Some y2 => beqA y1 y2 = true - | _, _ => False - end). -Proof. - induction m1; intros. - - simpl. rewrite PTree.bempty_correct. split; intros. - rewrite PTree.gleaf. rewrite H. auto. - generalize (H x). rewrite PTree.gleaf. destruct (PTree.get x m2); tauto. - - destruct m2. - + unfold beq2. rewrite PTree.bempty_correct. split; intros. - rewrite H. rewrite PTree.gleaf. auto. - generalize (H x). rewrite PTree.gleaf. - destruct (PTree.get x (PTree.Node m1_1 o m1_2)); tauto. - + simpl. split; intros. - * destruct (andb_prop _ _ H). destruct (andb_prop _ _ H0). - rewrite IHm1_1 in H3. rewrite IHm1_2 in H1. - destruct x; simpl. apply H1. apply H3. - destruct o; destruct o0; auto || congruence. - * apply andb_true_intro. split. apply andb_true_intro. split. - generalize (H xH); simpl. destruct o; destruct o0; tauto. - apply IHm1_1. intros; apply (H (xO x)). - apply IHm1_2. intros; apply (H (xI x)). -Qed. - -Lemma map0: - forall r, - empty # r = Ebase r. -Proof. intros; eapply get_empty. Qed. - -Lemma map1: - forall w dst dst', - dst <> dst' -> - (empty # dst <- w) # dst' = Ebase dst'. -Proof. intros; unfold get_forest; rewrite Rtree.gso; auto; apply map0. Qed. - -Lemma genmap1: - forall (f : forest) w dst dst', - dst <> dst' -> - (f # dst <- w) # dst' = f # dst'. -Proof. intros; unfold get_forest; rewrite Rtree.gso; auto. Qed. - -Lemma map2: - forall (v : expression) x rs, - (rs # x <- v) # x = v. -Proof. intros; unfold get_forest; rewrite Rtree.gss; trivial. Qed. - -Lemma tri1: - forall x y, - Reg x <> Reg y -> x <> y. -Proof. crush. Qed. - -Definition ge_preserved {A B C D: Type} (ge: Genv.t A B) (tge: Genv.t C D) : Prop := - (forall sp op vl, Op.eval_operation ge sp op vl = - Op.eval_operation tge sp op vl) - /\ (forall sp addr vl, Op.eval_addressing ge sp addr vl = - Op.eval_addressing tge sp addr vl). - -Lemma ge_preserved_same: - forall A B ge, @ge_preserved A B A B ge ge. -Proof. unfold ge_preserved; auto. Qed. -Hint Resolve ge_preserved_same : rtlpar. - -Inductive sem_state_ld : sem_state -> sem_state -> Prop := -| sem_state_ld_intro: - forall rs rs' m m', - regs_lessdef rs rs' -> - m = m' -> - sem_state_ld (mk_sem_state rs m) (mk_sem_state rs' m'). - -Lemma sems_det: - forall A ge tge sp st f, - ge_preserved ge tge -> - forall v v' mv mv', - (sem_value A ge sp st f v /\ sem_value A tge sp st f v' -> v = v') /\ - (sem_mem A ge sp st f mv /\ sem_mem A tge sp st f mv' -> mv = mv'). -Proof. Admitted. - -Lemma sem_value_det: - forall A ge tge sp st f v v', - ge_preserved ge tge -> - sem_value A ge sp st f v -> - sem_value A tge sp st f v' -> - v = v'. -Proof. - intros; - generalize (sems_det A ge tge sp st f H v v' - st.(sem_state_memory) st.(sem_state_memory)); - crush. -Qed. -Hint Resolve sem_value_det : rtlpar. - -Lemma sem_value_det': - forall FF ge sp s f v v', - sem_value FF ge sp s f v -> - sem_value FF ge sp s f v' -> - v = v'. -Proof. - simplify; eauto with rtlpar. -Qed. - -Lemma sem_mem_det: - forall A ge tge sp st f m m', - ge_preserved ge tge -> - sem_mem A ge sp st f m -> - sem_mem A tge sp st f m' -> - m = m'. -Proof. - intros; - generalize (sems_det A ge tge sp st f H sp sp m m'); - crush. -Qed. -Hint Resolve sem_mem_det : rtlpar. - -Lemma sem_mem_det': - forall FF ge sp s f m m', - sem_mem FF ge sp s f m -> - sem_mem FF ge sp s f m' -> - m = m'. -Proof. - simplify; eauto with rtlpar. -Qed. - -Hint Resolve Val.lessdef_same : rtlpar. - -Lemma sem_regset_det: - forall FF ge tge sp st f v v', - ge_preserved ge tge -> - sem_regset FF ge sp st f v -> - sem_regset FF tge sp st f v' -> - regs_lessdef v v'. -Proof. - intros; unfold regs_lessdef. - inv H0; inv H1; - eauto with rtlpar. -Qed. -Hint Resolve sem_regset_det : rtlpar. - -Lemma sem_det: - forall FF ge tge sp st f st' st'', - ge_preserved ge tge -> - sem FF ge sp st f st' -> - sem FF tge sp st f st'' -> - sem_state_ld st' st''. -Proof. - intros. - destruct st; destruct st'; destruct st''. - inv H0; inv H1. - constructor; eauto with rtlpar. -Qed. -Hint Resolve sem_det : rtlpar. - -Lemma sem_det': - forall FF ge sp st f st' st'', - sem FF ge sp st f st' -> - sem FF ge sp st f st'' -> - sem_state_ld st' st''. -Proof. eauto with rtlpar. Qed. - -(*| -Update functions. +This is done by multiplying the predicates together, and assigning the negation of the expression to +the other predicates. |*) -Fixpoint list_translation (l : list reg) (f : forest) {struct l} : expression_list := - match l with - | nil => Enil - | i :: l => Econs (f # (Reg i)) (list_translation l f) - end. - Definition update (f : forest) (i : instr) : forest := match i with | RBnop => f | RBop p op rl r => - f # (Reg r) <- (Eop op (list_translation rl f)) + f # (Reg r) <- + (app_predicated p + (f # (Reg r)) + (map_predicated (pred_ret (Eop op)) (merge (list_translation rl f)))) | RBload p chunk addr rl r => - f # (Reg r) <- (Eload chunk addr (list_translation rl f) (f # Mem)) + f # (Reg r) <- + (app_predicated p + (f # (Reg r)) + (map_predicated + (map_predicated (pred_ret (Eload chunk addr)) (merge (list_translation rl f))) + (f # Mem))) | RBstore p chunk addr rl r => - f # Mem <- (Estore (f # Mem) chunk addr (list_translation rl f) (f # (Reg r))) - | RBsetpred c addr p => f - | RBpiped p fu args => f - | RBassign p fu src dst => f + f # Mem <- + (app_predicated p + (f # Mem) + (map_predicated + (map_predicated + (predicated_apply2 (map_predicated (pred_ret Estore) (f # (Reg r))) chunk addr) + (merge (list_translation rl f))) (f # Mem))) + | RBsetpred p' c args p => + f # (Pred p) <- + (app_predicated p' + (f # (Pred p)) + (map_predicated (pred_ret (Esetpred c)) (merge (list_translation args f)))) end. (*| @@ -590,7 +201,7 @@ Get a sequence from the basic block. Fixpoint abstract_sequence (f : forest) (b : list instr) : forest := match b with | nil => f - | i :: l => update (abstract_sequence f l) i + | i :: l => abstract_sequence (update f i) l end. (*| @@ -632,37 +243,21 @@ Ltac solve_scheduled_trees_correct := end; repeat destruct_match; crush. Lemma check_scheduled_trees_correct: - forall f1 f2, + forall f1 f2 x y1, check_scheduled_trees f1 f2 = true -> - (forall x y1, - PTree.get x f1 = Some y1 -> - exists y2, PTree.get x f2 = Some y2 /\ schedule_oracle y1 y2 = true). + PTree.get x f1 = Some y1 -> + exists y2, PTree.get x f2 = Some y2 /\ schedule_oracle y1 y2 = true. Proof. solve_scheduled_trees_correct; eexists; crush. Qed. Lemma check_scheduled_trees_correct2: - forall f1 f2, + forall f1 f2 x, check_scheduled_trees f1 f2 = true -> - (forall x, - PTree.get x f1 = None -> - PTree.get x f2 = None). + PTree.get x f1 = None -> + PTree.get x f2 = None. Proof. solve_scheduled_trees_correct. Qed. (*| -Abstract computations -===================== -|*) - -Lemma abstract_execution_correct: - forall bb bb' cfi ge tge sp rs m rs' m', - ge_preserved ge tge -> - schedule_oracle (mk_bblock bb cfi) (mk_bblock bb' cfi) = true -> - RTLBlock.step_instr_list ge sp (InstrState rs m) bb (InstrState rs' m') -> - exists rs'', RTLPar.step_instr_block tge sp (InstrState rs m) bb' (InstrState rs'' m') - /\ regs_lessdef rs' rs''. -Proof. Admitted. - -(*| -Top-level functions +Top-level Functions =================== |*) @@ -675,21 +270,11 @@ Definition transl_function (f: RTLBlock.function) : Errors.res RTLPar.function : f.(fn_params) f.(fn_stacksize) tfcode - f.(fn_funct_units) f.(fn_entrypoint)) else Errors.Error (Errors.msg "RTLPargen: Could not prove the blocks equivalent."). -Definition transl_function_temp (f: RTLBlock.function) : Errors.res RTLPar.function := - let tfcode := fn_code (schedule f) in - Errors.OK (mkfunction f.(fn_sig) - f.(fn_params) - f.(fn_stacksize) - tfcode - f.(fn_funct_units) - f.(fn_entrypoint)). - -Definition transl_fundef := transf_partial_fundef transl_function_temp. +Definition transl_fundef := transf_partial_fundef transl_function. Definition transl_program (p : RTLBlock.program) : Errors.res RTLPar.program := transform_partial_program transl_fundef p. diff --git a/src/hls/RTLPargenproof.v b/src/hls/RTLPargenproof.v index eb7931e..588f67f 100644 --- a/src/hls/RTLPargenproof.v +++ b/src/hls/RTLPargenproof.v @@ -30,42 +30,797 @@ Require Import vericert.hls.RTLBlock. Require Import vericert.hls.RTLPar. Require Import vericert.hls.RTLBlockInstr. Require Import vericert.hls.RTLPargen. +Require Import vericert.hls.Predicate. +Require Import vericert.hls.Abstr. + +#[local] Open Scope positive. +#[local] Open Scope forest. +#[local] Open Scope pred_op. + +(*Definition is_regs i := match i with mk_instr_state rs _ => rs end. +Definition is_mem i := match i with mk_instr_state _ m => m end. + +Inductive state_lessdef : instr_state -> instr_state -> Prop := + state_lessdef_intro : + forall rs1 rs2 m1, + (forall x, rs1 !! x = rs2 !! x) -> + state_lessdef (mk_instr_state rs1 m1) (mk_instr_state rs2 m1). + +(*| +RTLBlock to abstract translation +-------------------------------- + +Correctness of translation from RTLBlock to the abstract interpretation language. +|*) + +Ltac inv_simp := + repeat match goal with + | H: exists _, _ |- _ => inv H + end; simplify. + +*) + +Definition check_dest i r' := + match i with + | RBop p op rl r => (r =? r')%positive + | RBload p chunk addr rl r => (r =? r')%positive + | _ => false + end. + +Lemma check_dest_dec i r : {check_dest i r = true} + {check_dest i r = false}. +Proof. destruct (check_dest i r); tauto. Qed. + +Fixpoint check_dest_l l r := + match l with + | nil => false + | a :: b => check_dest a r || check_dest_l b r + end. + +Lemma check_dest_l_forall : + forall l r, + check_dest_l l r = false -> + Forall (fun x => check_dest x r = false) l. +Proof. induction l; crush. Qed. + +Lemma check_dest_l_dec i r : {check_dest_l i r = true} + {check_dest_l i r = false}. +Proof. destruct (check_dest_l i r); tauto. Qed. + +Lemma check_dest_update : + forall f i r, + check_dest i r = false -> + (update f i) # (Reg r) = f # (Reg r). +Proof. + destruct i; crush; try apply Pos.eqb_neq in H; apply genmap1; crush. +Qed. + +Lemma check_dest_l_forall2 : + forall l r, + Forall (fun x => check_dest x r = false) l -> + check_dest_l l r = false. +Proof. + induction l; crush. + inv H. apply orb_false_intro; crush. +Qed. + +Lemma check_dest_l_ex2 : + forall l r, + (exists a, In a l /\ check_dest a r = true) -> + check_dest_l l r = true. +Proof. + induction l; crush. + specialize (IHl r). inv H. + apply orb_true_intro; crush. + apply orb_true_intro; crush. + right. apply IHl. exists x. auto. +Qed. + +Lemma check_list_l_false : + forall l x r, + check_dest_l (l ++ x :: nil) r = false -> + check_dest_l l r = false /\ check_dest x r = false. +Proof. + simplify. + apply check_dest_l_forall in H. apply Forall_app in H. + simplify. apply check_dest_l_forall2; auto. + apply check_dest_l_forall in H. apply Forall_app in H. + simplify. inv H1. auto. +Qed. + +Lemma check_dest_l_ex : + forall l r, + check_dest_l l r = true -> + exists a, In a l /\ check_dest a r = true. +Proof. + induction l; crush. + destruct (check_dest a r) eqn:?; try solve [econstructor; crush]. + simplify. + exploit IHl. apply H. simplify. econstructor. simplify. right. eassumption. + auto. +Qed. + +Lemma check_list_l_true : + forall l x r, + check_dest_l (l ++ x :: nil) r = true -> + check_dest_l l r = true \/ check_dest x r = true. +Proof. + simplify. + apply check_dest_l_ex in H; simplify. + apply in_app_or in H. inv H. left. + apply check_dest_l_ex2. exists x0. auto. + inv H0; auto. +Qed. + +Lemma check_dest_l_dec2 l r : + {Forall (fun x => check_dest x r = false) l} + + {exists a, In a l /\ check_dest a r = true}. +Proof. + destruct (check_dest_l_dec l r); [right | left]; + auto using check_dest_l_ex, check_dest_l_forall. +Qed. + +Lemma abstr_comp : + forall l i f x x0, + abstract_sequence f (l ++ i :: nil) = x -> + abstract_sequence f l = x0 -> + x = update x0 i. +Proof. induction l; intros; crush; eapply IHl; eauto. Qed. + +(* + +Lemma gen_list_base: + forall FF ge sp l rs exps st1, + (forall x, @sem_value FF ge sp st1 (exps # (Reg x)) (rs !! x)) -> + sem_val_list ge sp st1 (list_translation l exps) rs ## l. +Proof. + induction l. + intros. simpl. constructor. + intros. simpl. eapply Scons; eauto. +Qed. + +Lemma check_dest_update2 : + forall f r rl op p, + (update f (RBop p op rl r)) # (Reg r) = Eop op (list_translation rl f) (f # Mem). +Proof. crush; rewrite map2; auto. Qed. + +Lemma check_dest_update3 : + forall f r rl p addr chunk, + (update f (RBload p chunk addr rl r)) # (Reg r) = Eload chunk addr (list_translation rl f) (f # Mem). +Proof. crush; rewrite map2; auto. Qed. + +Lemma abstract_seq_correct_aux: + forall FF ge sp i st1 st2 st3 f, + @step_instr FF ge sp st3 i st2 -> + sem ge sp st1 f st3 -> + sem ge sp st1 (update f i) st2. +Proof. + intros; inv H; simplify. + { simplify; eauto. } (*apply match_states_refl. }*) + { inv H0. inv H6. destruct st1. econstructor. simplify. + constructor. intros. + destruct (resource_eq (Reg res) (Reg x)). inv e. + rewrite map2. econstructor. eassumption. apply gen_list_base; eauto. + rewrite Regmap.gss. eauto. + assert (res <> x). { unfold not in *. intros. apply n. rewrite H0. auto. } + rewrite Regmap.gso by auto. + rewrite genmap1 by auto. auto. + + rewrite genmap1; crush. } + { inv H0. inv H7. constructor. constructor. intros. + destruct (Pos.eq_dec dst x); subst. + rewrite map2. econstructor; eauto. + apply gen_list_base. auto. rewrite Regmap.gss. auto. + rewrite genmap1. rewrite Regmap.gso by auto. auto. + unfold not in *; intros. inv H0. auto. + rewrite genmap1; crush. + } + { inv H0. inv H7. constructor. constructor; intros. + rewrite genmap1; crush. + rewrite map2. econstructor; eauto. + apply gen_list_base; auto. + } +Qed. + +Lemma regmap_list_equiv : + forall A (rs1: Regmap.t A) rs2, + (forall x, rs1 !! x = rs2 !! x) -> + forall rl, rs1##rl = rs2##rl. +Proof. induction rl; crush. Qed. + +Lemma sem_update_Op : + forall A ge sp st f st' r l o0 o m rs v, + @sem A ge sp st f st' -> + Op.eval_operation ge sp o0 rs ## l m = Some v -> + match_states st' (mk_instr_state rs m) -> + exists tst, + sem ge sp st (update f (RBop o o0 l r)) tst /\ match_states (mk_instr_state (Regmap.set r v rs) m) tst. +Proof. + intros. inv H1. simplify. + destruct st. + econstructor. simplify. + { constructor. + { constructor. intros. destruct (Pos.eq_dec x r); subst. + { pose proof (H5 r). rewrite map2. pose proof H. inv H. econstructor; eauto. + { inv H9. eapply gen_list_base; eauto. } + { instantiate (1 := (Regmap.set r v rs0)). rewrite Regmap.gss. erewrite regmap_list_equiv; eauto. } } + { rewrite Regmap.gso by auto. rewrite genmap1; crush. inv H. inv H7; eauto. } } + { inv H. rewrite genmap1; crush. eauto. } } + { constructor; eauto. intros. + destruct (Pos.eq_dec r x); + subst; [repeat rewrite Regmap.gss | repeat rewrite Regmap.gso]; auto. } +Qed. + +Lemma sem_update_load : + forall A ge sp st f st' r o m a l m0 rs v a0, + @sem A ge sp st f st' -> + Op.eval_addressing ge sp a rs ## l = Some a0 -> + Mem.loadv m m0 a0 = Some v -> + match_states st' (mk_instr_state rs m0) -> + exists tst : instr_state, + sem ge sp st (update f (RBload o m a l r)) tst + /\ match_states (mk_instr_state (Regmap.set r v rs) m0) tst. +Proof. + intros. inv H2. pose proof H. inv H. inv H9. + destruct st. + econstructor; simplify. + { constructor. + { constructor. intros. + destruct (Pos.eq_dec x r); subst. + { rewrite map2. econstructor; eauto. eapply gen_list_base. intros. + rewrite <- H6. eauto. + instantiate (1 := (Regmap.set r v rs0)). rewrite Regmap.gss. auto. } + { rewrite Regmap.gso by auto. rewrite genmap1; crush. } } + { rewrite genmap1; crush. eauto. } } + { constructor; auto; intros. destruct (Pos.eq_dec r x); + subst; [repeat rewrite Regmap.gss | repeat rewrite Regmap.gso]; auto. } +Qed. + +Lemma sem_update_store : + forall A ge sp a0 m a l r o f st m' rs m0 st', + @sem A ge sp st f st' -> + Op.eval_addressing ge sp a rs ## l = Some a0 -> + Mem.storev m m0 a0 rs !! r = Some m' -> + match_states st' (mk_instr_state rs m0) -> + exists tst, sem ge sp st (update f (RBstore o m a l r)) tst + /\ match_states (mk_instr_state rs m') tst. +Proof. + intros. inv H2. pose proof H. inv H. inv H9. + destruct st. + econstructor; simplify. + { econstructor. + { econstructor; intros. rewrite genmap1; crush. } + { rewrite map2. econstructor; eauto. eapply gen_list_base. intros. rewrite <- H6. + eauto. specialize (H6 r). rewrite H6. eauto. } } + { econstructor; eauto. } +Qed. + +Lemma sem_update : + forall A ge sp st x st' st'' st''' f, + sem ge sp st f st' -> + match_states st' st''' -> + @step_instr A ge sp st''' x st'' -> + exists tst, sem ge sp st (update f x) tst /\ match_states st'' tst. +Proof. + intros. destruct x; inv H1. + { econstructor. split. + apply sem_update_RBnop. eassumption. + apply match_states_commut. auto. } + { eapply sem_update_Op; eauto. } + { eapply sem_update_load; eauto. } + { eapply sem_update_store; eauto. } +Qed. + +Lemma sem_update2_Op : + forall A ge sp st f r l o0 o m rs v, + @sem A ge sp st f (mk_instr_state rs m) -> + Op.eval_operation ge sp o0 rs ## l m = Some v -> + sem ge sp st (update f (RBop o o0 l r)) (mk_instr_state (Regmap.set r v rs) m). +Proof. + intros. destruct st. constructor. + inv H. inv H6. + { constructor; intros. simplify. + destruct (Pos.eq_dec r x); subst. + { rewrite map2. econstructor. eauto. + apply gen_list_base. eauto. + rewrite Regmap.gss. auto. } + { rewrite genmap1; crush. rewrite Regmap.gso; auto. } } + { simplify. rewrite genmap1; crush. inv H. eauto. } +Qed. + +Lemma sem_update2_load : + forall A ge sp st f r o m a l m0 rs v a0, + @sem A ge sp st f (mk_instr_state rs m0) -> + Op.eval_addressing ge sp a rs ## l = Some a0 -> + Mem.loadv m m0 a0 = Some v -> + sem ge sp st (update f (RBload o m a l r)) (mk_instr_state (Regmap.set r v rs) m0). +Proof. + intros. simplify. inv H. inv H7. constructor. + { constructor; intros. destruct (Pos.eq_dec r x); subst. + { rewrite map2. rewrite Regmap.gss. econstructor; eauto. + apply gen_list_base; eauto. } + { rewrite genmap1; crush. rewrite Regmap.gso; eauto. } + } + { simplify. rewrite genmap1; crush. } +Qed. + +Lemma sem_update2_store : + forall A ge sp a0 m a l r o f st m' rs m0, + @sem A ge sp st f (mk_instr_state rs m0) -> + Op.eval_addressing ge sp a rs ## l = Some a0 -> + Mem.storev m m0 a0 rs !! r = Some m' -> + sem ge sp st (update f (RBstore o m a l r)) (mk_instr_state rs m'). +Proof. + intros. simplify. inv H. inv H7. constructor; simplify. + { econstructor; intros. rewrite genmap1; crush. } + { rewrite map2. econstructor; eauto. apply gen_list_base; eauto. } +Qed. + +Lemma sem_update2 : + forall A ge sp st x st' st'' f, + sem ge sp st f st' -> + @step_instr A ge sp st' x st'' -> + sem ge sp st (update f x) st''. +Proof. + intros. + destruct x; inv H0; + eauto using sem_update_RBnop, sem_update2_Op, sem_update2_load, sem_update2_store. +Qed. + +Lemma abstr_sem_val_mem : + forall A B ge tge st tst sp a, + ge_preserved ge tge -> + forall v m, + (@sem_mem A ge sp st a m /\ match_states st tst -> @sem_mem B tge sp tst a m) /\ + (@sem_value A ge sp st a v /\ match_states st tst -> @sem_value B tge sp tst a v). +Proof. + intros * H. + apply expression_ind2 with + + (P := fun (e1: expression) => + forall v m, + (@sem_mem A ge sp st e1 m /\ match_states st tst -> @sem_mem B tge sp tst e1 m) /\ + (@sem_value A ge sp st e1 v /\ match_states st tst -> @sem_value B tge sp tst e1 v)) + + (P0 := fun (e1: expression_list) => + forall lv, @sem_val_list A ge sp st e1 lv /\ match_states st tst -> @sem_val_list B tge sp tst e1 lv); + simplify; intros; simplify. + { inv H1. inv H2. constructor. } + { inv H2. inv H1. rewrite H0. constructor. } + { inv H3. } + { inv H3. inv H4. econstructor. apply H1; auto. simplify. eauto. constructor. auto. auto. + apply H0; simplify; eauto. constructor; eauto. + unfold ge_preserved in *. simplify. rewrite <- H2. auto. + } + { inv H3. } + { inv H3. inv H4. econstructor. apply H1; eauto; simplify; eauto. constructor; eauto. + apply H0; simplify; eauto. constructor; eauto. + inv H. rewrite <- H4. eauto. + auto. + } + { inv H4. inv H5. econstructor. apply H0; eauto. simplify; eauto. constructor; eauto. + apply H2; eauto. simplify; eauto. constructor; eauto. + apply H1; eauto. simplify; eauto. constructor; eauto. + inv H. rewrite <- H5. eauto. auto. + } + { inv H4. } + { inv H1. constructor. } + { inv H3. constructor; auto. apply H0; eauto. apply Mem.empty. } +Qed. + +Lemma abstr_sem_value : + forall a A B ge tge sp st tst v, + @sem_value A ge sp st a v -> + ge_preserved ge tge -> + match_states st tst -> + @sem_value B tge sp tst a v. +Proof. intros; eapply abstr_sem_val_mem; eauto; apply Mem.empty. Qed. + +Lemma abstr_sem_mem : + forall a A B ge tge sp st tst v, + @sem_mem A ge sp st a v -> + ge_preserved ge tge -> + match_states st tst -> + @sem_mem B tge sp tst a v. +Proof. intros; eapply abstr_sem_val_mem; eauto. Qed. + +Lemma abstr_sem_regset : + forall a a' A B ge tge sp st tst rs, + @sem_regset A ge sp st a rs -> + ge_preserved ge tge -> + (forall x, a # x = a' # x) -> + match_states st tst -> + exists rs', @sem_regset B tge sp tst a' rs' /\ (forall x, rs !! x = rs' !! x). +Proof. + inversion 1; intros. + inv H7. + econstructor. simplify. econstructor. intros. + eapply abstr_sem_value; eauto. rewrite <- H6. + eapply H0. constructor; eauto. + auto. +Qed. + +Lemma abstr_sem : + forall a a' A B ge tge sp st tst st', + @sem A ge sp st a st' -> + ge_preserved ge tge -> + (forall x, a # x = a' # x) -> + match_states st tst -> + exists tst', @sem B tge sp tst a' tst' /\ match_states st' tst'. +Proof. + inversion 1; subst; intros. + inversion H4; subst. + exploit abstr_sem_regset; eauto; inv_simp. + do 3 econstructor; eauto. + rewrite <- H3. + eapply abstr_sem_mem; eauto. +Qed. + +Lemma abstract_execution_correct': + forall A B ge tge sp st' a a' st tst, + @sem A ge sp st a st' -> + ge_preserved ge tge -> + check a a' = true -> + match_states st tst -> + exists tst', @sem B tge sp tst a' tst' /\ match_states st' tst'. +Proof. + intros; + pose proof (check_correct a a' H1); + eapply abstr_sem; eauto. +Qed. + +Lemma states_match : + forall st1 st2 st3 st4, + match_states st1 st2 -> + match_states st2 st3 -> + match_states st3 st4 -> + match_states st1 st4. +Proof. + intros * H1 H2 H3; destruct st1; destruct st2; destruct st3; destruct st4. + inv H1. inv H2. inv H3; constructor. + unfold regs_lessdef in *. intros. + repeat match goal with + | H: forall _, _, r : positive |- _ => specialize (H r) + end. + congruence. + auto. +Qed. + +Lemma step_instr_block_same : + forall ge sp st st', + step_instr_block ge sp st nil st' -> + st = st'. +Proof. inversion 1; auto. Qed. + +Lemma step_instr_seq_same : + forall ge sp st st', + step_instr_seq ge sp st nil st' -> + st = st'. +Proof. inversion 1; auto. Qed. + +Lemma sem_update' : + forall A ge sp st a x st', + sem ge sp st (update (abstract_sequence empty a) x) st' -> + exists st'', + @step_instr A ge sp st'' x st' /\ + sem ge sp st (abstract_sequence empty a) st''. +Proof. + Admitted. + +Lemma rtlpar_trans_correct : + forall bb ge sp sem_st' sem_st st, + sem ge sp sem_st (abstract_sequence empty (concat (concat bb))) sem_st' -> + match_states sem_st st -> + exists st', RTLPar.step_instr_block ge sp st bb st' + /\ match_states sem_st' st'. +Proof. + induction bb using rev_ind. + { repeat econstructor. eapply abstract_interp_empty3 in H. + inv H. inv H0. constructor; congruence. } + { simplify. inv H0. repeat rewrite concat_app in H. simplify. + rewrite app_nil_r in H. + exploit sem_separate; eauto; inv_simp. + repeat econstructor. admit. admit. + } +Admitted. + +(*Lemma abstract_execution_correct_ld: + forall bb bb' cfi ge tge sp st st' tst, + RTLBlock.step_instr_list ge sp st bb st' -> + ge_preserved ge tge -> + schedule_oracle (mk_bblock bb cfi) (mk_bblock bb' cfi) = true -> + match_states_ld st tst -> + exists tst', RTLPar.step_instr_block tge sp tst bb' tst' + /\ match_states st' tst'. +Proof. + intros.*) +*) + +Lemma match_states_list : + forall A (rs: Regmap.t A) rs', + (forall r, rs !! r = rs' !! r) -> + forall l, rs ## l = rs' ## l. +Proof. induction l; crush. Qed. + +Lemma PTree_matches : + forall A (v: A) res rs rs', + (forall r, rs !! r = rs' !! r) -> + forall x, (Regmap.set res v rs) !! x = (Regmap.set res v rs') !! x. +Proof. + intros; destruct (Pos.eq_dec x res); subst; + [ repeat rewrite Regmap.gss by auto + | repeat rewrite Regmap.gso by auto ]; auto. +Qed. + +Lemma abstract_interp_empty3 : + forall A ctx st', + @sem A ctx empty st' -> match_states (ctx_is ctx) st'. +Proof. + inversion 1; subst; simplify. destruct ctx. + destruct ctx_is. + constructor; intros. + - inv H0. specialize (H3 x). inv H3. inv H8. reflexivity. + - inv H1. specialize (H3 x). inv H3. inv H8. reflexivity. + - inv H2. inv H8. reflexivity. +Qed. + +Lemma step_instr_matches : + forall A a ge sp st st', + @step_instr A ge sp st a st' -> + forall tst, + match_states st tst -> + exists tst', step_instr ge sp tst a tst' + /\ match_states st' tst'. +Proof. + induction 1; simplify; + match goal with H: match_states _ _ |- _ => inv H end; + try solve [repeat econstructor; try erewrite match_states_list; + try apply PTree_matches; eauto; + match goal with + H: forall _, _ |- context[Mem.storev] => erewrite <- H; eauto + end]. + - destruct p. match goal with H: eval_pred _ _ _ _ |- _ => inv H end. + repeat econstructor; try erewrite match_states_list; eauto. + erewrite <- eval_predf_pr_equiv; eassumption. + apply PTree_matches; assumption. + repeat (econstructor; try apply eval_pred_false); eauto. try erewrite match_states_list; eauto. + erewrite <- eval_predf_pr_equiv; eassumption. + econstructor; auto. + match goal with H: eval_pred _ _ _ _ |- _ => inv H end. + repeat econstructor; try erewrite match_states_list; eauto. + - destruct p. match goal with H: eval_pred _ _ _ _ |- _ => inv H end. + repeat econstructor; try erewrite match_states_list; eauto. + erewrite <- eval_predf_pr_equiv; eassumption. + apply PTree_matches; assumption. + repeat (econstructor; try apply eval_pred_false); eauto. try erewrite match_states_list; eauto. + erewrite <- eval_predf_pr_equiv; eassumption. + econstructor; auto. + match goal with H: eval_pred _ _ _ _ |- _ => inv H end. + repeat econstructor; try erewrite match_states_list; eauto. + - destruct p. match goal with H: eval_pred _ _ _ _ |- _ => inv H end. + repeat econstructor; try erewrite match_states_list; eauto. + match goal with + H: forall _, _ |- context[Mem.storev] => erewrite <- H; eauto + end. + erewrite <- eval_predf_pr_equiv; eassumption. + repeat (econstructor; try apply eval_pred_false); eauto. try erewrite match_states_list; eauto. + match goal with + H: forall _, _ |- context[Mem.storev] => erewrite <- H; eauto + end. + erewrite <- eval_predf_pr_equiv; eassumption. + match goal with H: eval_pred _ _ _ _ |- _ => inv H end. + repeat econstructor; try erewrite match_states_list; eauto. + match goal with + H: forall _, _ |- context[Mem.storev] => erewrite <- H; eauto + end. + - admit. Admitted. + +Lemma step_instr_list_matches : + forall a ge sp st st', + step_instr_list ge sp st a st' -> + forall tst, match_states st tst -> + exists tst', step_instr_list ge sp tst a tst' + /\ match_states st' tst'. +Proof. + induction a; intros; inv H; + try (exploit step_instr_matches; eauto; []; simplify; + exploit IHa; eauto; []; simplify); repeat econstructor; eauto. +Qed. + +Lemma step_instr_seq_matches : + forall a ge sp st st', + step_instr_seq ge sp st a st' -> + forall tst, match_states st tst -> + exists tst', step_instr_seq ge sp tst a tst' + /\ match_states st' tst'. +Proof. + induction a; intros; inv H; + try (exploit step_instr_list_matches; eauto; []; simplify; + exploit IHa; eauto; []; simplify); repeat econstructor; eauto. +Qed. + +Lemma step_instr_block_matches : + forall bb ge sp st st', + step_instr_block ge sp st bb st' -> + forall tst, match_states st tst -> + exists tst', step_instr_block ge sp tst bb tst' + /\ match_states st' tst'. +Proof. + induction bb; intros; inv H; + try (exploit step_instr_seq_matches; eauto; []; simplify; + exploit IHbb; eauto; []; simplify); repeat econstructor; eauto. +Qed. + +Lemma rtlblock_trans_correct' : + forall bb ge sp st x st'', + RTLBlock.step_instr_list ge sp st (bb ++ x :: nil) st'' -> + exists st', RTLBlock.step_instr_list ge sp st bb st' + /\ step_instr ge sp st' x st''. +Proof. + induction bb. + crush. exists st. + split. constructor. inv H. inv H6. auto. + crush. inv H. exploit IHbb. eassumption. simplify. + econstructor. split. + econstructor; eauto. eauto. +Qed. + +Lemma abstract_interp_empty A st : @sem A st empty (ctx_is st). +Proof. destruct st, ctx_is. simpl. repeat econstructor. Qed. + +Lemma abstract_seq : + forall l f i, + abstract_sequence f (l ++ i :: nil) = update (abstract_sequence f l) i. +Proof. induction l; crush. Qed. + +Lemma abstract_sequence_update : + forall l r f, + check_dest_l l r = false -> + (abstract_sequence f l) # (Reg r) = f # (Reg r). +Proof. + induction l using rev_ind; crush. + rewrite abstract_seq. rewrite check_dest_update. apply IHl. + apply check_list_l_false in H. tauto. + apply check_list_l_false in H. tauto. +Qed. + +(*Lemma sem_separate : + forall A ctx b a st', + sem ctx (abstract_sequence empty (a ++ b)) st' -> + exists st'', + @sem A ctx (abstract_sequence empty a) st'' + /\ @sem A (mk_ctx st'' (ctx_sp ctx) (ctx_ge ctx)) (abstract_sequence empty b) st'. +Proof. + induction b using rev_ind; simplify. + { econstructor. simplify. rewrite app_nil_r in H. eauto. apply abstract_interp_empty. } + { simplify. rewrite app_assoc in H. rewrite abstract_seq in H. + exploit sem_update'; eauto; simplify. + exploit IHb; eauto; inv_simp. + econstructor; split; eauto. + rewrite abstract_seq. + eapply sem_update2; eauto. + } +Qed.*) + +Lemma sem_update_RBnop : + forall A ctx f st', + @sem A ctx f st' -> sem ctx (update f RBnop) st'. +Proof. auto. Qed. + +Lemma sem_update_Op : + forall A ge sp ist f st' r l o0 o m rs v ps, + @sem A (mk_ctx ist sp ge) f st' -> + eval_predf ps o = true -> + Op.eval_operation ge sp o0 (rs ## l) m = Some v -> + match_states st' (mk_instr_state rs ps m) -> + exists tst, + sem (mk_ctx ist sp ge) (update f (RBop (Some o) o0 l r)) tst + /\ match_states (mk_instr_state (Regmap.set r v rs) ps m) tst. +Proof. + intros. inv H1. inv H. inv H1. inv H3. simplify. + econstructor. simplify. + { constructor; try constructor; intros; try solve [rewrite genmap1; now eauto]. + destruct (Pos.eq_dec x r); subst. + { rewrite map2. specialize (H1 r). inv H1. +(*} + } + destruct st. + econstructor. simplify. + { constructor. + { constructor. intros. destruct (Pos.eq_dec x r); subst. + { pose proof (H5 r). rewrite map2. pose proof H. inv H. econstructor; eauto. + { inv H9. eapply gen_list_base; eauto. } + { instantiate (1 := (Regmap.set r v rs0)). rewrite Regmap.gss. erewrite regmap_list_equiv; eauto. } } + { rewrite Regmap.gso by auto. rewrite genmap1; crush. inv H. inv H7; eauto. } } + { inv H. rewrite genmap1; crush. eauto. } } + { constructor; eauto. intros. + destruct (Pos.eq_dec r x); + subst; [repeat rewrite Regmap.gss | repeat rewrite Regmap.gso]; auto. } +Qed.*) Admitted. + +Lemma sem_update : + forall A ge sp st x st' st'' st''' f, + sem (mk_ctx st sp ge) f st' -> + match_states st' st''' -> + @step_instr A ge sp st''' x st'' -> + exists tst, sem (mk_ctx st sp ge) (update f x) tst /\ match_states st'' tst. +Proof. + intros. destruct x. + - inv H1. econstructor. simplify. eauto. symmetry; auto. + - inv H1. inv H0. econstructor. + Admitted. + +Lemma rtlblock_trans_correct : + forall bb ge sp st st', + RTLBlock.step_instr_list ge sp st bb st' -> + forall tst, + match_states st tst -> + exists tst', sem (mk_ctx tst sp ge) (abstract_sequence empty bb) tst' + /\ match_states st' tst'. +Proof. + induction bb using rev_ind; simplify. + { econstructor. simplify. apply abstract_interp_empty. + inv H. auto. } + { apply rtlblock_trans_correct' in H. simplify. + rewrite abstract_seq. + exploit IHbb; try eassumption; []; simplify. + exploit sem_update. apply H1. symmetry; eassumption. + eauto. simplify. econstructor. split. apply H3. + auto. } +Qed. + +Lemma abstract_execution_correct: + forall bb bb' cfi cfi' ge tge sp st st' tst, + RTLBlock.step_instr_list ge sp st bb st' -> + ge_preserved ge tge -> + schedule_oracle (mk_bblock bb cfi) (mk_bblock bb' cfi') = true -> + match_states st tst -> + exists tst', RTLPar.step_instr_block tge sp tst bb' tst' + /\ match_states st' tst'. +Proof. + intros. + unfold schedule_oracle in *. simplify. unfold empty_trees in H4. + exploit rtlblock_trans_correct; try eassumption; []; simplify. +(*) exploit abstract_execution_correct'; + try solve [eassumption | apply state_lessdef_match_sem; eassumption]. + apply match_states_commut. eauto. inv_simp. + exploit rtlpar_trans_correct; try eassumption; []; inv_simp. + exploit step_instr_block_matches; eauto. apply match_states_commut; eauto. inv_simp. + repeat match goal with | H: match_states _ _ |- _ => inv H end. + do 2 econstructor; eauto. + econstructor; congruence. +Qed.*)Admitted. Definition match_prog (prog : RTLBlock.program) (tprog : RTLPar.program) := match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq prog tprog. Inductive match_stackframes: RTLBlock.stackframe -> RTLPar.stackframe -> Prop := | match_stackframe: - forall f tf res sp pc rs rs', + forall f tf res sp pc rs rs' ps ps', transl_function f = OK tf -> - regs_lessdef rs rs' -> - match_stackframes (Stackframe res f sp pc rs) - (Stackframe res tf sp pc rs'). + (forall x, rs !! x = rs' !! x) -> + (forall x, ps !! x = ps' !! x) -> + match_stackframes (Stackframe res f sp pc rs ps) + (Stackframe res tf sp pc rs' ps'). Inductive match_states: RTLBlock.state -> RTLPar.state -> Prop := | match_state: - forall sf f sp pc rs rs' m m' sf' tf + forall sf f sp pc rs rs' m sf' tf ps ps' (TRANSL: transl_function f = OK tf) (STACKS: list_forall2 match_stackframes sf sf') - (REG: regs_lessdef rs rs') - (MEM: Mem.extends m m'), - match_states (State sf f sp pc rs m) - (State sf' tf sp pc rs' m') + (REG: forall x, rs !! x = rs' !! x) + (REG: forall x, ps !! x = ps' !! x), + match_states (State sf f sp pc rs ps m) + (State sf' tf sp pc rs' ps' m) | match_returnstate: - forall stack stack' v v' m m' - (STACKS: list_forall2 match_stackframes stack stack') - (MEM: Mem.extends m m') - (LD: Val.lessdef v v'), + forall stack stack' v m + (STACKS: list_forall2 match_stackframes stack stack'), match_states (Returnstate stack v m) - (Returnstate stack' v' m') + (Returnstate stack' v m) | match_callstate: - forall stack stack' f tf args args' m m' + forall stack stack' f tf args m (TRANSL: transl_fundef f = OK tf) - (STACKS: list_forall2 match_stackframes stack stack') - (LD: Val.lessdef_list args args') - (MEM: Mem.extends m m'), + (STACKS: list_forall2 match_stackframes stack stack'), match_states (Callstate stack f args m) - (Callstate stack' tf args' m'). + (Callstate stack' tf args m). Section CORRECTNESS. @@ -121,7 +876,7 @@ Section CORRECTNESS. Lemma find_function_translated: forall ros rs rs' f, - regs_lessdef rs rs' -> + (forall x, rs !! x = rs' !! x) -> find_function ge ros rs = Some f -> exists tf, find_function tge ros rs' = Some tf /\ transl_fundef f = OK tf. @@ -134,7 +889,7 @@ Section CORRECTNESS. | [ H: Genv.find_funct _ Vundef = Some _ |- _] => solve [inv H] | _ => solve [exploit functions_translated; eauto] end. - unfold regs_lessdef; destruct ros; simplify; try rewrite <- H; + destruct ros; simplify; try rewrite <- H; [| rewrite symbols_preserved; destruct_match; try (apply function_ptr_translated); crush ]; intros; @@ -160,8 +915,8 @@ Section CORRECTNESS. Qed. Lemma eval_op_eq: - forall (sp0 : Values.val) (op : Op.operation) (vl : list Values.val), - Op.eval_operation ge sp0 op vl = Op.eval_operation tge sp0 op vl. + forall (sp0 : Values.val) (op : Op.operation) (vl : list Values.val) m, + Op.eval_operation ge sp0 op vl m = Op.eval_operation tge sp0 op vl m. Proof using TRANSL. intros. destruct op; auto; unfold Op.eval_operation, Genv.symbol_address, Op.eval_addressing32; @@ -197,6 +952,16 @@ Section CORRECTNESS. Proof using. destruct or; crush. Qed. Hint Resolve lessdef_regmap_optget : rtlgp. + Lemma regmap_equiv_lessdef: + forall rs rs', + (forall x, rs !! x = rs' !! x) -> + regs_lessdef rs rs'. + Proof using. + intros; unfold regs_lessdef; intros. + rewrite H. apply Val.lessdef_refl. + Qed. + Hint Resolve regmap_equiv_lessdef : rtlgp. + Lemma int_lessdef: forall rs rs', regs_lessdef rs rs' -> @@ -227,8 +992,8 @@ Section CORRECTNESS. let H2 := fresh "SCHED" in learn H as H2; apply schedule_oracle_nil in H2 - | [ H: find_function _ _ _ = Some _ |- _ ] => - learn H; exploit find_function_translated; eauto; inversion 1 + | [ H: find_function _ _ _ = Some _, H2: forall x, ?rs !! x = ?rs' !! x |- _ ] => + learn H; exploit find_function_translated; try apply H2; eauto; inversion 1 | [ H: Mem.free ?m _ _ _ = Some ?m', H2: Mem.extends ?m ?m'' |- _ ] => learn H; exploit Mem.free_parallel_extends; eauto; intros | [ H: Events.eval_builtin_args _ _ _ _ _ _, H2: regs_lessdef ?rs ?rs' |- _ ] => @@ -249,6 +1014,29 @@ Section CORRECTNESS. Hint Resolve set_reg_lessdef : rtlgp. Hint Resolve Op.eval_condition_lessdef : rtlgp. + Hint Constructors Events.eval_builtin_arg: barg. + + Lemma eval_builtin_arg_eq: + forall A ge a v1 m1 e1 e2 sp, + (forall x, e1 x = e2 x) -> + @Events.eval_builtin_arg A ge e1 sp m1 a v1 -> + Events.eval_builtin_arg ge e2 sp m1 a v1. +Proof. induction 2; try rewrite H; eauto with barg. Qed. + + Lemma eval_builtin_args_eq: + forall A ge e1 sp m1 e2 al vl1, + (forall x, e1 x = e2 x) -> + @Events.eval_builtin_args A ge e1 sp m1 al vl1 -> + Events.eval_builtin_args ge e2 sp m1 al vl1. + Proof. + induction 2. + - econstructor; split. + - exploit eval_builtin_arg_eq; eauto. intros. + destruct IHlist_forall2 as [| y]. constructor; eauto. + constructor. constructor; auto. + constructor; eauto. + Qed. + Lemma step_cf_instr_correct: forall cfi t s s', step_cf_instr ge s cfi t s' -> @@ -257,7 +1045,26 @@ Section CORRECTNESS. exists r', step_cf_instr tge r cfi t r' /\ match_states s' r'. Proof using TRANSL. induction 1; repeat semantics_simpl; - repeat (econstructor; eauto with rtlgp). + try solve [repeat (try erewrite match_states_list; eauto; econstructor; eauto with rtlgp)]. + { do 3 (try erewrite match_states_list by eauto; econstructor; eauto with rtlgp). + eapply eval_builtin_args_eq. eapply REG. + eapply Events.eval_builtin_args_preserved. eapply symbols_preserved. + eauto. + intros. + unfold regmap_setres. destruct res. + destruct (Pos.eq_dec x0 x); subst. + repeat rewrite Regmap.gss; auto. + repeat rewrite Regmap.gso; auto. + eapply REG. eapply REG. + } + { repeat (try erewrite match_states_list; eauto; econstructor; eauto with rtlgp). + unfold regmap_optget. destruct or. rewrite REG. constructor; eauto. + constructor; eauto. + } + { exploit IHstep_cf_instr; eauto. simplify. + repeat (try erewrite match_states_list; eauto; econstructor; eauto with rtlgp). + erewrite eval_predf_pr_equiv; eauto. + } Qed. Theorem transl_step_correct : @@ -269,20 +1076,65 @@ Section CORRECTNESS. Proof. induction 1; repeat semantics_simpl. - Abort. - -(* { destruct bb as [bbc bbe]; destruct x as [bbc' bbe']. - assert (bbe = bbe') by admit. - rewrite H3 in H5. - eapply abstract_execution_correct in H5; eauto with rtlgp. - repeat econstructor; eauto with rtlgp. simplify. - exploit step_cf_instr_correct. eauto. - econstructor; eauto with rtlgp. - } - { unfold bind in *. destruct_match; try discriminate. repeat semantics_simpl. inv TRANSL0. - repeat econstructor; eauto. } + + { destruct bb; destruct x. + assert (bb_exit = bb_exit0). + { unfold schedule_oracle in *. simplify. + unfold check_control_flow_instr in *. + destruct_match; crush. + } + subst. + + exploit abstract_execution_correct; try eassumption. eapply ge_preserved_lem. + econstructor; eauto. + simplify. destruct x. inv H7. + + exploit step_cf_instr_correct; try eassumption. econstructor; eauto. + simplify. + + econstructor. econstructor. eapply Smallstep.plus_one. econstructor. + eauto. eauto. simplify. eauto. eauto. } + { unfold bind in *. inv TRANSL0. clear Learn. inv H0. destruct_match; crush. + inv H2. unfold transl_function in Heqr. destruct_match; crush. + inv Heqr. + repeat econstructor; eauto. + unfold bind in *. destruct_match; crush. } { inv TRANSL0. repeat econstructor; eauto using Events.external_call_symbols_preserved, symbols_preserved, senv_preserved, Events.E0_right. } - { inv STACKS. inv H2. repeat econstructor; eauto. } - Qed.*) + { inv STACKS. inv H2. repeat econstructor; eauto. + intros. apply PTree_matches; eauto. } + Qed. + + Lemma transl_initial_states: + forall S, + RTLBlock.initial_state prog S -> + exists R, RTLPar.initial_state tprog R /\ match_states S R. + Proof. + induction 1. + exploit function_ptr_translated; eauto. intros [tf [A B]]. + econstructor; split. + econstructor. apply (Genv.init_mem_transf_partial TRANSL); eauto. + replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved; eauto. + symmetry; eapply match_program_main; eauto. + eexact A. + rewrite <- H2. apply sig_transl_function; auto. + constructor. auto. constructor. + Qed. + + Lemma transl_final_states: + forall S R r, + match_states S R -> RTLBlock.final_state S r -> RTLPar.final_state R r. + Proof. + intros. inv H0. inv H. inv STACKS. constructor. + Qed. + + Theorem transf_program_correct: + Smallstep.forward_simulation (RTLBlock.semantics prog) (RTLPar.semantics tprog). + Proof. + eapply Smallstep.forward_simulation_plus. + apply senv_preserved. + eexact transl_initial_states. + eexact transl_final_states. + exact transl_step_correct. + Qed. End CORRECTNESS. diff --git a/src/hls/Sat.v b/src/hls/Sat.v index 9549947..b7596f6 100644 --- a/src/hls/Sat.v +++ b/src/hls/Sat.v @@ -1,38 +1,21 @@ -(** Homework Assignment 6#<br># +(** #<a href="http://www.cs.berkeley.edu/~adamc/itp/">#Interactive Computer Theorem Proving#</a><br># CS294-9, Fall 2006#<br># UC Berkeley *) -(** Submit your solution file for this assignment as an attachment - #<a href="mailto:adamc@cs.berkeley.edu?subject=ICTP HW6">#by e-mail#</a># with - the subject "ICTP HW6" by the start of class on October 12. - You should write your solutions entirely on your own, which includes not - consulting any solutions to these problems that may be posted on the web. - - #<a href="HW6.v">#Template source file#</a># - *) - Require Import Arith Bool List. +Require Import Coq.funind.Recdef. +Require Coq.MSets.MSetList. +Require Import Coq.Structures.OrderedTypeEx. +Require Import Coq.Structures.OrdersAlt. +Require Import Coq.Program.Wf. +Require Import Vericertlib. -(** This assignment involves building a certified boolean satisfiability solver - based on the DPLL algorithm. Your certified procedure will take as input a - boolean formula in conjunctive normal form (CNF) and either return a - satisfying assignment to the variables or a value signifying that the input - formula is unsatisfiable. Moreover, the procedure will be implemented with a - rich specification, so you'll know that the answer it gives is correct. By - the end of the assignment, you'll have extracted OCaml code that can be used - to solve some of the more modest classes of problems in the SATLIB archive. - - If you need to page in the relevant background material, try the Wikipedia - pages on - #<a href="http://en.wikipedia.org/wiki/Boolean_satisfiability_problem">#SAT#</a># - and - #<a href="http://en.wikipedia.org/wiki/DPLL_algorithm">#the DPLL - algorithm#</a>#. The implementation we'll develop here omits the pure literal - heuristic mentioned on the Wikipedia page but is otherwise identical. - *) +Module Nat_OT := Update_OT Nat_as_OT. +Module NSet := MSetList.Make Nat_OT. +#[local] Open Scope nat. (** * Problem Definition *) @@ -57,77 +40,22 @@ Definition satLit (l : lit) (a : asgn) := Fixpoint satClause (cl : clause) (a : asgn) {struct cl} : Prop := match cl with - | nil => False - | l :: cl' => satLit l a \/ satClause cl' a + | nil => False + | l :: cl' => satLit l a \/ satClause cl' a end. (** An assignment satisfies a clause if it satisfies at least one of its literals. - *) + *) Fixpoint satFormula (fm: formula) (a: asgn) {struct fm} : Prop := match fm with - | nil => True - | cl :: fm' => satClause cl a /\ satFormula fm' a + | nil => True + | cl :: fm' => satClause cl a /\ satFormula fm' a end. (** An assignment satisfies a formula if it satisfies all of its clauses. *) (** * Subroutines *) -(** This is the only section of this assignment where you need to provide your - own solutions. You will be implementing four crucial subroutines used by - DPLL. - - I've provided a number of useful definitions and lemmas which you should feel - free to take advantage of in your definitions. A few tips to keep in mind - while writing these strongly specified functions: - - You have a case-by-case choice of a "programming" approach, based around the - [refine] tactic; or a "proving" approach, where the "code" parts of your - definitions are constructed step by step with tactics. The former is often - harder to get started with, but it tends to be more maintainable. - - When you use [refine] with a [fix] expression, it's usually a good idea to - use the [clear] tactic to remove the recursive function name from the - context immediately afterward. This is because Coq won't check that you - call this function with strictly smaller arguments until the whole proof is - done, and it's a real downer to be told you had an invalid recursion - somewhere after you finally "finish" a proof. Instead, make all recursive - calls explicit in the [refine] argument and clear the function name - afterward. - - You'll probably end up with a lot of proof obligations to discharge, and you - definitely won't want to prove most of them manually. These tactics will - probably be your best friends here: [intuition], [firstorder], [eauto], - [simpl], [subst], .... You will probably want to follow your [refine] tactics - with semicolons and strings of semicolon-separated tactics. These strings - should probably start out with basic simplifiers like [intros], [simpl], and - [subst]. - - A word of warning about the [firstorder] tactic: When it works, it works - really well! However, this tactic has a way of running forever on - complicated enough goals. Be ready to cancel its use (e.g., press the - "Stop" button in Proof General) if it takes more than a few seconds. If - you do things the way I have, be prepared to mix and match all sorts of - different combinations of the automating tactics to get a proof script that - solves the problem quickly enough. - - The dependent type families that we use with rich specifications are all - defined in #<a href="http://coq.inria.fr/library/Coq.Init.Specif.html">#the - Specif module#</a># of the Coq standard library. One potential gotcha when - using them comes from the fact that they are defined inductively with - parameters; that is, some arguments to these type families are defined - before the colon in the [Inductive] command. Compared to general arguments - stemming from function types after that colon, usage of parameters is - restricted; they aren't allowed to vary in recursive occurrences of the - type being defined, for instance. Because of this, parameters are ignored - for the purposes of pattern-matching, while they must be passed when - actually constructing new values. For instance, one would pattern-match a - value of a [sig] type with a pattern like [exist x pf], while one would - construct a new value of the same type like [exist _ x pf]. The parameter - [P] is passed in the second case, and we use an underscore when the Coq - type-checker ought to be able to infer its value. When this inference isn't - possible, you may need to specify manually the predicate defining the [sig] - type you want. - - You can also consult the sizeable example at the end of this file, which ties - together the pieces you are supposed to write. - *) - (** You'll probably want to compare booleans for equality at some point. *) Definition bool_eq_dec : forall (x y : bool), {x = y} + {x <> y}. decide equality. @@ -135,10 +63,10 @@ Defined. (** A literal and its negation can't be true simultaneously. *) Lemma contradictory_assignment : forall s l cl a, - s <> fst l - -> satLit l a - -> satLit (s, snd l) a - -> satClause cl a. + s <> fst l + -> satLit l a + -> satLit (s, snd l) a + -> satClause cl a. intros. red in H0, H1. simpl in H1. @@ -146,79 +74,68 @@ Lemma contradictory_assignment : forall s l cl a, tauto. Qed. -Local Hint Resolve contradictory_assignment : core. +#[local] Hint Resolve contradictory_assignment : core. (** Augment an assignment with a new mapping. *) Definition upd (a : asgn) (l : lit) : asgn := fun v : var => if eq_nat_dec v (snd l) - then fst l - else a v. + then fst l + else a v. (** Some lemmas about [upd] *) Lemma satLit_upd_eq : forall l a, - satLit l (upd a l). + satLit l (upd a l). unfold satLit, upd; simpl; intros. destruct (eq_nat_dec (snd l) (snd l)); tauto. Qed. -Local Hint Resolve satLit_upd_eq : core. +#[local] Hint Resolve satLit_upd_eq : core. Lemma satLit_upd_neq : forall v l s a, - v <> snd l - -> satLit (s, v) (upd a l) - -> satLit (s, v) a. + v <> snd l + -> satLit (s, v) (upd a l) + -> satLit (s, v) a. unfold satLit, upd; simpl; intros. destruct (eq_nat_dec v (snd l)); tauto. Qed. -Local Hint Resolve satLit_upd_neq : core. +#[local] Hint Resolve satLit_upd_neq : core. Lemma satLit_upd_neq2 : forall v l s a, - v <> snd l - -> satLit (s, v) a - -> satLit (s, v) (upd a l). + v <> snd l + -> satLit (s, v) a + -> satLit (s, v) (upd a l). unfold satLit, upd; simpl; intros. destruct (eq_nat_dec v (snd l)); tauto. Qed. -Local Hint Resolve satLit_upd_neq2 : core. +#[local] Hint Resolve satLit_upd_neq2 : core. Lemma satLit_contra : forall s l a cl, - s <> fst l - -> satLit (s, snd l) (upd a l) - -> satClause cl a. + s <> fst l + -> satLit (s, snd l) (upd a l) + -> satClause cl a. unfold satLit, upd; simpl; intros. destruct (eq_nat_dec (snd l) (snd l)); intuition. assert False; intuition. Qed. -Local Hint Resolve satLit_contra : core. - -(** Here's the tactic that I used to discharge #<i>#all#</i># proof obligations - in my implementations of the four functions you will define. - It comes with no warranty, as different implementations may lead to - obligations that it can't solve, or obligations that it takes 42 years to - solve. - However, if you think enough like me, each of the four definitions you fill in - should read like: [[ -refine some_expression_with_holes; clear function_name; magic_solver. -]] leaving out the [clear] invocation for non-recursive function definitions. - *) +#[local] Hint Resolve satLit_contra : core. + Ltac magic_solver := simpl; intros; subst; intuition eauto; firstorder; - match goal with - | [ H1 : satLit ?l ?a, H2 : satClause ?cl ?a |- _ ] => - assert (satClause cl (upd a l)); firstorder - end. + match goal with + | [ H1 : satLit ?l ?a, H2 : satClause ?cl ?a |- _ ] => + assert (satClause cl (upd a l)); firstorder + end. -(** OK, here's your first challenge. Write this strongly-specified function to - update a clause to reflect the effect of making a particular literal true. - *) +(** Strongly-specified function to update a clause to reflect the effect of making a particular + literal true. *) Definition setClause : forall (cl : clause) (l : lit), - {cl' : clause | - forall a, satClause cl (upd a l) <-> satClause cl' a} - + {forall a, satLit l a -> satClause cl a}. + {cl' : clause | + forall a, satClause cl (upd a l) <-> satClause cl' a} + + {forall a, satLit l a -> satClause cl a}. refine (fix setClause (cl: clause) (l: lit) {struct cl} := match cl with | nil => inleft (exist _ nil _) @@ -247,20 +164,13 @@ Defined. (** For testing purposes, we define a weakly-specified function as a thin wrapper around [setClause]. - *) + *) Definition setClauseSimple (cl : clause) (l : lit) := match setClause cl l with - | inleft (exist _ cl' _) => Some cl' - | inright _ => None + | inleft (exist _ cl' _) => Some cl' + | inright _ => None end. -(** When your [setClause] implementation is done, you should be able to - uncomment these test cases and verify that each one yields the correct answer. - Be sure that your [setClause] definition ends in [Defined] and not [Qed], as - the former exposes the definition for use in computational reduction, while - the latter doesn't. - *) - (*Eval compute in setClauseSimple ((false, 1%nat) :: nil) (true, 1%nat).*) (*Eval compute in setClauseSimple nil (true, 0). Eval compute in setClauseSimple ((true, 0) :: nil) (true, 0). @@ -281,40 +191,38 @@ Arguments isNil [A]. (** Some more lemmas that I found helpful.... *) Lemma satLit_idem_lit : forall l a l', - satLit l a - -> satLit l' a - -> satLit l' (upd a l). + satLit l a + -> satLit l' a + -> satLit l' (upd a l). unfold satLit, upd; simpl; intros. destruct (eq_nat_dec (snd l') (snd l)); congruence. Qed. -Local Hint Resolve satLit_idem_lit : core. +#[local] Hint Resolve satLit_idem_lit : core. Lemma satLit_idem_clause : forall l a cl, - satLit l a - -> satClause cl a - -> satClause cl (upd a l). + satLit l a + -> satClause cl a + -> satClause cl (upd a l). induction cl; simpl; intuition. Qed. -Local Hint Resolve satLit_idem_clause : core. +#[local] Hint Resolve satLit_idem_clause : core. Lemma satLit_idem_formula : forall l a fm, - satLit l a - -> satFormula fm a - -> satFormula fm (upd a l). + satLit l a + -> satFormula fm a + -> satFormula fm (upd a l). induction fm; simpl; intuition. Qed. -Local Hint Resolve satLit_idem_formula : core. +#[local] Hint Resolve satLit_idem_formula : core. -(** Challenge 2: Write this function that updates an entire formula to reflect - setting a literal to true. - *) +(** Function that updates an entire formula to reflect setting a literal to true. *) Definition setFormula : forall (fm : formula) (l : lit), - {fm' : formula | - forall a, satFormula fm (upd a l) <-> satFormula fm' a} - + {forall a, satLit l a -> ~satFormula fm a}. + {fm' : formula | + forall a, satFormula fm (upd a l) <-> satFormula fm' a} + + {forall a, satLit l a -> ~satFormula fm a}. refine (fix setFormula (fm: formula) (l: lit) {struct fm} := match fm with | nil => inleft (exist _ nil _) @@ -330,43 +238,39 @@ Definition setFormula : forall (fm : formula) (l : lit), else inleft (exist _ (cl'' :: fm'') _) end end - end); clear setFormula; try solve [magic_solver]. + end); clear setFormula; magic_solver. Defined. -(** Here's some code for testing your implementation. *) - Definition setFormulaSimple (fm : formula) (l : lit) := match setFormula fm l with - | inleft (exist _ fm' _) => Some fm' - | inright _ => None + | inleft (exist _ fm' _) => Some fm' + | inright _ => None end. -(*Eval compute in setFormulaSimple (((true, 1%nat) :: nil) :: ((false, 1%nat) :: nil) :: nil) (true, 1%nat). +Eval compute in setFormulaSimple (((true, 1%nat) :: nil) :: ((false, 1%nat) :: nil) :: nil) (true, 1%nat). Eval compute in setFormulaSimple nil (true, 0). Eval compute in setFormulaSimple (((true, 0) :: nil) :: nil) (true, 0). Eval compute in setFormulaSimple (((false, 0) :: nil) :: nil) (true, 0). Eval compute in setFormulaSimple (((false, 1) :: nil) :: nil) (true, 0). Eval compute in setFormulaSimple (((false, 1) :: (true, 0) :: nil) :: nil) (true, 0). -Eval compute in setFormulaSimple (((false, 1) :: (false, 0) :: nil) :: nil) (true, 0).*) +Eval compute in setFormulaSimple (((false, 1) :: (false, 0) :: nil) :: nil) (true, 0). -Local Hint Extern 1 False => discriminate : core. +#[local] Hint Extern 1 False => discriminate : core. Local Hint Extern 1 False => - match goal with - | [ H : In _ (_ :: _) |- _ ] => inversion H; clear H; subst - end : core. +match goal with +| [ H : In _ (_ :: _) |- _ ] => inversion H; clear H; subst +end : core. -(** Challenge 3: Write this code that either finds a unit clause in a formula - or declares that there are none. - *) +(** Code that either finds a unit clause in a formula or declares that there are none. *) Definition findUnitClause : forall (fm: formula), - {l : lit | In (l :: nil) fm} - + {forall l, ~In (l :: nil) fm}. + {l : lit | In (l :: nil) fm} + + {forall l, ~In (l :: nil) fm}. refine (fix findUnitClause (fm: formula) {struct fm} := match fm with | nil => inright _ | (l :: nil) :: fm' => inleft (exist _ l _) - | cl :: fm' => + | _ :: fm' => match findUnitClause fm' with | inleft (exist _ l _) => inleft (exist _ l _) | inright H => inright _ @@ -375,33 +279,30 @@ Definition findUnitClause : forall (fm: formula), ); clear findUnitClause; magic_solver. Defined. -(** The literal in a unit clause must always be true in a satisfying - assignment. - *) +(** The literal in a unit clause must always be true in a satisfying assignment. *) Lemma unitClauseTrue : forall l a fm, - In (l :: nil) fm - -> satFormula fm a - -> satLit l a. + In (l :: nil) fm + -> satFormula fm a + -> satLit l a. induction fm; intuition. inversion H. inversion H; subst; simpl in H0; intuition. Qed. -Local Hint Resolve unitClauseTrue : core. +#[local] Hint Resolve unitClauseTrue : core. -(** Final challenge: Implement unit propagation. The return type of - [unitPropagate] signifies that three results are possible: +(** Unit propagation. The return type of [unitPropagate] signifies that three results are possible: - [None]: There are no unit clauses. - [Some (inleft _)]: There is a unit clause, and here is a formula reflecting setting its literal to true. - [Some (inright _)]: There is a unit clause, and propagating it reveals that the formula is unsatisfiable. - *) + *) Definition unitPropagate : forall (fm : formula), option (sigT (fun fm' : formula => - {l : lit | - (forall a, satFormula fm a -> satLit l a) - /\ forall a, satFormula fm (upd a l) <-> satFormula fm' a}) -+ {forall a, ~satFormula fm a}). + {l : lit | + (forall a, satFormula fm a -> satLit l a) + /\ forall a, satFormula fm (upd a l) <-> satFormula fm' a}) + + {forall a, ~satFormula fm a}). refine (fix unitPropagate (fm: formula) {struct fm} := match findUnitClause fm with | inright H => None @@ -418,9 +319,9 @@ Defined. Definition unitPropagateSimple (fm : formula) := match unitPropagate fm with - | None => None - | Some (inleft (existT _ fm' (exist _ l _))) => Some (Some (fm', l)) - | Some (inright _) => Some None + | None => None + | Some (inleft (existT _ fm' (exist _ l _))) => Some (Some (fm', l)) + | Some (inright _) => Some None end. (*Eval compute in unitPropagateSimple (((true, 1%nat) :: nil) :: ((false, 1%nat) :: nil) :: nil). @@ -434,23 +335,21 @@ Eval compute in unitPropagateSimple (((false, 0) :: (false, 1) :: nil) :: ((true (** * The SAT Solver *) -(** This section defines a DPLL SAT solver in terms of the subroutines you've - written. - *) +(** This section defines a DPLL SAT solver in terms of the subroutines. *) (** An arbitrary heuristic to choose the next variable to split on *) Definition chooseSplit (fm : formula) := match fm with - | ((l :: _) :: _) => l - | _ => (true, 0) + | ((l :: _) :: _) => l + | _ => (true, 0) end. Definition negate (l : lit) := (negb (fst l), snd l). -Local Hint Unfold satFormula : core. +#[local] Hint Unfold satFormula : core. Lemma satLit_dec : forall l a, - {satLit l a} + {satLit (negate l) a}. + {satLit l a} + {satLit (negate l) a}. destruct l. unfold satLit; simpl; intro. destruct b; destruct (a v); simpl; auto. @@ -461,12 +360,11 @@ Definition alist := list lit. Fixpoint interp_alist (al : alist) : asgn := match al with - | nil => fun _ => true - | l :: al' => upd (interp_alist al') l + | nil => fun _ => true + | l :: al' => upd (interp_alist al') l end. -(** Here's the final definition! This is not the way you should write proof - scripts. ;-) +(** Here's the final definition! This implementation isn't #<i>#quite#</i># what you would expect, since it takes an extra parameter expressing a search tree depth. Writing the function @@ -474,57 +372,57 @@ Fixpoint interp_alist (al : alist) : asgn := In practice, you can just seed the bound with one plus the number of variables in the input, but the function's return type still indicates a possibility for a "time-out" by returning [None]. - *) + *) Definition boundedSat: forall (bound : nat) (fm : formula), - option ({al : alist | satFormula fm (interp_alist al)} - + {forall a, ~satFormula fm a}). + option ({al : alist | satFormula fm (interp_alist al)} + + {forall a, ~satFormula fm a}). refine (fix boundedSat (bound : nat) (fm : formula) {struct bound} - : option ({al : alist | satFormula fm (interp_alist al)} - + {forall a, ~satFormula fm a}) := - match bound with - | O => None - | S bound' => - if isNil fm - then Some (inleft _ (exist _ nil _)) - else match unitPropagate fm with - | Some (inleft (existT _ fm' (exist _ l _))) => - match boundedSat bound' fm' with + : option ({al : alist | satFormula fm (interp_alist al)} + + {forall a, ~satFormula fm a}) := + match bound with + | O => None + | S bound' => + if isNil fm + then Some (inleft _ (exist _ nil _)) + else match unitPropagate fm with + | Some (inleft (existT _ fm' (exist _ l _))) => + match boundedSat bound' fm' with | None => None | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (l :: al) _)) | Some (inright _) => Some (inright _ _) - end - | Some (inright _) => Some (inright _ _) - | None => - let l := chooseSplit fm in + end + | Some (inright _) => Some (inright _ _) + | None => + let l := chooseSplit fm in match setFormula fm l with - | inleft (exist _ fm' _) => - match boundedSat bound' fm' with + | inleft (exist _ fm' _) => + match boundedSat bound' fm' with + | None => None + | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (l :: al) _)) + | Some (inright _) => + match setFormula fm (negate l) with + | inleft (exist _ fm' _) => + match boundedSat bound' fm' with | None => None - | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (l :: al) _)) - | Some (inright _) => - match setFormula fm (negate l) with - | inleft (exist _ fm' _) => - match boundedSat bound' fm' with - | None => None - | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (negate l :: al) _)) - | Some (inright _) => Some (inright _ _) - end - | inright _ => Some (inright _ _) - end + | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (negate l :: al) _)) + | Some (inright _) => Some (inright _ _) + end + | inright _ => Some (inright _ _) end - | inright _ => - match setFormula fm (negate l) with - | inleft (exist _ fm' _) => - match boundedSat bound' fm' with - | None => None - | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (negate l :: al) _)) - | Some (inright _) => Some (inright _ _) - end - | inright _ => Some (inright _ _) + end + | inright _ => + match setFormula fm (negate l) with + | inleft (exist _ fm' _) => + match boundedSat bound' fm' with + | None => None + | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (negate l :: al) _)) + | Some (inright _) => Some (inright _ _) end + | inright _ => Some (inright _ _) + end end - end - end); simpl; intros; subst; intuition; try generalize dependent (interp_alist al). + end + end); simpl; intros; subst; intuition; try generalize dependent (interp_alist al). firstorder. firstorder. firstorder. @@ -578,3 +476,186 @@ Eval compute in boundedSatSimple 100 (((true, 0) :: (false, 1) :: nil) :: ((true Eval compute in boundedSatSimple 100 (((true, 0) :: (false, 1) :: nil) :: ((true, 1) :: (false, 0) :: nil) :: nil). Eval compute in boundedSatSimple 100 (((true, 0) :: (false, 1) :: nil) :: ((false, 0) :: (false, 0) :: nil) :: ((true, 1) :: nil) :: nil). Eval compute in boundedSatSimple 100 (((false, 0) :: (true, 1) :: nil) :: ((false, 1) :: (true, 0) :: nil) :: nil).*) + +Definition lit_set_cl (cl: clause) := + fold_right NSet.add NSet.empty (map snd cl). + +Definition lit_set (fm: formula) := + fold_right NSet.union NSet.empty (map lit_set_cl fm). + +Compute NSet.cardinal (lit_set (((true, 1)::(true, 1)::(true, 1)::nil)::nil)). + +Definition sat_measure (fm: formula) := NSet.cardinal (lit_set fm). + +Lemma elim_clause : + forall (cl: clause) l, In l cl -> exists H, setClause cl l = inright H. +Proof. + induction cl; intros; simpl in *; try contradiction. + destruct (setClause cl l) eqn:?; [|econstructor; eauto]. + destruct s. inversion H; subst. clear H. + destruct (Nat.eq_dec (snd l) (snd l)); [| contradiction]. + destruct (bool_eq_dec (fst l) (fst l)); [| contradiction]. + econstructor. eauto. apply IHcl in H0. + inversion H0. rewrite H1 in Heqs. discriminate. +Qed. + +Lemma sat_measure_setClause' : + forall cl cl' l A, + setClause cl l = inleft (exist _ cl' A) -> + ~ In (snd l) (map snd cl'). +Proof. + induction cl; intros. + { simpl in *. inv H. unfold not in *. intros. inv H. } + { simpl in H. + repeat (destruct_match; crush; []). destruct_match. + repeat (destruct_match; crush; []). inv H. eapply IHcl; eauto. + inv H. unfold not. intros. inv H. contradiction. eapply IHcl; eauto. + } +Qed. + +Lemma sat_measure_setClause'' : + forall cl cl' l A, + setClause cl l = inleft (exist _ cl' A) -> + forall l', + l' <> snd l -> + In l' (map snd cl) -> + In l' (map snd cl'). +Proof. + induction cl; intros. + { inversion H1. } + { inversion H1. subst. simpl in H. + repeat (destruct_match; crush; []). inv H. simpl. + inv H1. eauto. right. eapply IHcl; eauto. + simpl in H. repeat (destruct_match; crush; []). destruct_match. + repeat (destruct_match; crush; []). inv H. eapply IHcl; eauto. + inv H1; crush. inv H. simplify. auto. + inv H. simpl. right. eapply IHcl; eauto. + } +Qed. + +Lemma sat_measure_setClause : + forall cl cl' l A, + In (snd l) (map snd cl) -> + setClause cl l = inleft (exist _ cl' A) -> + NSet.cardinal (lit_set_cl cl') < NSet.cardinal (lit_set_cl cl). +Proof. + intros. pose proof H0. apply sat_measure_setClause' in H0. + pose proof (sat_measure_setClause'' _ _ _ _ H1). admit. +Admitted. + +Definition InFm l (fm: formula) := exists cl, In cl fm /\ In l cl. + +Lemma sat_measure_setFormula : + forall fm fm' l A, + InFm l fm -> + setFormula fm l = inleft (exist _ fm' A) -> + sat_measure fm' < sat_measure fm. +Proof. Admitted. + +Lemma sat_measure_propagate_unit : + forall fm' fm H, + unitPropagate fm = Some (inleft (existT _ fm' H)) -> + sat_measure fm' < sat_measure fm. +Proof. + induction fm; crush. + repeat (destruct_match; crush; []). + destruct_match. + repeat (destruct_match; crush; []). + inv Heqs1. + unfold sat_measure. + Admitted. + +Program Fixpoint satSolve (fm: formula) { measure (sat_measure fm) }: + {al : alist | satFormula fm (interp_alist al)} + {forall a, ~satFormula fm a} := + if isNil fm + then inleft _ (exist _ nil _) + else match unitPropagate fm with + | Some (inleft (existT _ fm' (exist _ l _))) => + match satSolve fm' with + | inleft (exist _ al _) => inleft _ (exist _ (l :: al) _) + | inright _ => inright _ _ + end + | Some (inright _) => inright _ _ + | None => + let l := chooseSplit fm in + match setFormula fm l with + | inleft (exist _ fm' _) => + match satSolve fm' with + | inleft (exist _ al _) => inleft _ (exist _ (l :: al) _) + | inright _ => + match setFormula fm (negate l) with + | inleft (exist _ fm' _) => + match satSolve fm' with + | inleft (exist _ al _) => inleft _ (exist _ (negate l :: al) _) + | inright _ => inright _ _ + end + | inright _ => inright _ _ + end + end + | inright _ => + match setFormula fm (negate l) with + | inleft (exist _ fm' _) => + match satSolve fm' with + | inleft (exist _ al _) => inleft _ (exist _ (negate l :: al) _) + | inright _ => inright _ _ + end + | inright _ => inright _ _ + end + end + end. +Next Obligation. + eapply sat_measure_propagate_unit; eauto. Defined. +Next Obligation. + apply i; auto. Defined. +Next Obligation. + unfold not; intros; eapply wildcard'; apply i; eauto. Defined. +Next Obligation. + Admitted. +Next Obligation. + apply wildcard'0; auto. Defined. +Next Obligation. + Admitted. +Next Obligation. + apply wildcard'2; auto. Defined. +Next Obligation. + unfold not in *; intros. + destruct (satLit_dec (chooseSplit fm) a); + [assert (satFormula fm (upd a (chooseSplit fm))) + | assert (satFormula fm (upd a (negate (chooseSplit fm))))]; firstorder. + { eapply wildcard'1. apply wildcard'0; eauto. } + { eapply wildcard'. apply wildcard'2; eauto. } +Defined. +Next Obligation. + unfold not in *; intros. + destruct (satLit_dec (chooseSplit fm) a); + [assert (satFormula fm (upd a (chooseSplit fm))) + | assert (satFormula fm (upd a (negate (chooseSplit fm))))]; firstorder. + { eapply wildcard'1. eapply wildcard'0. eauto. } + { eapply wildcard'; eauto. } +Defined. +Next Obligation. + Admitted. +Next Obligation. + apply wildcard'1; auto. Defined. +Next Obligation. + unfold not in *; intros. + destruct (satLit_dec (chooseSplit fm) a); + [assert (satFormula fm (upd a (chooseSplit fm))) + | assert (satFormula fm (upd a (negate (chooseSplit fm))))]; firstorder. + { eapply wildcard'0; eauto. } + { eapply wildcard'; apply wildcard'1; eauto. } +Defined. +Next Obligation. + unfold not in *; intros. + destruct (satLit_dec (chooseSplit fm) a). + { eapply wildcard'0; eauto. } + { eapply wildcard'; eauto. } +Defined. + +Definition satSolveSimple (fm : formula) := + match satSolve fm with + | inleft (exist _ a _) => Some a + | inright _ => None + end. + +Eval compute in satSolveSimple nil. diff --git a/src/hls/Schedule.ml b/src/hls/Schedule.ml index 613236f..94225fa 100644 --- a/src/hls/Schedule.ml +++ b/src/hls/Schedule.ml @@ -26,6 +26,7 @@ open AST open Kildall open Op open RTLBlockInstr +open Predicate open RTLBlock open HTL open Verilog @@ -87,14 +88,25 @@ end)(struct let default = 0 end) +module DFGSimp = Graph.Persistent.Graph.Concrete(struct + type t = int * instr + let compare = compare + let equal = (=) + let hash = Hashtbl.hash + end) + +let convert dfg = + DFG.fold_vertex (fun v g -> DFGSimp.add_vertex g v) dfg DFGSimp.empty + |> DFG.fold_edges (fun v1 v2 g -> DFGSimp.add_edge (DFGSimp.add_edge g v1 v2) v2 v1) dfg + let reg r = sprintf "r%d" (P.to_int r) -let print_pred r = sprintf "p%d" (Nat.to_int r) +let print_pred r = sprintf "p%d" (P.to_int r) let print_instr = function | RBnop -> "" | RBload (_, _, _, _, r) -> sprintf "load(%s)" (reg r) | RBstore (_, _, _, _, r) -> sprintf "store(%s)" (reg r) - | RBsetpred (_, _, p) -> sprintf "setpred(%s)" (print_pred p) + | RBsetpred (_, _, _, p) -> sprintf "setpred(%s)" (print_pred p) | RBop (_, op, args, d) -> (match op, args with | Omove, _ -> "mov" @@ -203,6 +215,8 @@ module DFGDot = Graph.Graphviz.Dot(struct include DFG end) +module DFGDfs = Graph.Traverse.Dfs(DFG) + module IMap = Map.Make (struct type t = int @@ -341,7 +355,7 @@ let rec find_all_next_dst_read i dst i' curr = | RBload (_, _, _, rs, _) :: curr' -> check_dst rs curr' | RBstore (_, _, _, rs, src) :: curr' -> check_dst (src :: rs) curr' | RBnop :: curr' -> find_all_next_dst_read i dst (i' + 1) curr' - | RBsetpred (_, rs, _) :: curr' -> check_dst rs curr' + | RBsetpred (_, _, rs, _) :: curr' -> check_dst rs curr' let drop i lst = let rec drop' i' lst' = @@ -400,10 +414,11 @@ let accumulate_WAW_mem_deps instrs dfg curri = let rec in_predicate p p' = match p' with - | Pvar p'' -> Nat.to_int p = Nat.to_int p'' - | Pnot p'' -> in_predicate p p'' + | Plit p'' -> P.to_int p = P.to_int (snd p'') | Pand (p1, p2) -> in_predicate p p1 || in_predicate p p2 | Por (p1, p2) -> in_predicate p p1 || in_predicate p p2 + | Ptrue -> false + | Pfalse -> false let get_predicate = function | RBop (p, _, _, _) -> p @@ -413,7 +428,7 @@ let get_predicate = function let rec next_setpred p i = function | [] -> None - | RBsetpred (_, _, p') :: rst -> + | RBsetpred (_, _, _, p') :: rst -> if in_predicate p' p then Some i else @@ -446,7 +461,7 @@ let accumulate_RAW_pred_deps instrs dfg curri = let accumulate_WAR_pred_deps instrs dfg curri = let i, curr = curri in match curr with - | RBsetpred (_, _, p) -> ( + | RBsetpred (_, _, _, p) -> ( match next_preduse p 0 (take i instrs |> List.rev) with | None -> dfg | Some d -> DFG.add_edge dfg (gen_vertex instrs (i - d - 1)) (gen_vertex instrs i) ) @@ -455,8 +470,8 @@ let accumulate_WAR_pred_deps instrs dfg curri = let accumulate_WAW_pred_deps instrs dfg curri = let i, curr = curri in match curr with - | RBsetpred (_, _, p) -> ( - match next_setpred (Pvar p) 0 (take i instrs |> List.rev) with + | RBsetpred (_, _, _, p) -> ( + match next_setpred (Plit (true, p)) 0 (take i instrs |> List.rev) with | None -> dfg | Some d -> DFG.add_edge dfg (gen_vertex instrs (i - d - 1)) (gen_vertex instrs i) ) | _ -> dfg @@ -499,18 +514,18 @@ let assigned_vars vars = function | RBop (_, _, _, dst) -> dst :: vars | RBload (_, _, _, _, dst) -> dst :: vars | RBstore (_, _, _, _, _) -> vars - | RBsetpred (_, _, _) -> vars + | RBsetpred (_, _, _, _) -> vars let get_pred = function | RBnop -> None | RBop (op, _, _, _) -> op | RBload (op, _, _, _, _) -> op | RBstore (op, _, _, _, _) -> op - | RBsetpred (_, _, _) -> None + | RBsetpred (_, _, _, _) -> None let independant_pred p p' = - match sat_pred_temp (Nat.of_int 100000) (Pand (p, p')) with - | Some None -> true + match sat_pred_simple (Pand (p, p')) with + | None -> true | _ -> false let check_dependent op1 op2 = @@ -720,22 +735,22 @@ let parse_soln (tree, bbtree) s = else (tree, bbtree)) let solve_constraints constr = - let oc = open_out "lpsolve.txt" in + let (fn, oc) = Filename.open_temp_file "vericert_" "_lp_solve" in fprintf oc "%s\n" (print_lp constr); close_out oc; - Str.split (Str.regexp_string "\n") (read_process "lp_solve lpsolve.txt") - |> drop 3 - |> List.fold_left parse_soln (IMap.empty, IMap.empty) + let res = Str.split (Str.regexp_string "\n") (read_process ("lp_solve " ^ fn)) + |> drop 3 + |> List.fold_left parse_soln (IMap.empty, IMap.empty) + in + Sys.remove fn; res let subgraph dfg l = let dfg' = List.fold_left (fun g v -> DFG.add_vertex g v) DFG.empty l in List.fold_left (fun g v -> List.fold_left (fun g' v' -> let edges = DFG.find_all_edges dfg v v' in - List.fold_left (fun g'' e -> - DFG.add_edge_e g'' e - ) g' edges + List.fold_left DFG.add_edge_e g' edges ) g l ) dfg' l @@ -755,6 +770,21 @@ let combine_bb_schedule schedule s = let i, st = s in IMap.update st (update_schedule i) schedule +(**let add_el dfg i l = + List.*) + +let check_in el = + List.exists (List.exists ((=) el)) + +let all_dfs dfg = + let roots = DFG.fold_vertex (fun v li -> + if DFG.in_degree dfg v = 0 then v :: li else li + ) dfg [] in + let dfg' = DFG.fold_edges (fun v1 v2 g -> DFG.add_edge g v2 v1) dfg dfg in + List.fold_left (fun a el -> + if check_in el a then a else + (DFGDfs.fold_component (fun v l -> v :: l) [] dfg' el) :: a) [] roots + let range s e = List.init (e - s) (fun i -> i) |> List.map (fun x -> x + s) @@ -773,23 +803,29 @@ let transf_rtlpar c c' schedule = let i_sched_tree = List.fold_left combine_bb_schedule IMap.empty i_sched in - (*let body = IMap.to_seq i_sched_tree |> List.of_seq |> List.map snd + let body = IMap.to_seq i_sched_tree |> List.of_seq |> List.map snd |> List.map (List.map (fun x -> (x, List.nth bb_body' x))) - in*) - let body2 = List.fold_left (fun x b -> + in + (*let body2 = List.fold_left (fun x b -> match IMap.find_opt b i_sched_tree with | Some i -> i :: x | None -> [] :: x ) [] (range (fst bb_st_e) (snd bb_st_e + 1)) |> List.map (List.map (fun x -> (x, List.nth bb_body' x))) |> List.rev - in + in*) (*let final_body = List.map (fun x -> subgraph dfg x |> order_instr) body in*) let final_body2 = List.map (fun x -> subgraph dfg x - |> (fun x -> TopoDFG.fold (fun i l -> snd i :: l) x []) - |> List.rev) body2 + |> (fun x -> + all_dfs x + |> List.map (subgraph x) + |> List.map (fun y -> + TopoDFG.fold (fun i l -> snd i :: l) y [] + |> List.rev))) body + (*|> (fun x -> TopoDFG.fold (fun i l -> snd i :: l) x []) + |> List.rev) body2*) in - { bb_body = List.map (fun x -> [x]) final_body2; + { bb_body = final_body2; bb_exit = ctrl_flow } in @@ -799,7 +835,7 @@ let schedule entry (c : RTLBlock.bb RTLBlockInstr.code) = let debug = true in let transf_graph (_, dfg, _) = dfg in let c' = PTree.map1 (fun x -> gather_bb_constraints false x |> transf_graph) c in - (*let _ = if debug then PTree.map (fun r o -> printf "##### %d #####\n%a\n\n" (P.to_int r) print_dfg (second o)) c' else PTree.empty in*) + (*let _ = if debug then PTree.map (fun r o -> printf "##### %d #####\n%a\n\n" (P.to_int r) print_dfg o) c' else PTree.empty in*) let cgraph = PTree.elements c' |> List.map (function (x, y) -> (P.to_int x, y)) |> List.fold_left (gather_cfg_constraints c) G.empty @@ -809,7 +845,7 @@ let schedule entry (c : RTLBlock.bb RTLBlockInstr.code) = close_out graph; let schedule' = solve_constraints cgraph in (**IMap.iter (fun a b -> printf "##### %d #####\n%a\n\n" a (print_list print_tuple) b) schedule';*) - (*printf "Schedule: %a\n" (fun a x -> IMap.iter (fun d -> fprintf a "%d: %a\n" d (print_list print_tuple)) x) schedule';*) + (**printf "Schedule: %a\n" (fun a x -> IMap.iter (fun d -> fprintf a "%d: %a\n" d (print_list print_tuple)) x) schedule';*) transf_rtlpar c c' schedule' let rec find_reachable_states c e = @@ -831,7 +867,6 @@ let schedule_fn (f : RTLBlock.coq_function) : RTLPar.coq_function = { fn_sig = f.fn_sig; fn_params = f.fn_params; fn_stacksize = f.fn_stacksize; - fn_code = List.fold_left (add_to_tree scheduled) PTree.empty reachable; - fn_funct_units = f.fn_funct_units; + fn_code = scheduled (*List.fold_left (add_to_tree scheduled) PTree.empty reachable*); fn_entrypoint = f.fn_entrypoint } diff --git a/src/hls/Verilog.v b/src/hls/Verilog.v index 779b05c..3a2c81d 100644 --- a/src/hls/Verilog.v +++ b/src/hls/Verilog.v @@ -21,23 +21,24 @@ Set Implicit Arguments. Require Import Coq.Structures.OrderedTypeEx. Require Import Coq.FSets.FMapPositive. +Require Import Coq.Program.Basics. Require Import Coq.Arith.PeanoNat. Require Import Coq.ZArith.ZArith. Require Import Coq.Lists.List. +Require Import Coq.Program.Program. Require Import Coq.micromega.Lia. +Require compcert.common.Events. +Require Import compcert.lib.Integers. Require Import compcert.common.Errors. -Require Import compcert.common.Globalenvs. Require Import compcert.common.Smallstep. -Require Import compcert.lib.Integers. -Require compcert.common.Events. +Require Import compcert.common.Globalenvs. -Require Import vericert.common.Show. Require Import vericert.common.Vericertlib. -Require Import vericert.hls.Array. -Require Import vericert.hls.AssocMap. -Require Import vericert.hls.FunctionalUnits. +Require Import vericert.common.Show. Require Import vericert.hls.ValueInt. +Require Import vericert.hls.AssocMap. +Require Import vericert.hls.Array. Import ListNotations. @@ -81,6 +82,39 @@ Definition merge_arr (new : option arr) (old : option arr) : option arr := Definition merge_arrs (new : assocmap_arr) (old : assocmap_arr) : assocmap_arr := AssocMap.combine merge_arr new old. +Lemma merge_arr_empty': + forall l, + merge_arr (Some (arr_repeat None (length l))) (Some (make_array l)) = Some (make_array l). +Proof. + induction l; auto. + unfold merge_arr. + unfold combine, make_array. simplify. rewrite H0. + rewrite list_repeat_cons. simplify. + rewrite H0; auto. +Qed. + +Lemma merge_arr_empty: + forall v l, + v = Some (make_array l) -> + merge_arr (Some (arr_repeat None (length l))) v = v. +Proof. intros. rewrite H. apply merge_arr_empty'. Qed. + +Lemma merge_arr_empty2: + forall v l v', + v = Some v' -> + l = arr_length v' -> + merge_arr (Some (arr_repeat None l)) v = v. +Proof. + intros. subst. destruct v'. simplify. + generalize dependent arr_wf. generalize dependent arr_length. + induction arr_contents. + - simplify; subst; auto. + - unfold combine, make_array in *; simplify; subst. + rewrite list_repeat_cons; simplify. + specialize (IHarr_contents (Datatypes.length arr_contents) eq_refl). + inv IHarr_contents. rewrite H0. rewrite H0. auto. +Qed. + Definition arr_assocmap_lookup (a : assocmap_arr) (r : reg) (i : nat) : option value := match a ! r with | None => None @@ -195,9 +229,12 @@ Inductive stmnt : Type := | Vskip : stmnt | Vseq : stmnt -> stmnt -> stmnt | Vcond : expr -> stmnt -> stmnt -> stmnt -| Vcase : expr -> list (expr * stmnt) -> option stmnt -> stmnt +| Vcase : expr -> stmnt_expr_list -> option stmnt -> stmnt | Vblock : expr -> expr -> stmnt -| Vnonblock : expr -> expr -> stmnt. +| Vnonblock : expr -> expr -> stmnt +with stmnt_expr_list : Type := +| Stmntnil : stmnt_expr_list +| Stmntcons : expr -> stmnt -> stmnt_expr_list -> stmnt_expr_list. (*| Edges @@ -263,7 +300,6 @@ Record module : Type := mkmodule { mod_stk : reg; mod_stk_len : nat; mod_args : list reg; - mod_funct_units: funct_units; mod_body : list module_item; mod_entrypoint : node; }. @@ -405,7 +441,7 @@ Inductive expr_runp : fext -> assocmap -> assocmap_arr -> expr -> value -> Prop expr_runp fext reg stack fs vf -> valueToBool vc = false -> expr_runp fext reg stack (Vternary c ts fs) vf. -Hint Constructors expr_runp : verilog. +#[export] Hint Constructors expr_runp : verilog. Definition handle_opt {A : Type} (err : errmsg) (val : option A) : res A := @@ -464,19 +500,19 @@ Inductive stmnt_runp: fext -> reg_associations -> arr_associations -> expr_runp f asr0.(assoc_blocking) asa0.(assoc_blocking) me mve -> mve <> ve -> stmnt_runp f asr0 asa0 (Vcase e cs def) asr1 asa1 -> - stmnt_runp f asr0 asa0 (Vcase e ((me, sc)::cs) def) asr1 asa1 + stmnt_runp f asr0 asa0 (Vcase e (Stmntcons me sc cs) def) asr1 asa1 | stmnt_runp_Vcase_match: forall e ve asr0 asa0 f asr1 asa1 me mve sc cs def, expr_runp f asr0.(assoc_blocking) asa0.(assoc_blocking) e ve -> expr_runp f asr0.(assoc_blocking) asa0.(assoc_blocking) me mve -> mve = ve -> stmnt_runp f asr0 asa0 sc asr1 asa1 -> - stmnt_runp f asr0 asa0 (Vcase e ((me, sc)::cs) def) asr1 asa1 + stmnt_runp f asr0 asa0 (Vcase e (Stmntcons me sc cs) def) asr1 asa1 | stmnt_runp_Vcase_default: forall asr0 asa0 asr1 asa1 f st e ve, expr_runp f asr0.(assoc_blocking) asa0.(assoc_blocking) e ve -> stmnt_runp f asr0 asa0 st asr1 asa1 -> - stmnt_runp f asr0 asa0 (Vcase e nil (Some st)) asr1 asa1 + stmnt_runp f asr0 asa0 (Vcase e Stmntnil (Some st)) asr1 asa1 | stmnt_runp_Vblock_reg: forall lhs r rhs rhsval asr asa f, location_is f asr.(assoc_blocking) asa.(assoc_blocking) lhs (LocReg r) -> @@ -505,26 +541,35 @@ Inductive stmnt_runp: fext -> reg_associations -> arr_associations -> stmnt_runp f asr asa (Vnonblock lhs rhs) asr (nonblock_arr r i asa rhsval). -Hint Constructors stmnt_runp : verilog. +#[export] Hint Constructors stmnt_runp : verilog. Inductive mi_stepp : fext -> reg_associations -> arr_associations -> module_item -> reg_associations -> arr_associations -> Prop := | mi_stepp_Valways : forall f sr0 sa0 st sr1 sa1 c, stmnt_runp f sr0 sa0 st sr1 sa1 -> - mi_stepp f sr0 sa0 (Valways c st) sr1 sa1 -| mi_stepp_Valways_ff : - forall f sr0 sa0 st sr1 sa1 c, - stmnt_runp f sr0 sa0 st sr1 sa1 -> - mi_stepp f sr0 sa0 (Valways_ff c st) sr1 sa1 -| mi_stepp_Valways_comb : + mi_stepp f sr0 sa0 (Valways (Vposedge c) st) sr1 sa1 +| mi_stepp_Valways_ne : + forall f sr0 sa0 c st, + mi_stepp f sr0 sa0 (Valways (Vnegedge c) st) sr0 sa0 +| mi_stepp_Vdecl : + forall f sr0 sa0 d, + mi_stepp f sr0 sa0 (Vdeclaration d) sr0 sa0. +#[export] Hint Constructors mi_stepp : verilog. + +Inductive mi_stepp_negedge : fext -> reg_associations -> arr_associations -> + module_item -> reg_associations -> arr_associations -> Prop := +| mi_stepp_negedge_Valways : forall f sr0 sa0 st sr1 sa1 c, stmnt_runp f sr0 sa0 st sr1 sa1 -> - mi_stepp f sr0 sa0 (Valways_comb c st) sr1 sa1 -| mi_stepp_Vdecl : - forall f sr sa d, - mi_stepp f sr sa (Vdeclaration d) sr sa. -Hint Constructors mi_stepp : verilog. + mi_stepp_negedge f sr0 sa0 (Valways (Vnegedge c) st) sr1 sa1 +| mi_stepp_negedge_Valways_ne : + forall f sr0 sa0 c st, + mi_stepp_negedge f sr0 sa0 (Valways (Vposedge c) st) sr0 sa0 +| mi_stepp_negedge_Vdecl : + forall f sr0 sa0 d, + mi_stepp_negedge f sr0 sa0 (Vdeclaration d) sr0 sa0. +#[export] Hint Constructors mi_stepp : verilog. Inductive mis_stepp : fext -> reg_associations -> arr_associations -> list module_item -> reg_associations -> arr_associations -> Prop := @@ -536,7 +581,19 @@ Inductive mis_stepp : fext -> reg_associations -> arr_associations -> | mis_stepp_Nil : forall f sr sa, mis_stepp f sr sa nil sr sa. -Hint Constructors mis_stepp : verilog. +#[export] Hint Constructors mis_stepp : verilog. + +Inductive mis_stepp_negedge : fext -> reg_associations -> arr_associations -> + list module_item -> reg_associations -> arr_associations -> Prop := +| mis_stepp_negedge_Cons : + forall f mi mis sr0 sa0 sr1 sa1 sr2 sa2, + mi_stepp_negedge f sr0 sa0 mi sr1 sa1 -> + mis_stepp_negedge f sr1 sa1 mis sr2 sa2 -> + mis_stepp_negedge f sr0 sa0 (mi :: mis) sr2 sa2 +| mis_stepp_negedge_Nil : + forall f sr sa, + mis_stepp_negedge f sr sa nil sr sa. +#[export] Hint Constructors mis_stepp : verilog. Local Close Scope error_monad_scope. @@ -552,18 +609,24 @@ Definition empty_stack (m : module) : assocmap_arr := Inductive step : genv -> state -> Events.trace -> state -> Prop := | step_module : - forall asr asa asr' asa' basr1 nasr1 basa1 nasa1 f stval pstval m sf st g ist, + forall asr asa asr' asa' basr1 nasr1 basa1 nasa1 basr2 nasr2 + basa2 nasa2 f stval pstval m sf st g ist, asr!(m.(mod_reset)) = Some (ZToValue 0) -> asr!(m.(mod_finish)) = Some (ZToValue 0) -> asr!(m.(mod_st)) = Some ist -> valueToPos ist = st -> mis_stepp f (mkassociations asr empty_assocmap) (mkassociations asa (empty_stack m)) - m.(mod_body) + (mod_body m) (mkassociations basr1 nasr1) - (mkassociations basa1 nasa1)-> - asr' = merge_regs nasr1 basr1 -> - asa' = merge_arrs nasa1 basa1 -> + (mkassociations basa1 nasa1) -> + mis_stepp_negedge f (mkassociations (merge_regs nasr1 basr1) empty_assocmap) + (mkassociations (merge_arrs nasa1 basa1) (empty_stack m)) + (mod_body m) + (mkassociations basr2 nasr2) + (mkassociations basa2 nasa2) -> + asr' = merge_regs nasr2 basr2 -> + asa' = merge_arrs nasa2 basa2 -> asr'!(m.(mod_st)) = Some stval -> valueToPos stval = pstval -> step g (State sf m st asr asa) Events.E0 (State sf m pstval asr' asa') @@ -586,7 +649,7 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := mst = mod_st m -> step g (Returnstate (Stackframe r m pc asr asa :: sf) i) Events.E0 (State sf m pc ((asr # mst <- (posToValue pc)) # r <- i) asa). -Hint Constructors step : verilog. +#[export] Hint Constructors step : verilog. Inductive initial_state (p: program): state -> Prop := | initial_state_intro: forall b m0 m, @@ -605,6 +668,18 @@ Definition semantics (m : program) := Smallstep.Semantics step (initial_state m) final_state (Globalenvs.Genv.globalenv m). +Fixpoint list_to_stmnt st := + match st with + | (e, s) :: r => Stmntcons e s (list_to_stmnt r) + | nil => Stmntnil + end. + +Fixpoint stmnt_to_list st := + match st with + | Stmntcons e s r => (e, s) :: stmnt_to_list r + | Stmntnil => nil + end. + Lemma expr_runp_determinate : forall f e asr asa v, expr_runp f asr asa e v -> @@ -632,7 +707,7 @@ Proof. learn (H1 _ H2) end; crush). Qed. -Hint Resolve expr_runp_determinate : verilog. +#[export] Hint Resolve expr_runp_determinate : verilog. Lemma location_is_determinate : forall f asr asa e l, @@ -665,8 +740,8 @@ Lemma stmnt_runp_determinate : | [ H : stmnt_runp _ _ _ (Vblock _ _) _ _ |- _ ] => invert H | [ H : stmnt_runp _ _ _ Vskip _ _ |- _ ] => invert H | [ H : stmnt_runp _ _ _ (Vcond _ _ _) _ _ |- _ ] => invert H - | [ H : stmnt_runp _ _ _ (Vcase _ (_ :: _) _) _ _ |- _ ] => invert H - | [ H : stmnt_runp _ _ _ (Vcase _ [] _) _ _ |- _ ] => invert H + | [ H : stmnt_runp _ _ _ (Vcase _ (Stmntcons _ _ _) _) _ _ |- _ ] => invert H + | [ H : stmnt_runp _ _ _ (Vcase _ Stmntnil _) _ _ |- _ ] => invert H | [ H1 : expr_runp _ ?asr ?asa ?e _, H2 : expr_runp _ ?asr ?asa ?e _ |- _ ] => @@ -681,7 +756,7 @@ Lemma stmnt_runp_determinate : learn (H1 _ _ H2) end; crush). Qed. -Hint Resolve stmnt_runp_determinate : verilog. +#[export] Hint Resolve stmnt_runp_determinate : verilog. Lemma mi_stepp_determinate : forall f asr0 asa0 m asr1 asa1, @@ -699,6 +774,22 @@ Proof. end; crush). Qed. +Lemma mi_stepp_negedge_determinate : + forall f asr0 asa0 m asr1 asa1, + mi_stepp_negedge f asr0 asa0 m asr1 asa1 -> + forall asr1' asa1', + mi_stepp_negedge f asr0 asa0 m asr1' asa1' -> + asr1' = asr1 /\ asa1' = asa1. +Proof. + intros. destruct m; invert H; invert H0; + + repeat (try match goal with + | [ H1 : stmnt_runp _ ?asr0 ?asa0 ?s _ _, + H2 : stmnt_runp _ ?asr0 ?asa0 ?s _ _ |- _ ] => + learn (stmnt_runp_determinate H1 H2) + end; crush). +Qed. + Lemma mis_stepp_determinate : forall f asr0 asa0 m asr1 asa1, mis_stepp f asr0 asa0 m asr1 asa1 -> @@ -722,17 +813,77 @@ Proof. end; crush). Qed. +Lemma mis_stepp_negedge_determinate : + forall f asr0 asa0 m asr1 asa1, + mis_stepp_negedge f asr0 asa0 m asr1 asa1 -> + forall asr1' asa1', + mis_stepp_negedge f asr0 asa0 m asr1' asa1' -> + asr1' = asr1 /\ asa1' = asa1. +Proof. + induction 1; intros; + + repeat (try match goal with + | [ H : mis_stepp_negedge _ _ _ [] _ _ |- _ ] => invert H + | [ H : mis_stepp_negedge _ _ _ ( _ :: _ ) _ _ |- _ ] => invert H + + | [ H1 : mi_stepp_negedge _ ?asr0 ?asa0 ?s _ _, + H2 : mi_stepp_negedge _ ?asr0 ?asa0 ?s _ _ |- _ ] => + learn (mi_stepp_negedge_determinate H1 H2) + + | [ H1 : forall asr1 asa1, mis_stepp_negedge _ ?asr0 ?asa0 ?m asr1 asa1 -> _, + H2 : mis_stepp_negedge _ ?asr0 ?asa0 ?m _ _ |- _ ] => + learn (H1 _ _ H2) + end; crush). +Qed. + Lemma semantics_determinate : forall (p: program), Smallstep.determinate (semantics p). Proof. intros. constructor; set (ge := Globalenvs.Genv.globalenv p); simplify. - invert H; invert H0; constructor. (* Traces are always empty *) - - invert H; invert H0; crush. - assert (f = f0) by (destruct f; destruct f0; auto); subst. - pose proof (mis_stepp_determinate H5 H15). + - invert H; invert H0; crush. assert (f = f0) by (destruct f; destruct f0; auto); subst. + pose proof (mis_stepp_determinate H5 H15). simplify. inv H0. inv H4. + pose proof (mis_stepp_negedge_determinate H6 H17). crush. - constructor. invert H; crush. - invert H; invert H0; unfold ge0, ge1 in *; crush. - red; simplify; intro; invert H0; invert H; crush. - invert H; invert H0; crush. Qed. + +Local Open Scope positive. + +Fixpoint max_reg_expr (e: expr) := + match e with + | Vlit _ => 1 + | Vvar r => r + | Vvari r e => Pos.max r (max_reg_expr e) + | Vrange r e1 e2 => Pos.max r (Pos.max (max_reg_expr e1) (max_reg_expr e2)) + | Vinputvar r => r + | Vbinop _ e1 e2 => Pos.max (max_reg_expr e1) (max_reg_expr e2) + | Vunop _ e => max_reg_expr e + | Vternary e1 e2 e3 => Pos.max (max_reg_expr e1) (Pos.max (max_reg_expr e2) (max_reg_expr e3)) + end. + +Fixpoint max_reg_stmnt (st: stmnt) := + match st with + | Vskip => 1 + | Vseq s1 s2 => Pos.max (max_reg_stmnt s1) (max_reg_stmnt s2) + | Vcond e s1 s2 => + Pos.max (max_reg_expr e) + (Pos.max (max_reg_stmnt s1) (max_reg_stmnt s2)) + | Vcase e stl None => Pos.max (max_reg_expr e) (max_reg_stmnt_expr_list stl) + | Vcase e stl (Some s) => + Pos.max (max_reg_stmnt s) + (Pos.max (max_reg_expr e) (max_reg_stmnt_expr_list stl)) + | Vblock e1 e2 => Pos.max (max_reg_expr e1) (max_reg_expr e2) + | Vnonblock e1 e2 => Pos.max (max_reg_expr e1) (max_reg_expr e2) + end +with max_reg_stmnt_expr_list (stl: stmnt_expr_list) := + match stl with + | Stmntnil => 1 + | Stmntcons e s stl' => + Pos.max (max_reg_expr e) + (Pos.max (max_reg_stmnt s) + (max_reg_stmnt_expr_list stl')) + end. diff --git a/src/hls/Veriloggen.v b/src/hls/Veriloggen.v index 6ea00e0..035e7a4 100644 --- a/src/hls/Veriloggen.v +++ b/src/hls/Veriloggen.v @@ -25,6 +25,7 @@ Require Import vericert.hls.AssocMap. Require Import vericert.hls.HTL. Require Import vericert.hls.ValueInt. Require Import vericert.hls.Verilog. +Require Import vericert.hls.FunctionalUnits. Definition transl_list_fun (a : node * Verilog.stmnt) := let (n, stmnt) := a in @@ -42,28 +43,61 @@ Definition arr_to_Vdeclarr_fun (a : reg * (option io * arr_decl)) := Definition arr_to_Vdeclarr arrdecl := map arr_to_Vdeclarr_fun arrdecl. +Definition inst_ram clk ram := + Valways (Vnegedge clk) + (Vcond (Vbinop Vne (Vvar (ram_u_en ram)) (Vvar (ram_en ram))) + (Vseq (Vcond (Vvar (ram_wr_en ram)) + (Vnonblock (Vvari (ram_mem ram) (Vvar (ram_addr ram))) + (Vvar (ram_d_in ram))) + (Vnonblock (Vvar (ram_d_out ram)) + (Vvari (ram_mem ram) (Vvar (ram_addr ram))))) + (Vnonblock (Vvar (ram_en ram)) (Vvar (ram_u_en ram)))) + Vskip). + Definition transl_module (m : HTL.module) : Verilog.module := - let case_el_ctrl := transl_list (PTree.elements m.(mod_controllogic)) in - let case_el_data := transl_list (PTree.elements m.(mod_datapath)) in - let body := - Valways (Vposedge m.(HTL.mod_clk)) (Vcond (Vbinop Veq (Vvar m.(HTL.mod_reset)) (Vlit (ZToValue 1))) - (Vnonblock (Vvar m.(HTL.mod_st)) (Vlit (posToValue m.(HTL.mod_entrypoint)))) - (Vcase (Vvar m.(HTL.mod_st)) case_el_ctrl (Some Vskip))) - :: Valways (Vposedge m.(HTL.mod_clk)) (Vcase (Vvar m.(HTL.mod_st)) case_el_data (Some Vskip)) - :: List.map Vdeclaration (arr_to_Vdeclarr (AssocMap.elements m.(mod_arrdecls)) - ++ scl_to_Vdecl (AssocMap.elements m.(mod_scldecls))) in - Verilog.mkmodule m.(HTL.mod_start) - m.(HTL.mod_reset) - m.(HTL.mod_clk) - m.(HTL.mod_finish) - m.(HTL.mod_return) - m.(HTL.mod_st) - m.(HTL.mod_stk) - m.(HTL.mod_stk_len) - m.(HTL.mod_params) - m.(HTL.mod_funct_units) - body - m.(HTL.mod_entrypoint). + let case_el_ctrl := list_to_stmnt (transl_list (PTree.elements m.(mod_controllogic))) in + let case_el_data := list_to_stmnt (transl_list (PTree.elements m.(mod_datapath))) in + match m.(HTL.mod_ram) with + | Some ram => + let body := + Valways (Vposedge m.(HTL.mod_clk)) (Vcond (Vbinop Veq (Vvar m.(HTL.mod_reset)) (Vlit (ZToValue 1))) + (Vnonblock (Vvar m.(HTL.mod_st)) (Vlit (posToValue m.(HTL.mod_entrypoint)))) + (Vcase (Vvar m.(HTL.mod_st)) case_el_ctrl (Some Vskip))) + :: Valways (Vposedge m.(HTL.mod_clk)) (Vcase (Vvar m.(HTL.mod_st)) case_el_data (Some Vskip)) + :: inst_ram m.(HTL.mod_clk) ram + :: List.map Vdeclaration (arr_to_Vdeclarr (AssocMap.elements m.(mod_arrdecls)) + ++ scl_to_Vdecl (AssocMap.elements m.(mod_scldecls))) in + Verilog.mkmodule m.(HTL.mod_start) + m.(HTL.mod_reset) + m.(HTL.mod_clk) + m.(HTL.mod_finish) + m.(HTL.mod_return) + m.(HTL.mod_st) + m.(HTL.mod_stk) + m.(HTL.mod_stk_len) + m.(HTL.mod_params) + body + m.(HTL.mod_entrypoint) + | None => + let body := + Valways (Vposedge m.(HTL.mod_clk)) (Vcond (Vbinop Veq (Vvar m.(HTL.mod_reset)) (Vlit (ZToValue 1))) + (Vnonblock (Vvar m.(HTL.mod_st)) (Vlit (posToValue m.(HTL.mod_entrypoint)))) + (Vcase (Vvar m.(HTL.mod_st)) case_el_ctrl (Some Vskip))) + :: Valways (Vposedge m.(HTL.mod_clk)) (Vcase (Vvar m.(HTL.mod_st)) case_el_data (Some Vskip)) + :: List.map Vdeclaration (arr_to_Vdeclarr (AssocMap.elements m.(mod_arrdecls)) + ++ scl_to_Vdecl (AssocMap.elements m.(mod_scldecls))) in + Verilog.mkmodule m.(HTL.mod_start) + m.(HTL.mod_reset) + m.(HTL.mod_clk) + m.(HTL.mod_finish) + m.(HTL.mod_return) + m.(HTL.mod_st) + m.(HTL.mod_stk) + m.(HTL.mod_stk_len) + m.(HTL.mod_params) + body + m.(HTL.mod_entrypoint) + end. Definition transl_fundef := transf_fundef transl_module. diff --git a/src/hls/Veriloggenproof.v b/src/hls/Veriloggenproof.v index 9abbd4b..d1494ec 100644 --- a/src/hls/Veriloggenproof.v +++ b/src/hls/Veriloggenproof.v @@ -115,7 +115,7 @@ Lemma Zle_relax : p < q <= r -> p <= q <= r. Proof. lia. Qed. -Hint Resolve Zle_relax : verilogproof. +#[local] Hint Resolve Zle_relax : verilogproof. Lemma transl_in : forall l p, @@ -178,7 +178,7 @@ Lemma transl_list_correct : stmnt_runp f {| assoc_blocking := asr; assoc_nonblocking := asrn |} {| assoc_blocking := asa; assoc_nonblocking := asan |} - (Vcase (Vvar ev) (transl_list l) (Some Vskip)) + (Vcase (Vvar ev) (list_to_stmnt (transl_list l)) (Some Vskip)) {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} {| assoc_blocking := asa'; assoc_nonblocking := asan' |}). Proof. @@ -202,7 +202,7 @@ Proof. eapply IHl. auto. inv NOREP. auto. eassumption. inv IN. inv H. contradiction. apply H. trivial. assumption. Qed. -Hint Resolve transl_list_correct : verilogproof. +#[local] Hint Resolve transl_list_correct : verilogproof. Lemma pc_wf : forall A m p v, @@ -223,7 +223,117 @@ Proof. - intros. constructor. - intros. simplify. econstructor. constructor. auto. Qed. -Hint Resolve mis_stepp_decl : verilogproof. +#[local] Hint Resolve mis_stepp_decl : verilogproof. + +Lemma mis_stepp_negedge_decl : + forall l asr asa f, + mis_stepp_negedge f asr asa (map Vdeclaration l) asr asa. +Proof. + induction l. + - intros. constructor. + - intros. simplify. econstructor. constructor. auto. +Qed. +#[local] Hint Resolve mis_stepp_negedge_decl : verilogproof. + +Lemma mod_entrypoint_equiv m : mod_entrypoint (transl_module m) = HTL.mod_entrypoint m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_st_equiv m : mod_st (transl_module m) = HTL.mod_st m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_stk_equiv m : mod_stk (transl_module m) = HTL.mod_stk m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_stk_len_equiv m : mod_stk_len (transl_module m) = HTL.mod_stk_len m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_finish_equiv m : mod_finish (transl_module m) = HTL.mod_finish m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_reset_equiv m : mod_reset (transl_module m) = HTL.mod_reset m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_clk_equiv m : mod_clk (transl_module m) = HTL.mod_clk m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_return_equiv m : mod_return (transl_module m) = HTL.mod_return m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_params_equiv m : mod_args (transl_module m) = HTL.mod_params m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma empty_stack_equiv m : empty_stack (transl_module m) = HTL.empty_stack m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Ltac rewrite_eq := rewrite mod_return_equiv + || rewrite mod_clk_equiv + || rewrite mod_reset_equiv + || rewrite mod_finish_equiv + || rewrite mod_stk_len_equiv + || rewrite mod_stk_equiv + || rewrite mod_st_equiv + || rewrite mod_entrypoint_equiv + || rewrite mod_params_equiv + || rewrite empty_stack_equiv. + +Lemma find_assocmap_get r i v : r ! i = Some v -> r # i = v. +Proof. + intros. unfold find_assocmap, AssocMapExt.get_default. rewrite H. auto. +Qed. + +Lemma ram_exec_match : + forall f asr asa asr' asa' r clk, + HTL.exec_ram asr asa (Some r) asr' asa' -> + mi_stepp_negedge f asr asa (inst_ram clk r) asr' asa'. +Proof. + inversion 1; subst; simplify. + { unfold inst_ram. econstructor. + eapply stmnt_runp_Vcond_false. + econstructor. econstructor. econstructor. auto. + econstructor. auto. + simplify. + unfold boolToValue, natToValue, valueToBool. + rewrite Int.eq_sym. rewrite H3. simplify. + auto. constructor. } + { unfold inst_ram. econstructor. econstructor. econstructor. + econstructor. econstructor. auto. + econstructor. auto. + simplify. + unfold boolToValue, natToValue, valueToBool. + pose proof H4 as X. apply find_assocmap_get in X. + rewrite X. rewrite Int.eq_sym. rewrite H1. auto. + econstructor. econstructor. econstructor. econstructor. + pose proof H5 as X. apply find_assocmap_get in X. + rewrite X. + unfold valueToBool. unfold ZToValue in *. + unfold Int.eq in H2. + unfold uvalueToZ. + assert (Int.unsigned wr_en =? 0 = false). + apply Z.eqb_neq. rewrite Int.unsigned_repr in H2 by (simplify; lia). + destruct (zeq (Int.unsigned wr_en) 0); crush. + rewrite H0. auto. + apply stmnt_runp_Vnonblock_arr. econstructor. econstructor. auto. + econstructor. econstructor. + apply find_assocmap_get in H9. rewrite H9. + apply find_assocmap_get in H6. rewrite H6. + repeat econstructor. apply find_assocmap_get; auto. + } + { econstructor. econstructor. econstructor. econstructor. auto. + econstructor. auto. + econstructor. + unfold boolToValue, natToValue, valueToBool. + apply find_assocmap_get in H3. rewrite H3. + rewrite Int.eq_sym. rewrite H1. auto. + econstructor. + eapply stmnt_runp_Vcond_false. econstructor. auto. + simplify. apply find_assocmap_get in H4. rewrite H4. + auto. + repeat (econstructor; auto). apply find_assocmap_get in H5. + rewrite H5. eassumption. + repeat econstructor. simplify. apply find_assocmap_get; auto. + } +Qed. + Section CORRECTNESS. @@ -238,7 +348,7 @@ Section CORRECTNESS. Lemma symbols_preserved: forall (s: AST.ident), Genv.find_symbol tge s = Genv.find_symbol ge s. Proof. intros. eapply (Genv.find_symbol_match TRANSL). Qed. - Hint Resolve symbols_preserved : verilogproof. + #[local] Hint Resolve symbols_preserved : verilogproof. Lemma function_ptr_translated: forall (b: Values.block) (f: HTL.fundef), @@ -249,7 +359,7 @@ Section CORRECTNESS. intros. exploit (Genv.find_funct_ptr_match TRANSL); eauto. intros (cu & tf & P & Q & R); exists tf; auto. Qed. - Hint Resolve function_ptr_translated : verilogproof. + #[local] Hint Resolve function_ptr_translated : verilogproof. Lemma functions_translated: forall (v: Values.val) (f: HTL.fundef), @@ -260,14 +370,20 @@ Section CORRECTNESS. intros. exploit (Genv.find_funct_match TRANSL); eauto. intros (cu & tf & P & Q & R); exists tf; auto. Qed. - Hint Resolve functions_translated : verilogproof. + #[local] Hint Resolve functions_translated : verilogproof. Lemma senv_preserved: Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). Proof. intros. eapply (Genv.senv_match TRANSL). Qed. - Hint Resolve senv_preserved : verilogproof. + #[local] Hint Resolve senv_preserved : verilogproof. + + Ltac unfold_replace := + match goal with + | H: HTL.mod_ram _ = _ |- context[transl_module] => + unfold transl_module; rewrite H + end. Theorem transl_step_correct : forall (S1 : HTL.state) t S2, @@ -276,12 +392,14 @@ Section CORRECTNESS. match_states S1 R1 -> exists R2, Smallstep.plus step tge R1 t R2 /\ match_states S2 R2. Proof. - induction 1; intros R1 MSTATE; inv MSTATE. + induction 1; intros R1 MSTATE; inv MSTATE; destruct (HTL.mod_ram m) eqn:?. - econstructor; split. apply Smallstep.plus_one. econstructor. - assumption. assumption. eassumption. apply valueToPos_posToValue. + unfold_replace. assumption. unfold_replace. assumption. + unfold_replace. eassumption. apply valueToPos_posToValue. split. lia. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. split. lia. apply HP. eassumption. eassumption. + unfold_replace. econstructor. econstructor. eapply stmnt_runp_Vcond_false. econstructor. econstructor. simpl. unfold find_assocmap. unfold AssocMapExt.get_default. rewrite H. trivial. @@ -303,7 +421,40 @@ Section CORRECTNESS. econstructor. econstructor. eapply transl_list_correct. - intros. split. lia. pose proof (HTL.mod_wf m) as HP. destruct HP as [_ HP]. auto. + intros. split. lia. pose proof (HTL.mod_wf m) as HP. destruct HP as [_ HP]. + auto. apply Maps.PTree.elements_keys_norepet. eassumption. + 2: { apply valueToPos_inj. apply unsigned_posToValue_le. + eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. + apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. + destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. trivial. + } + apply Maps.PTree.elements_correct. eassumption. eassumption. + econstructor. econstructor. + apply mis_stepp_decl. simplify. unfold_replace. simplify. + econstructor. econstructor. econstructor. econstructor. + econstructor. + apply ram_exec_match. eauto. + apply mis_stepp_negedge_decl. simplify. auto. auto. + rewrite_eq. eauto. auto. + rewrite valueToPos_posToValue. econstructor. auto. + simplify; lia. + - inv H7. econstructor; split. apply Smallstep.plus_one. econstructor. + unfold_replace. assumption. unfold_replace. assumption. + unfold_replace. eassumption. apply valueToPos_posToValue. + split. lia. + eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. + unfold_replace. + econstructor. econstructor. eapply stmnt_runp_Vcond_false. econstructor. econstructor. + simpl. unfold find_assocmap. unfold AssocMapExt.get_default. + rewrite H. trivial. + + econstructor. simpl. auto. auto. + + eapply transl_list_correct. + intros. split. lia. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. auto. apply Maps.PTree.elements_keys_norepet. eassumption. 2: { apply valueToPos_inj. apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. @@ -314,19 +465,44 @@ Section CORRECTNESS. } apply Maps.PTree.elements_correct. eassumption. eassumption. - apply mis_stepp_decl. trivial. trivial. simpl. eassumption. auto. - rewrite valueToPos_posToValue. constructor; assumption. lia. + econstructor. econstructor. - - econstructor; split. apply Smallstep.plus_one. apply step_finish. assumption. eassumption. + eapply transl_list_correct. + intros. split. lia. pose proof (HTL.mod_wf m) as HP. + destruct HP as [_ HP]; auto. + apply Maps.PTree.elements_keys_norepet. eassumption. + 2: { apply valueToPos_inj. apply unsigned_posToValue_le. + eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. + apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. + destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. trivial. + } + apply Maps.PTree.elements_correct. eassumption. eassumption. + + apply mis_stepp_decl. simplify. + unfold_replace. + repeat econstructor. apply mis_stepp_negedge_decl. trivial. trivial. + simpl. unfold_replace. eassumption. auto. simplify. + rewrite valueToPos_posToValue. constructor; eassumption. simplify; lia. + - econstructor; split. apply Smallstep.plus_one. apply step_finish. + rewrite_eq. assumption. + rewrite_eq. eassumption. + econstructor; auto. + - econstructor; split. apply Smallstep.plus_one. apply step_finish. + unfold transl_module. rewrite Heqo. simplify. + assumption. unfold_replace. eassumption. constructor; assumption. - econstructor; split. apply Smallstep.plus_one. constructor. - - constructor. constructor. + repeat rewrite_eq. constructor. constructor. + - econstructor; split. apply Smallstep.plus_one. constructor. + repeat rewrite_eq. constructor. constructor. - inv H3. econstructor; split. apply Smallstep.plus_one. constructor. trivial. - - apply match_state. assumption. + repeat rewrite_eq. apply match_state. assumption. + - inv H3. econstructor; split. apply Smallstep.plus_one. constructor. trivial. + repeat rewrite_eq. apply match_state. assumption. Qed. - Hint Resolve transl_step_correct : verilogproof. + #[local] Hint Resolve transl_step_correct : verilogproof. Lemma transl_initial_states : forall s1 : Smallstep.state (HTL.semantics prog), @@ -344,7 +520,7 @@ Section CORRECTNESS. inv B. eauto. constructor. Qed. - Hint Resolve transl_initial_states : verilogproof. + #[local] Hint Resolve transl_initial_states : verilogproof. Lemma transl_final_states : forall (s1 : Smallstep.state (HTL.semantics prog)) @@ -356,7 +532,7 @@ Section CORRECTNESS. Proof. intros. inv H0. inv H. inv H3. constructor. reflexivity. Qed. - Hint Resolve transl_final_states : verilogproof. + #[local] Hint Resolve transl_final_states : verilogproof. Theorem transf_program_correct: forward_simulation (HTL.semantics prog) (Verilog.semantics tprog). diff --git a/test/Makefile b/test/Makefile new file mode 100644 index 0000000..fa482c6 --- /dev/null +++ b/test/Makefile @@ -0,0 +1,34 @@ +CC ?= gcc +VERICERT ?= vericert +VERICERT_OPTS ?= -fschedule -fif-conv +IVERILOG ?= iverilog +IVERILOG_OPTS ?= + +TESTS := $(patsubst %.c,%.check,$(wildcard *.c)) + +all: $(TESTS) + +%.gcc.out: %.gcc + @./$< ; echo "$$?" >$@ + +%.o: %.c + @$(CC) $(CFLAGS) -c -o $@ $< + +%.gcc: %.o + @$(CC) $(CFLAGS) -o $@ $< + +%.v: %.c + @$(VERICERT) $(VERICERT_OPTS) -o $@ $< + +%.iver: %.v + @$(IVERILOG) $(IVERILOG_OPTS) -o $@ -- $< + +%.veri.out: %.iver + @./$< | tail -n1 | sed -r -e 's/[^0-9]*([0-9]+)/\1/' >$@ + +%.check: %.gcc.out %.veri.out + @diff $^ >$@ + @printf "\033[0;36mOK\033[0m\t$(patsubst %.check,%,$@)\n" + +clean: + rm -f *.check *.gcc *.gcc.out *.o *.v *.iver *.veri.out diff --git a/test/array.c b/test/array.c index 680acdf..a50cda4 100644 --- a/test/array.c +++ b/test/array.c @@ -1,128 +1,9 @@ -/* durbin.c: this file is part of PolyBench/C */ +int main() { + int a[10] = {0}; -#ifndef SYNTHESIS -#include <stdio.h> -#endif - -unsigned int divider(unsigned int x, unsigned int y) -{ - unsigned int r0, q0, y0, y1; - - r0 = x; - q0 = 0; - y0 = y; - y1 = y; - do - { - y1 = 2 * y1; - } while (y1 <= x); - do - { - y1 = y1 / 2; - q0 = 2 * q0; - if (r0 >= y1) - { - r0 = r0 - y1; - q0 = q0 + 1; - } - } while ((int)y1 != (int)y0); - return q0; -} - -int sdivider(int N, int D) { - if (D < 0) { - if (N < 0) - return divider(-N, -D); - else - return -divider(N, -D); - } else { - if (N < 0) - return -divider(-N, D); - else - return divider(N, D); - } -} - -#define plus(i) i = i + ONE -/* Include polybench common header. */ -static -void init_array (int n, - int r[ 40 + 0]) -{ - int ONE = 1; - int i; - - for (i = 0; i < n; plus(i)) - { - r[i] = (n+ONE-i); + for (int i = 1; i < 10; i++) { + a[i] = a[i-1] + i; } -} - - - -static -int print_array(int n, - int y[ 40 + 0]) - -{ - int ONE = 1; - int i; - int res = 0; - - for (i = 0; i < n; plus(i)) { - res ^= y[i]; - } - -#ifndef SYNTHESIS - printf("finished: %u\n", res); -#endif - - return res; -} - -static -void kernel_durbin(int n, - int r[ 40 + 0], - int y[ 40 + 0]) -{ - int z[40]; - int alpha; - int beta; - int sum; - - int ONE = 1; - int i,k; - y[0] = -r[0]; - beta = 1; - alpha = -r[0]; - - for (k = 1; k < n; plus(k)) { - beta = (ONE-alpha*alpha)*beta; - sum = 0; - for (i=0; i<k; plus(i)) { - sum += r[k-i-ONE]*y[i]; - } - alpha = - sdivider(r[k] + sum, beta); - - for (i=0; i<k; plus(i)) { - z[i] = y[i] + alpha*y[k-i-ONE]; - } - for (i=0; i<k; plus(i)) { - y[i] = z[i]; - } - y[k] = alpha; - } -} - - -int main() -{ - int n = 40; - int r[40 + 0]; - int y[40 + 0]; - - init_array (n, r); - kernel_durbin (n, r, y); - return print_array(n, y); + return a[9]; } diff --git a/test/test_all.sh b/test/test_all.sh index 6b67d27..f2b045b 100755 --- a/test/test_all.sh +++ b/test/test_all.sh @@ -1,3 +1,5 @@ +#!/bin/bash + mytmpdir=$(mktemp -d 2>/dev/null || mktemp -d -t 'mytmpdir') echo "--------------------------------------------------" echo "Created working directory: $mytmpdir" @@ -21,6 +23,7 @@ test_command() { test_command iverilog test_command gcc +test_command vericert echo "--------------------------------------------------" @@ -30,13 +33,13 @@ for cfile in $test_dir/*.c; do gcc -o $outbase.gcc $cfile >/dev/null 2>&1 $outbase.gcc expected=$? - ./bin/vericert -fschedule -drtl -o $outbase.v $cfile >/dev/null 2>&1 + vericert -fschedule -drtl -o $outbase.v $cfile >/dev/null 2>&1 if [[ ! -f $outbase.v ]]; then echo "ERROR" continue fi iverilog -o $outbase.iverilog $outbase.v - actual=$($outbase.iverilog | sed -E -e 's/[^0-9]+([0-9]+)/\1/') + actual=$($outbase.iverilog | tail -n1 | sed -E -e 's/[^0-9]+([0-9]+)/\1/') if [[ $expected = $actual ]]; then echo "OK" else |