diff options
155 files changed, 6309 insertions, 4617 deletions
diff --git a/.github/workflows/macOS_build.yml b/.github/workflows/macOS_build.yml new file mode 100644 index 00000000..ebc97a63 --- /dev/null +++ b/.github/workflows/macOS_build.yml @@ -0,0 +1,16 @@ +name: CI macOS-latest + +on: [push] + +jobs: + build: + + runs-on: macOS-latest + + steps: + - uses: actions/checkout@v1 + - name: Build on macOS + run: | + brew install gpatch gmp z3 pkg-config + brew install opam + etc/ci_opam_build.sh diff --git a/.github/workflows/ubuntu_build.yml b/.github/workflows/ubuntu_build.yml new file mode 100644 index 00000000..bf517113 --- /dev/null +++ b/.github/workflows/ubuntu_build.yml @@ -0,0 +1,16 @@ +name: CI ubuntu-latest + +on: [push] + +jobs: + build: + + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v1 + - name: Build on ubuntu + run: | + sudo apt install build-essential libgmp-dev z3 + sudo apt install opam + etc/ci_opam_build.sh @@ -6,7 +6,6 @@ S src S src/contrib/** S src/gen_lib/** S src/lem_interp/** -S src/pprint/** S src/test/** B src/_build/** PKG num str unix uint zarith linksem lem omd linenoise base64 yojson diff --git a/BUILDING.md b/BUILDING.md new file mode 100644 index 00000000..8df08e0b --- /dev/null +++ b/BUILDING.md @@ -0,0 +1,137 @@ +Building Sail on Ubuntu and macOS +========================= + +This note lists the commands needed to get Sail and all dependencies +working and built from source on a new Ubuntu install or macOS. We +have recently (2018-02-17) tested these on Xubuntu 16.04 LTS in a +virtual machine and on macOS Sierra 10.12.6, so they should +work. Hopefully this will be useful as a reference. + +For most users, installing and building the dependencies using OPAM is +likely easier than building everything manually, see [INSTALL.md](INSTALL.md). + +Basics +------ + +First we need some basic packages if they're not already installed. + +For Ubuntu: +``` +sudo apt-get install build-essential git +``` + +For macOS: compilers and supporting utilities are called Xcode instead of build-essential. First, download Xcode from the Mac App Store, and then run the following in the terminal: +``` +xcode-select --install +``` +git can be installed using ```brew install git``` + +OCaml and sail expect some packages. m4 is for OPAM, libgmp-dev is for +zarith which most of our tools rely on. Sail uses Z3 as a constraint +solver. +``` +sudo apt-get install m4 libgmp-dev z3 +``` +For macOS: ```brew install m4 gmp z3``` + +OCaml and OPAM +-------------- + +Install OPAM. Either directly from [https://opam.ocaml.org] or from +the package manager - both should work, but we used the install script +from the website. ```opam init``` must be run after installing OPAM. + +Distributions often contain quite outdated OCaml packages, so we need to make sure that we use an up-to-date OCaml compiler with opam: +``` +opam switch 4.06.1 +``` +For opam versions >=2.0 the command syntax for opam switch is slightly different: +``` +opam switch create ocaml-base-compiler.4.06.1 +``` +After doing opam switch it is important to check that the ocaml tools in your $PATH point at the opam installed toolchain, rather than any installed by the distribution package manager. + +The `opam` file in the Sail repository specifies the required dependencies: +``` +depends: [ + "ocamlfind" + "ocamlbuild" + "zarith" + "menhir" + "linenoise" {>= "1.1.0"} + "ott" {>= "0.28"} + "lem" {>= "2018-12-14"} + "linksem" {>= "0.3"} + "omd" + "conf-gmp" + "conf-zlib" + "base64" {< "3.0.0"} + "yojson" + "pprint" +] +``` +each of which can be installed using `opam install`. The `opam pin` command can be used to select a specific version of a dependency. + +Ott +--- + +Before cloning the repositories you may need to set up ssh keys with +github or use https. Create a directory to install the various REMS +tools and cd into it. +``` +git clone git@github.com:ott-lang/ott.git +cd ott +make +cd .. +``` +Sail depends on ott, so add the ott executable (``` path-to-ott/bin```) in the $PATH. + + +Lem +--- + +If you are using OCaml 4.06, you'll need to run `opam install num` before building lem. + +``` +git clone git@github.com:rems-project/lem.git +cd lem +make +cd ocaml-lib +make install +cd ../.. +``` + +Linksem +------- + +Before installing linksem, we are required to set the LEMLIB environment variable and to put the lem executable in $PATH. LEMLIB should be the library directory within the checked-out lem directory (i.e. ```path-to-lem/library/```). Next, install linksem as + +``` +git clone git@github.com:rems-project/linksem.git +cd linksem +make && make install +``` + +Sail +---- + +Sail depends on lem and ott, so make sure lem and ott executables +exist in $PATH. +``` +git clone git@github.com:rems-project/sail.git +cd sail +make +``` +To build Sail with interactive support we need two more commands +``` +opam install linenoise +make isail +``` +To test Sail is installed correctly, execute the following from the +root directory of the sail repository. You may also need to set +$LEM_DIR to the root of the lem repository for the lem tests. Some of +the C backend tests will fail if valgrind isn't installed. +``` +export SAIL_DIR=$PWD +test/run_tests.sh +``` @@ -1,28 +1,24 @@ -These are instructions for installing Sail via opam, the ocaml package manager. -The most up-to-date version of this document can be found on the Sail wiki +# How to install Sail using opam -https://github.com/rems-project/sail/wiki/OPAMInstall +First, install opam (the OCaml package manager) if you haven't already. You can use your system's package +manager e.g. `sudo apt-get install opam` or follow the [instructions +from the opam website](https://opam.ocaml.org/doc/Install.html). +Depending on your system and how you installed opam you may get either +opam version 1 or 2. Opam 1 is no longer officially supported but our +packages should work with either. -To build everything from source, instructions can be found here: - -https://github.com/rems-project/sail/wiki/Building-from-Source - -# How to install Sail from opam - -Install opam if you haven't already: https://opam.ocaml.org/doc/Install.html - -Use opam to install a version of ocaml we know works for us: +Use `ocaml -version` to check your OCaml version. If you do not have OCaml 4.06.1 or newer then use `opam switch` to install it e.g.: ``` opam switch 4.06.1 ``` OR, if you are using opam >=2.0, the syntax of the switch command changed slightly: ``` -opam switch create ocaml-base-compiler.4.06.1 +opam switch create 4.06.1 ``` -Then set up the environment for the ocaml we just installed: +Then set up the environment for the OCaml we just installed (note that older versions of opam suggest backticks instead of `$(...)`, but it makes no difference): ``` -eval `opam config env` +eval $(opam config env) ``` Add our local opam repo: ``` @@ -32,11 +28,12 @@ Install system dependencies, on Ubuntu: ``` sudo apt-get install build-essential libgmp-dev z3 ``` -or homebrew: +or [MacOS homebrew](https://brew.sh/): ``` -brew install gmp z3 +xcode-select --install # if you haven't already +brew install gmp z3 pkg-config ``` -Install sail and its dependencies: +Finally, install sail and its dependencies: ``` opam install sail ``` @@ -45,7 +42,7 @@ If all goes well then you'll have sail in your path: which sail sail --help ``` -Some source files that sail uses are found in at ``opam config var sail:share`` (e.g. for ``$include <foo.sail>``) but sail should find those when it needs them. +Some source files that sail uses are found at ``opam config var sail:share`` (e.g. for ``$include <foo.sail>``) but sail should find those when it needs them. ### Installing development versions of Sail Released Sail packages lag behind the latest development in the repository. If you find you need a recently added feature or bug fix you can use opam pin to install the latest version of Sail from the repository. Assuming you have previously followed the above instructions (required to install dependencies): @@ -67,4 +64,4 @@ To remove the pin and revert to the latest released opam package type: opam pin remove sail ``` -Alternatively you could follow the instructions to [build Sail manually](https://github.com/rems-project/sail/wiki/Building-from-Source), optionally skipping the steps to install ott, lem and linksem if they were already installed via opam. +Alternatively you could follow the instructions to [build Sail manually](BUILDING.md), optionally skipping the steps to install ott, lem and linksem if they were already installed via opam. @@ -1,12 +1,8 @@ Sail Sail and the Sail architecture models here, comprising all files and -directories except the PPrint library, and ASL-derived Sail code in -the aarch64 directory, are subject to the BSD two-clause licence -below. - -The PPrint library, in src/pprint, is subject to the CeCILL-C free -software licence agreement therein. +directories except the ASL-derived Sail code in the aarch64 directory, +are subject to the BSD two-clause licence below. The ASL derived parts of the ARMv8.3 specification in aarch64/no_vector and aarch64/full are copyright ARM Ltd. @@ -1,6 +1,9 @@ The Sail ISA specification language =================================== + + + Overview ======== @@ -75,14 +78,13 @@ on Github. These and the RISC-V model are integrated with our [RMEM](http://www OPAM Installation ================= -See the following Sail [wiki -page](https://github.com/rems-project/sail/wiki/OPAMInstall) for how -to get pre-built binaries of Sail using OPAM. +See [INSTALL.md](INSTALL.md) for how +to install Sail using opam (recommended). Building ======== -See [INSTALL.md](INSTALL.md) for full details of how to build Sail from source +See [BUILDING.md](BUILDING.md) for full details of how to build Sail from source with all the required dependencies. Emacs Mode @@ -97,9 +99,7 @@ Licensing The Sail implementation, in src/, as well as its tests in test/ and other supporting files in lib/ and language/, is distributed under the -2-clause BSD licence in the headers of those files and in src/LICENCE, -with the exception of the library src/pprint, which is distributed -under the CeCILL-C free software licence in src/pprint/LICENSE. +2-clause BSD licence in the headers of those files and in src/LICENCE. The generated parts of the ASL-derived ARMv8.3 model in aarch64/ are copyright ARM Ltd. See https://github.com/meriac/archex, and the diff --git a/doc/Makefile b/doc/Makefile index 7afebdf2..315eaaaa 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -58,8 +58,8 @@ all: manual.pdf .PHONY: clean -code_riscv.tex: ${SAIL_RISCV}/model/prelude.sail ${SAIL_RISCV}/model/riscv_duopod.sail - sail -o code_riscv -latex -latex_full_valspecs ${SAIL_RISCV}/model/prelude.sail ${SAIL_RISCV}/model/riscv_duopod.sail +code_riscv.tex: ${SAIL_RISCV}/model/riscv_duopod.sail + sail -o code_riscv -latex -latex_full_valspecs $^ cp code_riscv/commands.tex code_riscv.tex code_myreplicatebits.tex: examples/my_replicate_bits.sail @@ -69,8 +69,12 @@ code_myreplicatebits.tex: examples/my_replicate_bits.sail grammar.tex: ../language/sail.ott ott -pp_grammar -tex_wrap false -tex_suppress_category I -tex_suppress_category D -tex_suppress_ntr terminals -tex_suppress_ntr formula -tex_suppress_ntr judgement -tex_suppress_ntr user_syntax -tex_suppress_ntr dec_comm -sort false -generate_aux_rules false -picky_multiple_parses true -i ../language/sail.ott -o grammar.tex +internals.tex: internals.md + pandoc $< -f markdown -t latex --listings -o $@ + sed -i.bak -f pandocfix.sed $@ + LATEXARG=manual.tex -manual.pdf: grammar.tex introduction.tex usage.tex types.tex code_riscv.tex riscv.tex manual.tex manual.bib tutorial.tex code_myreplicatebits.tex +manual.pdf: grammar.tex introduction.tex usage.tex types.tex code_riscv.tex riscv.tex manual.tex manual.bib tutorial.tex internals.tex code_myreplicatebits.tex pdflatex ${LATEXARG} bibtex manual pdflatex ${LATEXARG} @@ -83,6 +87,7 @@ clean: -rm manual.pdf -rm -rf code_riscv/ -rm -f code_riscv.tex + -rm -f internals.tex -rm -rf code_myreplicatebits/ -rm -f code_myreplicatebits.tex -rm -f *.aux diff --git a/doc/internals.md b/doc/internals.md index 6ba60fa6..6422f227 100644 --- a/doc/internals.md +++ b/doc/internals.md @@ -10,7 +10,7 @@ by [Lem](https://github.com/rems-project/lem), which allows the Sail OCaml source to seamlessly interoperate with parts written in Lem. Although we do not make much use of this, in principle it allows us to implement parts of Sail in Lem, which would enable them to be -verified in Isabelle or HOL. +verified in Isabelle or HOL4. The Sail AST looks something like: @@ -35,13 +35,13 @@ which attaches an annotation to each node in the AST, consisting of an arbitrary type that parameterises the AST, and a location identifying the position of the AST node in the source code: -``` +```OCaml type 'a annot = l * 'a ``` There are various types of locations: -``` +```OCaml type l = | Unknown | Unique of int * l @@ -184,7 +184,7 @@ which invokes the backend for each target, e.g. for OCaml: ``` There is also a `Sail.prover_regstate` function that allows the -register state to be Set up in a prover-agnostic way for each of the +register state to be set up in a prover-agnostic way for each of the theorem-prover targets. ## Type Checker diff --git a/doc/manual.tex b/doc/manual.tex index 38b14322..f3578784 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -105,6 +105,9 @@ \include{tutorial} +\lstset{language={},escapechar=\`} +\include{internals} + % Remove for now since incomplete %\include{types} diff --git a/doc/pandocfix.sed b/doc/pandocfix.sed new file mode 100644 index 00000000..1b6f2688 --- /dev/null +++ b/doc/pandocfix.sed @@ -0,0 +1,2 @@ +s/https:\/\/github.com\/rems-project\/sail\/blob\/sail2\/doc\/// +s/\\includegraphics/\\includegraphics[scale=0.35]/
\ No newline at end of file diff --git a/doc/riscv.tex b/doc/riscv.tex index ee0c07e1..ca2b9dfe 100644 --- a/doc/riscv.tex +++ b/doc/riscv.tex @@ -3,38 +3,35 @@ We introduce the basic features of Sail via a small example from our \riscv\ model that includes just two instructions: add immediate and -load double. - -We start with some basic type synonyms. We create a type \ll{xlen_t} -for bitvectors of length 64, then we define a type \ll{regno}, which -is a type synonym for the builtin type \ll{atom}. The type -\ll{atom('n)} is a number which is exactly equal to the type variable -\ll{atom('n)}. Type variables are syntactically marked with single -quotes, as in ML. A \emph{constraint} can be attached to this type -synonym---ensuring that it is only used where we can guarantee that -its value will be between 0 and 31. Sail supports a rich variety of -numeric types, including range types, which are statically checked. We -then define a synonym \ll{regbits} for \ll{bits(5)}. We don't want to -manually convert between \ll{regbits} and \ll{regno} all the time, so -we define a function that maps between them and declare it as a -\emph{cast}, which allows the type-checker to insert it where -needed. By default, we do not do any automatic casting (except between -basic numeric types when safe), but to allow idioms in ISA vendor -description documents we support flexible user defined casts. To ensure -that the constraint on the \ll{regno} type synonym is satisfied, we -return an existentially quantified type \ll{\{'n, 0 <= 'n < - 32. regno('n)\}}. - -\sailtype{xlen_t} -\sailtype{regno} +load double. We start by including two files from the main sail-riscv +development: + +\begin{lstlisting} +$include "prelude.sail" +$include "riscv_xlen64.sail" +\end{lstlisting} + +The prelude sets up basic definitions we will use, it can vary on a +per-architecture basis to account for stylistic differences in ISA +specifications. \texttt{riscv\_xlen64.sail} introduces some type +synonyms. It creates a integer type xlen, which is 64. Sail supports +definitions which are generic over both regular types, and integers +(think const generics in C++, but more expressive). We also create a +type \ll{xlenbits} for bitvectors of length \ll{xlen}. + +\sailtype{xlen} +\sailtype{xlen_bytes} +\sailtype{xlenbits} + +For the purpose of this example, we also introduce a type synonym for +bitvectors of length 5, which represent registers. + \sailtype{regbits} -\sailval{regbits_to_regno} -\sailfn{regbits_to_regno} We now set up some basic architectural state. First creating a -register of type \ll{xlen_t} for both the program counter \ll{PC}, and +register of type \ll{xlenbits} for both the program counter \ll{PC}, and the next program counter, \ll{nextPC}. We define the general purpose -registers as a vector of 32 \ll{xlen_t} bitvectors. The \ll{dec} +registers as a vector of 32 \ll{xlenbits} bitvectors. The \ll{dec} keyword isn't important in this example, but Sail supports two different numbering schemes for (bit)vectors \ll{inc}, for most significant bit is zero, and \ll{dec} for least significant bit is @@ -48,20 +45,18 @@ overloading, and has an expressive l-value language in assignments, with the aim of allowing pseudo-code like definitions. \begin{lstlisting} -register PC : xlen_t -register nextPC : xlen_t +register PC : xlenbits +register nextPC : xlenbits -register Xs : vector(32, dec, xlen_t) +register Xs : vector(32, dec, xlenbits) \end{lstlisting} \sailval{rX} -% TODO: Fix funcl commands -\sailfclrX -\sailfclMMMrX +\sailfn{rX} \sailval{wX} \sailfn{wX} -\sailoverloadIIX +\sailoverloadUUX We also give a function \ll{MEMr} for reading memory, this function just points at a builtin we have defined elsewhere. Note that @@ -83,8 +78,7 @@ desirable to group the relevant parts of these functions and datatypes together in one place, as they would usually be found in an architecture reference manual. To support this Sail supports \emph{scattered} definitions. First we give types for the execute and -decode functions, and declare them as scattered functions, as well as -the \ll{ast} union. +decode functions, as well as the \ll{ast} union. \sailtype{iop} @@ -92,10 +86,8 @@ the \ll{ast} union. scattered union ast val decode : bits(32) -> option(ast) effect pure -scattered function decode val execute : ast -> unit effect {rmem, rreg, wreg} -scattered function execute \end{lstlisting} Now we provide the clauses for the add-immediate \ll{ast} type, as @@ -111,8 +103,8 @@ its argument. union clause ast = ITYPE : (bits(12), regbits, regbits, iop) \end{lstlisting} -%\sailfndecodeSomeITYPE -%\sailfnexecuteITYPE +\sailfclITYPEdecode +\sailfclITYPEexecute \noindent Now we do the same thing for the load-double instruction: @@ -120,22 +112,11 @@ union clause ast = ITYPE : (bits(12), regbits, regbits, iop) union clause ast = LOAD : (bits(12), regbits, regbits) \end{lstlisting} -%\sailfndecodeSomeLOAD -%\sailfnexecuteLOAD - -Finally we define the fallthrough case for the decode function, and -end all our scattered definitions. Note that the clauses in a -scattered function will be matched in the order they appear in the -file. - -%\sailfndecodeNone - -\begin{lstlisting} -end ast -end decode -end execute -\end{lstlisting} +\sailfclLOADdecode +\sailfclLOADexecute -The actual code for this example, as well as our more complete -\riscv\ specification can be found on our github at +Finally we define the fallthrough case for the decode function. Note +that the clauses in a scattered function will be matched in the order +they appear in the file. The actual code for this example, as well as +our more complete \riscv\ specification can be found on our github at \anonymise{\url{https://github.com/rems-project/sail-riscv/blob/master/model/riscv_duopod.sail}}. diff --git a/doc/tutorial.tex b/doc/tutorial.tex index b9901fc9..c60edf69 100644 --- a/doc/tutorial.tex +++ b/doc/tutorial.tex @@ -58,7 +58,7 @@ check. This is another feature that must be used carefully, because too many implicit casts can quickly result in unreadable code. Sail does not make any distinction between expressions and statements, so since there is only a single line of code within the foreach block, we -can drop it and simply write: \mrbfn{my_replicate_bits_three} +can drop it and simply write: \mrbfn{my_replicate_bits_3} %\subsection{External Bindings} diff --git a/doc/usage.tex b/doc/usage.tex index a7532ddf..68ca76d6 100644 --- a/doc/usage.tex +++ b/doc/usage.tex @@ -87,7 +87,7 @@ To compile Sail into C, the \verb+-c+ option is used, like so: \begin{verbatim} sail -c FILES 1> out.c \end{verbatim} -The transated C is by default printed to stdout, but one can also use +The translated C is by default printed to stdout, but one can also use the \verb+-o+ option to output to a file, so \begin{verbatim} sail -c FILES -o out diff --git a/etc/ci_opam_build.sh b/etc/ci_opam_build.sh new file mode 100755 index 00000000..10af3e3c --- /dev/null +++ b/etc/ci_opam_build.sh @@ -0,0 +1,12 @@ +#!/bin/sh + +set -eu + +opam init -y --no-setup --compiler=4.06.1 --shell=sh + +eval `opam config env` + +opam repository -y add rems https://github.com/rems-project/opam-repository.git +opam pin -y add sail . +opam install -y -v sail +sail -v diff --git a/language/jib.ott b/language/jib.ott index 1345ba64..63c86126 100644 --- a/language/jib.ott +++ b/language/jib.ott @@ -26,6 +26,11 @@ metavar string ::= {{ ocaml string }} {{ lem string }} +metavar mstring ::= + {{ phantom }} + {{ ocaml string option }} + {{ lem maybe string }} + metavar bool ::= {{ phantom }} {{ ocaml bool }} @@ -54,6 +59,7 @@ name :: '' ::= | id nat :: :: name | have_exception nat :: :: have_exception | current_exception nat :: :: current_exception + | throw_location nat :: :: throw_location | return nat :: :: return op :: '' ::= @@ -62,7 +68,6 @@ op :: '' ::= | and :: :: band | hd :: :: list_hd | tl :: :: list_tl - | bit_to_bool :: :: bit_to_bool | eq :: :: eq | neq :: :: neq % Integer ops @@ -92,7 +97,6 @@ op :: '' ::= cval :: 'V_' ::= | name : ctyp :: :: id - | '&' name : ctyp :: :: ref | value : ctyp :: :: lit | struct { uid0 = cval0 , ... , uidn = cvaln } ctyp :: :: struct | cval != kind id ( ctyp0 , ... , ctypn ) ctyp :: :: ctor_kind @@ -152,6 +156,7 @@ ctyp :: 'CT_' ::= | variant id ( uid0 * ctyp0 , ... , uidn * ctypn ) :: :: variant % A vector type for non-bit vectors, and a (linked) list type. + | fvector ( nat , bool , ctyp ) :: :: fvector | vector ( bool , ctyp ) :: :: vector | list ( ctyp ) :: :: list @@ -240,7 +245,7 @@ cdef :: 'CDEF_' ::= instr0 ; ... ; instrm } :: :: let - | val id ( ctyp0 , ... , ctypn ) -> ctyp :: :: spec + | val id = mstring ( ctyp0 , ... , ctypn ) -> ctyp :: :: spec % If mid = Some id this indicates that the caller should allocate the % return type and passes a pointer to it as an extra argument id for diff --git a/language/sail.ott b/language/sail.ott index c0c8da49..9c47a4f1 100644 --- a/language/sail.ott +++ b/language/sail.ott @@ -229,7 +229,7 @@ typ :: 'Typ_' ::= | id :: :: id {{ com defined type }} | kid :: :: var {{ com type variable }} | ( typ1 , ... , typn ) -> typ2 effectkw effect :: :: fn {{ com Function (first-order only) }} - | typ1 <-> typ2 :: :: bidir {{ com Mapping }} + | typ1 <-> typ2 effectkw effect :: :: bidir {{ com Mapping }} | ( typ1 , .... , typn ) :: :: tup {{ com Tuple }} | id ( typ_arg1 , ... , typ_argn ) :: :: app {{ com type constructor application }} | ( typ ) :: S :: paren {{ ichlo [[typ]] }} diff --git a/lib/coq/Hoare.v b/lib/coq/Hoare.v index 400630af..f5d764b2 100644 --- a/lib/coq/Hoare.v +++ b/lib/coq/Hoare.v @@ -193,9 +193,9 @@ eapply PrePost_bindS. Qed. Lemma PrePost_and_boolSP (*[PrePost_compositeI]:*) Regs E PP QQ RR H - (l : monadS Regs {b : bool & Sail2_values.ArithFact (PP b)} E) - (r : monadS Regs {b : bool & Sail2_values.ArithFact (QQ b)} E) - P (Q : result {b : bool & Sail2_values.ArithFact (RR b)} E -> predS Regs) R : + (l : monadS Regs {b : bool & Sail2_values.ArithFactP (PP b)} E) + (r : monadS Regs {b : bool & Sail2_values.ArithFactP (QQ b)} E) + P (Q : result {b : bool & Sail2_values.ArithFactP (RR b)} E -> predS Regs) R : (forall p, PrePost R r (fun r => @@ -237,9 +237,9 @@ eapply PrePost_bindS. Qed. Lemma PrePost_or_boolSP (*[PrePost_compositeI]:*) Regs E PP QQ RR H - (l : monadS Regs {b : bool & Sail2_values.ArithFact (PP b)} E) - (r : monadS Regs {b : bool & Sail2_values.ArithFact (QQ b)} E) - P (Q : result {b : bool & Sail2_values.ArithFact (RR b)} E -> predS Regs) R : + (l : monadS Regs {b : bool & Sail2_values.ArithFactP (PP b)} E) + (r : monadS Regs {b : bool & Sail2_values.ArithFactP (QQ b)} E) + P (Q : result {b : bool & Sail2_values.ArithFactP (RR b)} E -> predS Regs) R : (forall p, PrePost R r (fun r => @@ -530,6 +530,16 @@ destruct b as [H | H]. * apply (HY H). reflexivity. Qed. +Lemma PrePostE_match_sum_branch (*[PrePostE_compositeI]:*) Regs A Ety X Y (b : sumbool X Y) (f : X -> monadS Regs A Ety) (g : Y -> monadS Regs A Ety) Pf Pg Q E : + (forall H : X, b = left H -> PrePostE (Pf H) (f H) Q E) -> + (forall H : Y, b = right H -> PrePostE (Pg H) (g H) Q E) -> + PrePostE (fun s => match b with left H => Pf H s | right H => Pg H s end) (match b with left H => f H | right H => g H end) Q E. +intros HX HY. +destruct b as [H | H]. +* apply (HX H). reflexivity. +* apply (HY H). reflexivity. +Qed. + Lemma PrePostE_if Regs A Ety (b : bool) (f g : monadS Regs A Ety) P Q E : (b = true -> PrePostE P f Q E) -> (b = false -> PrePostE P g Q E) -> @@ -598,9 +608,9 @@ Qed. and prevents the reduction of the function application. *) Lemma PrePostE_and_boolSP (*[PrePost_compositeI]:*) Regs Ety PP QQ RR H - (l : monadS Regs {b : bool & Sail2_values.ArithFact (PP b)} Ety) - (r : monadS Regs {b : bool & Sail2_values.ArithFact (QQ b)} Ety) - P (Q : {b : bool & Sail2_values.ArithFact (RR b)} -> predS Regs) E R : + (l : monadS Regs {b : bool & Sail2_values.ArithFactP (PP b)} Ety) + (r : monadS Regs {b : bool & Sail2_values.ArithFactP (QQ b)} Ety) + P (Q : {b : bool & Sail2_values.ArithFactP (RR b)} -> predS Regs) E R : PrePostE R r (fun r s => forall pf, Q (existT _ (projT1 r) pf) s) E -> PrePostE P l (fun r s => match r with @@ -635,9 +645,9 @@ eapply PrePostE_bindS. Qed. Lemma PrePostE_or_boolSP (*[PrePost_compositeI]:*) Regs Ety PP QQ RR H - (l : monadS Regs {b : bool & Sail2_values.ArithFact (PP b)} Ety) - (r : monadS Regs {b : bool & Sail2_values.ArithFact (QQ b)} Ety) - P (Q : {b : bool & Sail2_values.ArithFact (RR b)} -> predS Regs) E R : + (l : monadS Regs {b : bool & Sail2_values.ArithFactP (PP b)} Ety) + (r : monadS Regs {b : bool & Sail2_values.ArithFactP (QQ b)} Ety) + P (Q : {b : bool & Sail2_values.ArithFactP (RR b)} -> predS Regs) E R : PrePostE R r (fun r s => forall pf, Q (existT _ (projT1 r) pf) s) E -> PrePostE P l (fun r s => match r with @@ -764,6 +774,43 @@ apply PrePost_foreachS_invariant with (Q := fun v => match v with Value a => Q a auto. Qed. +Lemma PrePostE_foreach_ZS_up_invariant Regs Vars Ety from to step (H : Sail2_values.ArithFact (0 <? step)%Z) vars body (Q : Vars -> predS Regs) (E : ex Ety -> predS Regs) : + (forall i range vars, PrePostE (Q vars) (body i range vars) Q E) -> + PrePostE (Q vars) (foreach_ZS_up from to step vars body) Q E. +intro INV. +unfold foreach_ZS_up. +match goal with +| |- context[@foreach_ZS_up' _ _ _ _ _ _ _ _ _ ?pf _ _] => generalize pf +end. +generalize 0%Z at 2 3 as off. +revert vars. +induction (S (Z.abs_nat (from - to))); intros. +* simpl. destruct (Sumbool.sumbool_of_bool (from + off <=? to)%Z); apply PrePostE_returnS. +* simpl. destruct (Sumbool.sumbool_of_bool (from + off <=? to)%Z). + + eapply PrePostE_bindS. + - intro. apply IHn. + - apply INV. + + apply PrePostE_returnS. +Qed. + +Lemma PrePostE_foreach_ZS_down_invariant Regs Vars Ety from to step (H : Sail2_values.ArithFact (0 <? step)%Z) vars body (Q : Vars -> predS Regs) (E : ex Ety -> predS Regs) : + (forall i range vars, PrePostE (Q vars) (body i range vars) Q E) -> + PrePostE (Q vars) (foreach_ZS_down from to step vars body) Q E. +intro INV. +unfold foreach_ZS_down. +match goal with +| |- context[@foreach_ZS_down' _ _ _ _ _ _ _ _ _ ?pf _ _] => generalize pf +end. +generalize 0%Z at 1 3 as off. +revert vars. +induction (S (Z.abs_nat (from - to))); intros. +* simpl. destruct (Sumbool.sumbool_of_bool (to <=? from + off)%Z); apply PrePostE_returnS. +* simpl. destruct (Sumbool.sumbool_of_bool (to <=? from + off)%Z). + + eapply PrePostE_bindS. + - intro. apply IHn. + - apply INV. + + apply PrePostE_returnS. +Qed. Lemma PrePostE_use_pre Regs A Ety m (P : predS Regs) (Q : A -> predS Regs) (E : ex Ety -> predS Regs) : (forall s, P s -> PrePostE P m Q E) -> @@ -991,7 +1038,7 @@ Qed. Local Open Scope Z. -Lemma PrePostE_undefined_bitvectorS_any Regs Ety n `{Sail2_values.ArithFact (n >= 0)} (Q : Sail2_values.mword n -> predS Regs) (E : ex Ety -> predS Regs) : +Lemma PrePostE_undefined_bitvectorS_any Regs Ety n `{Sail2_values.ArithFact (n >=? 0)} (Q : Sail2_values.mword n -> predS Regs) (E : ex Ety -> predS Regs) : PrePostE (fun s => forall w, Q w s) (undefined_bitvectorS n) Q E. unfold undefined_bitvectorS. eapply PrePostE_strengthen_pre. @@ -1002,15 +1049,15 @@ simpl. auto. Qed. -Lemma PrePostE_undefined_bitvectorS_ignore Regs Ety n `{Sail2_values.ArithFact (n >= 0)} (Q : predS Regs) (E : ex Ety -> predS Regs) : +Lemma PrePostE_undefined_bitvectorS_ignore Regs Ety n `{Sail2_values.ArithFact (n >=? 0)} (Q : predS Regs) (E : ex Ety -> predS Regs) : PrePostE Q (undefined_bitvectorS n) (fun _ => Q) E. eapply PrePostE_strengthen_pre. apply PrePostE_undefined_bitvectorS_any; auto. simpl; auto. Qed. -Lemma PrePostE_build_trivial_exS Regs (T:Type) Ety (m : monadS Regs T Ety) P (Q : {T & Sail2_values.ArithFact True} -> predS Regs) E : - PrePostE P m (fun v => Q (existT _ v (Sail2_values.Build_ArithFact _ I))) E -> +Lemma PrePostE_build_trivial_exS Regs (T:Type) Ety (m : monadS Regs T Ety) P (Q : {T & Sail2_values.ArithFact true} -> predS Regs) E : + PrePostE P m (fun v => Q (existT _ v (Sail2_values.Build_ArithFactP _ eq_refl))) E -> PrePostE P (build_trivial_exS m) Q E. intro H. unfold build_trivial_exS. @@ -1064,7 +1111,6 @@ Create HintDb PrePostE_specs. Ltac PrePostE_step := match goal with - | |- _ => solve [ clear; eauto with nocore PrePostE_specs ] | |- PrePostE _ (bindS _ (fun _ => ?f)) _ _ => eapply PrePostE_bindS_ignore | |- PrePostE _ (bindS _ _) _ _ => eapply PrePostE_bindS; intros | |- PrePostE _ (seqS _ _) _ _ => eapply PrePostE_seqS; intros @@ -1077,9 +1123,12 @@ Ltac PrePostE_step := [ eapply PrePostE_if_branch; intros | eapply PrePostE_if_sum_branch; intros ] + | |- PrePostE _ (match _ with left _ => _ | right _ => _ end) _ _ => + eapply PrePostE_match_sum_branch; intros | |- PrePostE _ (readS _) ?ppeQ ?ppeE => apply PrePostE_readS with (Q := ppeQ) (E := ppeE) | |- PrePostE _ (assert_expS _ _) _ _ => apply PrePostE_assert_expS | |- PrePostE _ (assert_expS' _ _) _ _ => apply PrePostE_assert_expS' + | |- PrePostE _ (maybe_failS _ _) _ _ => apply PrePostE_maybe_failS | |- PrePostE _ (exitS _) _ ?E => apply (PrePostE_exitS _ _ _ _ _ E) | |- PrePostE _ (and_boolS _ _) _ _ => eapply PrePostE_and_boolS | |- PrePostE _ (or_boolS _ _) _ _ => eapply PrePostE_or_boolS @@ -1102,6 +1151,8 @@ Ltac PrePostE_step := | |- PrePostE _ (undefined_bitvectorS _) ?ppeQ ?ppeE => apply PrePostE_undefined_bitvectorS_any with (Q := ppeQ) (E := ppeE) | |- PrePostE _ (build_trivial_exS _) _ _ => eapply PrePostE_build_trivial_exS; intros + | |- PrePostE _ (liftRS _) ?ppeQ ?ppeE => + apply PrePostE_liftRS with (Q := ppeQ) (E := ppeE); intros | |- PrePostE _ (let '(_,_) := ?x in _) _ _ => is_var x; let PAIR := fresh "PAIR" in @@ -1114,4 +1165,19 @@ Ltac PrePostE_step := assert (PAIR : x = existT _ (projT1 x) (projT2 x)) by (destruct x; reflexivity); rewrite PAIR at - 1; clear PAIR + (* Applying specifications from the hintdb. For performance, + * don't use hypotheses from the context (if we need to and it's + not good enough, consider using a separate hintdb) + + * use auto rather than eauto - when eauto is applied to a goal + with an evar Coq falls back to trying all of the specs rather + than picking out one which matches (at least, with 8.9). + *) + | |- PrePostE ?pre _ _ _ => + clear; + solve [ tryif is_evar pre then auto with nocore PrePostE_specs + else (eapply PrePostE_strengthen_pre; + [ auto with nocore PrePostE_specs + | exact (fun s p => p) ]) + ] end. diff --git a/lib/coq/Makefile b/lib/coq/Makefile index fa453d90..d16191cb 100644 --- a/lib/coq/Makefile +++ b/lib/coq/Makefile @@ -1,7 +1,7 @@ BBV_DIR?=../../../bbv CORESRC=Sail2_prompt_monad.v Sail2_prompt.v Sail2_impl_base.v Sail2_instr_kinds.v Sail2_operators_bitlists.v Sail2_operators_mwords.v Sail2_operators.v Sail2_values.v Sail2_state_monad.v Sail2_state.v Sail2_state_lifting.v Sail2_string.v Sail2_real.v -PROOFSRC=Sail2_state_monad_lemmas.v Sail2_state_lemmas.v Hoare.v +PROOFSRC=Sail2_values_lemmas.v Sail2_state_monad_lemmas.v Sail2_state_lemmas.v Hoare.v SRC=$(CORESRC) $(PROOFSRC) COQ_LIBS = -R . Sail -R "$(BBV_DIR)/theories" bbv diff --git a/lib/coq/Sail2_operators_mwords.v b/lib/coq/Sail2_operators_mwords.v index 698ca51b..1f176ad9 100644 --- a/lib/coq/Sail2_operators_mwords.v +++ b/lib/coq/Sail2_operators_mwords.v @@ -8,6 +8,7 @@ Require Import Arith. Require Import ZArith. Require Import Omega. Require Import Eqdep_dec. +Open Scope Z. Fixpoint cast_positive (T : positive -> Type) (p q : positive) : T p -> p = q -> T q. refine ( @@ -43,11 +44,17 @@ destruct m. * simpl. rewrite cast_positive_refl. reflexivity. Qed. -Definition autocast {T : Z -> Type} {m n} (x : T m) `{H:ArithFact (m = n)} : T n := - cast_T x (use_ArithFact H). +Definition autocast {T : Z -> Type} {m n} (x : T m) `{H:ArithFact (m =? n)} : T n. +refine (cast_T x _). +apply Z.eqb_eq. +apply (use_ArithFact H). +Defined. -Definition autocast_m {rv e m n} (x : monad rv (mword m) e) `{H:ArithFact (m = n)} : monad rv (mword n) e := - x >>= fun x => returnm (cast_T x (use_ArithFact H)). +Definition autocast_m {rv e m n} (x : monad rv (mword m) e) `{H:ArithFact (m =? n)} : monad rv (mword n) e. +refine (x >>= fun x => returnm (cast_T x _)). +apply Z.eqb_eq. +apply (use_ArithFact H). +Defined. Definition cast_word {m n} (x : Word.word m) (eq : m = n) : Word.word n := DepEqNat.nat_cast _ eq x. @@ -94,9 +101,10 @@ Definition update_vec_inc {a} (w : mword a) i b : mword a := (*val update_vec_dec : forall 'a. Size 'a => mword 'a -> integer -> bitU -> mword 'a*) Definition update_vec_dec {a} (w : mword a) i b : mword a := opt_def w (update_mword_dec w i b). -Lemma subrange_lemma0 {n m o} `{ArithFact (0 <= o)} `{ArithFact (o <= m < n)} : (Z.to_nat o <= Z.to_nat m < Z.to_nat n)%nat. +Lemma subrange_lemma0 {n m o} `{ArithFact (0 <=? o)} `{ArithFact (o <=? m <? n)} : (Z.to_nat o <= Z.to_nat m < Z.to_nat n)%nat. intros. unwrap_ArithFacts. +unbool_comparisons. split. + apply Z2Nat.inj_le; omega. + apply Z2Nat.inj_lt; omega. @@ -107,9 +115,10 @@ Qed. Lemma subrange_lemma2 {n m o} : (o <= m < n -> m+1 = o+(m-o+1))%nat. omega. Qed. -Lemma subrange_lemma3 {m o} `{ArithFact (0 <= o)} `{ArithFact (o <= m)} : +Lemma subrange_lemma3 {m o} `{ArithFact (0 <=? o)} `{ArithFact (o <=? m)} : Z.of_nat (Z.to_nat m - Z.to_nat o + 1)%nat = m - o + 1. unwrap_ArithFacts. +unbool_comparisons. rewrite Nat2Z.inj_add. rewrite Nat2Z.inj_sub. repeat rewrite Z2Nat.id; try omega. @@ -117,7 +126,7 @@ reflexivity. apply Z2Nat.inj_le; omega. Qed. -Definition subrange_vec_dec {n} (v : mword n) m o `{ArithFact (0 <= o)} `{ArithFact (o <= m < n)} : mword (m - o + 1) := +Definition subrange_vec_dec {n} (v : mword n) m o `{ArithFact (0 <=? o)} `{ArithFact (o <=? m <? n)} : mword (m - o + 1) := let n := Z.to_nat n in let m := Z.to_nat m in let o := Z.to_nat o in @@ -127,10 +136,10 @@ Definition subrange_vec_dec {n} (v : mword n) m o `{ArithFact (0 <= o)} `{ArithF (cast_word (split1 (m+1) (n-(m+1)) (cast_word w (subrange_lemma1 prf))) (subrange_lemma2 prf))) subrange_lemma3. -Definition subrange_vec_inc {n} (v : mword n) m o `{ArithFact (0 <= m)} `{ArithFact (m <= o < n)} : mword (o - m + 1) := autocast (subrange_vec_dec v (n-1-m) (n-1-o)). +Definition subrange_vec_inc {n} (v : mword n) m o `{ArithFact (0 <=? m)} `{ArithFact (m <=? o <? n)} : mword (o - m + 1) := autocast (subrange_vec_dec v (n-1-m) (n-1-o)). (* TODO: get rid of bogus default *) -Parameter dummy_vector : forall {n} `{ArithFact (n >= 0)}, mword n. +Parameter dummy_vector : forall {n} `{ArithFact (n >=? 0)}, mword n. (*val update_subrange_vec_inc : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> integer -> mword 'b -> mword 'a*) Definition update_subrange_vec_inc_unchecked {a b} (v : mword a) i j (w : mword b) : mword a := @@ -141,10 +150,11 @@ Definition update_subrange_vec_dec_unchecked {a b} (v : mword a) i j (w : mword opt_def dummy_vector (of_bits (update_subrange_bv_dec v i j w)). Lemma update_subrange_vec_dec_pf {o m n} : -ArithFact (0 <= o) -> -ArithFact (o <= m < n) -> +ArithFact (0 <=? o) -> +ArithFact (o <=? m <? n) -> Z.of_nat (Z.to_nat o + (Z.to_nat (m - o + 1) + (Z.to_nat n - (Z.to_nat m + 1)))) = n. intros [H1] [H2]. +unbool_comparisons. rewrite <- subrange_lemma3. rewrite !Nat2Z.inj_add. rewrite !Nat2Z.inj_sub. @@ -155,7 +165,7 @@ apply Z2Nat.inj_lt; omega. apply Z2Nat.inj_le; omega. Qed. -Definition update_subrange_vec_dec {n} (v : mword n) m o `{ArithFact (0 <= o)} `{ArithFact (o <= m < n)} (w : mword (m - o + 1)) : mword n. +Definition update_subrange_vec_dec {n} (v : mword n) m o `{ArithFact (0 <=? o)} `{ArithFact (o <=? m <? n)} (w : mword (m - o + 1)) : mword n. refine ( let n := Z.to_nat n in let m := Z.to_nat m in @@ -173,7 +183,7 @@ refine ( cast_to_mword z (update_subrange_vec_dec_pf _ _)). Defined. -Definition update_subrange_vec_inc {n} (v : mword n) m o `{ArithFact (0 <= m)} `{ArithFact (m <= o < n)} (w : mword (o - m + 1)) : mword n := update_subrange_vec_dec v (n-1-m) (n-1-o) (autocast w). +Definition update_subrange_vec_inc {n} (v : mword n) m o `{ArithFact (0 <=? m)} `{ArithFact (m <=? o <? n)} (w : mword (o - m + 1)) : mword n := update_subrange_vec_dec v (n-1-m) (n-1-o) (autocast w). Lemma mword_nonneg {a} : mword a -> a >= 0. destruct a; @@ -182,9 +192,10 @@ destruct 1. Qed. (*val extz_vec : forall 'a 'b. Size 'a, Size 'b => integer -> mword 'a -> mword 'b*) -Definition extz_vec {a b} `{ArithFact (b >= a)} (n : Z) (v : mword a) : mword b. +Definition extz_vec {a b} `{ArithFact (b >=? a)} (n : Z) (v : mword a) : mword b. refine (cast_to_mword (Word.zext (get_word v) (Z.to_nat (b - a))) _). unwrap_ArithFacts. +unbool_comparisons. assert (a >= 0). { apply mword_nonneg. assumption. } rewrite <- Z2Nat.inj_add; try omega. rewrite Zplus_minus. @@ -193,9 +204,10 @@ auto with zarith. Defined. (*val exts_vec : forall 'a 'b. Size 'a, Size 'b => integer -> mword 'a -> mword 'b*) -Definition exts_vec {a b} `{ArithFact (b >= a)} (n : Z) (v : mword a) : mword b. +Definition exts_vec {a b} `{ArithFact (b >=? a)} (n : Z) (v : mword a) : mword b. refine (cast_to_mword (Word.sext (get_word v) (Z.to_nat (b - a))) _). unwrap_ArithFacts. +unbool_comparisons. assert (a >= 0). { apply mword_nonneg. assumption. } rewrite <- Z2Nat.inj_add; try omega. rewrite Zplus_minus. @@ -203,13 +215,14 @@ apply Z2Nat.id. auto with zarith. Defined. -Definition zero_extend {a} (v : mword a) (n : Z) `{ArithFact (n >= a)} : mword n := extz_vec n v. +Definition zero_extend {a} (v : mword a) (n : Z) `{ArithFact (n >=? a)} : mword n := extz_vec n v. -Definition sign_extend {a} (v : mword a) (n : Z) `{ArithFact (n >= a)} : mword n := exts_vec n v. +Definition sign_extend {a} (v : mword a) (n : Z) `{ArithFact (n >=? a)} : mword n := exts_vec n v. -Definition zeros (n : Z) `{ArithFact (n >= 0)} : mword n. +Definition zeros (n : Z) `{ArithFact (n >=? 0)} : mword n. refine (cast_to_mword (Word.wzero (Z.to_nat n)) _). unwrap_ArithFacts. +unbool_comparisons. apply Z2Nat.id. auto with zarith. Defined. @@ -227,11 +240,17 @@ assert ((Z.to_nat m <= Z.to_nat n)%nat). omega. Qed. -Definition vector_truncate {n} (v : mword n) (m : Z) `{ArithFact (m >= 0)} `{ArithFact (m <= n)} : mword m := - cast_to_mword (Word.split1 _ _ (cast_word (get_word v) (ltac:(unwrap_ArithFacts; apply truncate_eq; auto) : Z.to_nat n = Z.to_nat m + (Z.to_nat n - Z.to_nat m))%nat)) (ltac:(unwrap_ArithFacts; apply Z2Nat.id; omega) : Z.of_nat (Z.to_nat m) = m). +Definition vector_truncate {n} (v : mword n) (m : Z) `{ArithFact (m >=? 0)} `{ArithFact (m <=? n)} : mword m. +refine (cast_to_mword (Word.split1 _ _ (cast_word (get_word v) (_ : Z.to_nat n = Z.to_nat m + (Z.to_nat n - Z.to_nat m))%nat)) (_ : Z.of_nat (Z.to_nat m) = m)). +abstract (unwrap_ArithFacts; unbool_comparisons; apply truncate_eq; auto with zarith). +abstract (unwrap_ArithFacts; unbool_comparisons; apply Z2Nat.id; omega). +Defined. -Definition vector_truncateLSB {n} (v : mword n) (m : Z) `{ArithFact (m >= 0)} `{ArithFact (m <= n)} : mword m := - cast_to_mword (Word.split2 _ _ (cast_word (get_word v) (ltac:(unwrap_ArithFacts; apply truncateLSB_eq; auto) : Z.to_nat n = (Z.to_nat n - Z.to_nat m) + Z.to_nat m)%nat)) (ltac:(unwrap_ArithFacts; apply Z2Nat.id; omega) : Z.of_nat (Z.to_nat m) = m). +Definition vector_truncateLSB {n} (v : mword n) (m : Z) `{ArithFact (m >=? 0)} `{ArithFact (m <=? n)} : mword m. +refine (cast_to_mword (Word.split2 _ _ (cast_word (get_word v) (_ : Z.to_nat n = (Z.to_nat n - Z.to_nat m) + Z.to_nat m)%nat)) (_ : Z.of_nat (Z.to_nat m) = m)). +abstract (unwrap_ArithFacts; unbool_comparisons; apply truncateLSB_eq; auto with zarith). +abstract (unwrap_ArithFacts; unbool_comparisons; apply Z2Nat.id; omega). +Defined. Lemma concat_eq {a b} : a >= 0 -> b >= 0 -> Z.of_nat (Z.to_nat b + Z.to_nat a)%nat = a + b. intros. @@ -270,13 +289,18 @@ induction n. reflexivity. Qed. -Program Definition uint {a} (x : mword a) : {z : Z & ArithFact (0 <= z /\ z <= 2 ^ a - 1)} := - existT _ (Z.of_N (Word.wordToN (get_word x))) _. +Definition uint_plain {a} (x : mword a) : Z := + Z.of_N (Word.wordToN (get_word x)). + +Program Definition uint {a} (x : mword a) : {z : Z & ArithFact (0 <=? z <=? 2 ^ a - 1)} := + existT _ (uint_plain x) _. Next Obligation. constructor. +apply Bool.andb_true_iff. constructor. -* apply N2Z.is_nonneg. -* assert (2 ^ a - 1 = Z.of_N (2 ^ (Z.to_N a) - 1)). { +* apply Z.leb_le. apply N2Z.is_nonneg. +* apply Z.leb_le. + assert (2 ^ a - 1 = Z.of_N (2 ^ (Z.to_N a) - 1)). { rewrite N2Z.inj_sub. * rewrite N2Z.inj_pow. rewrite Z2N.id; auto. @@ -303,12 +327,18 @@ induction n. rewrite Z.pow_succ_r; auto with zarith. Qed. -Program Definition sint {a} `{ArithFact (a > 0)} (x : mword a) : {z : Z & ArithFact (-(2^(a-1)) <= z /\ z <= 2 ^ (a-1) - 1)} := - existT _ (Word.wordToZ (get_word x)) _. +Definition sint_plain {a} (x : mword a) : Z := + Word.wordToZ (get_word x). + +Program Definition sint {a} `{ArithFact (a >? 0)} (x : mword a) : {z : Z & ArithFact (-(2^(a-1)) <=? z <=? 2 ^ (a-1) - 1)} := + existT _ (sint_plain x) _. Next Obligation. +unfold sint_plain. destruct H. +unbool_comparisons. destruct a; try inversion fact. constructor. +unbool_comparisons_goal. generalize (get_word x). rewrite <- positive_nat_Z. destruct (Pos2Nat.is_succ p) as [n eq]. @@ -326,10 +356,10 @@ rewrite <- Z.lt_le_pred. auto. Defined. -Definition sint0 {a} `{ArithFact (a >= 0)} (x : mword a) : Z := +Definition sint0 {a} `{ArithFact (a >=? 0)} (x : mword a) : Z := if sumbool_of_bool (Z.eqb a 0) then 0 else projT1 (sint x). -Lemma length_list_pos : forall {A} {l:list A}, length_list l >= 0. +Lemma length_list_pos : forall {A} {l:list A}, 0 <= Z.of_nat (List.length l). unfold length_list. auto with zarith. Qed. @@ -369,9 +399,9 @@ val smult_vec : forall 'a 'b. Size 'a, Size 'b => mword 'a -> mword 'a -> mword Definition add_vec {n} : mword n -> mword n -> mword n := word_binop Word.wplus. (*Definition sadd_vec {n} : mword n -> mword n -> mword n := sadd_bv w.*) Definition sub_vec {n} : mword n -> mword n -> mword n := word_binop Word.wminus. -Definition mult_vec {n m} `{ArithFact (m >= n)} (l : mword n) (r : mword n) : mword m := +Definition mult_vec {n m} `{ArithFact (m >=? n)} (l : mword n) (r : mword n) : mword m := word_binop Word.wmult (zero_extend l _) (zero_extend r _). -Definition mults_vec {n m} `{ArithFact (m >= n)} (l : mword n) (r : mword n) : mword m := +Definition mults_vec {n m} `{ArithFact (m >=? n)} (l : mword n) (r : mword n) : mword m := word_binop Word.wmult (sign_extend l _) (sign_extend r _). (*val add_vec_int : forall 'a. Size 'a => mword 'a -> integer -> mword 'a @@ -456,14 +486,14 @@ match n with | O => Word.WO | S m => Word.combine w (replicate_bits_aux w m) end. -Lemma replicate_ok {n a} `{ArithFact (n >= 0)} `{ArithFact (a >= 0)} : +Lemma replicate_ok {n a} `{ArithFact (n >=? 0)} `{ArithFact (a >=? 0)} : Z.of_nat (Z.to_nat n * Z.to_nat a) = a * n. -destruct H. destruct H0. +destruct H. destruct H0. unbool_comparisons. rewrite <- Z2Nat.id; auto with zarith. rewrite Z2Nat.inj_mul; auto with zarith. rewrite Nat.mul_comm. reflexivity. Qed. -Definition replicate_bits {a} (w : mword a) (n : Z) `{ArithFact (n >= 0)} : mword (a * n) := +Definition replicate_bits {a} (w : mword a) (n : Z) `{ArithFact (n >=? 0)} : mword (a * n) := cast_to_mword (replicate_bits_aux (get_word w) (Z.to_nat n)) replicate_ok. (*val duplicate : forall 'a. Size 'a => bitU -> integer -> mword 'a @@ -491,6 +521,28 @@ Definition ugteq_vec := ugteq_bv. Definition sgteq_vec := sgteq_bv. *) +Lemma eq_vec_true_iff {n} (v w : mword n) : + eq_vec v w = true <-> v = w. +unfold eq_vec. +destruct n. +* simpl in v,w. shatter_word v. shatter_word w. + compute. intuition. +* simpl in *. destruct (weq v w). + + subst. rewrite weqb_eq; tauto. + + rewrite weqb_ne; auto. intuition. +* destruct v. +Qed. + +Lemma eq_vec_false_iff {n} (v w : mword n) : + eq_vec v w = false <-> v <> w. +specialize (eq_vec_true_iff v w). +destruct (eq_vec v w). +intuition. +intros [H1 H2]. +split. +* intros _ EQ. intuition. +* auto. +Qed. Definition eq_vec_dec {n} : forall (x y : mword n), {x = y} + {x <> y}. refine (match n with @@ -520,7 +572,7 @@ Qed. Definition reverse_endianness {n} (bits : mword n) := with_word (P := id) reverse_endianness_word bits. -Definition get_slice_int {a} `{ArithFact (a >= 0)} : Z -> Z -> Z -> mword a := get_slice_int_bv. +Definition get_slice_int {a} `{ArithFact (a >=? 0)} : Z -> Z -> Z -> mword a := get_slice_int_bv. Definition set_slice n m (v : mword n) x (w : mword m) : mword n := update_subrange_vec_dec_unchecked v (x + m - 1) x w. @@ -535,7 +587,7 @@ Definition set_slice_int len n lo (v : mword len) : Z := else n. (* Variant of bitvector slicing for the ARM model with few constraints *) -Definition slice {m} (v : mword m) lo len `{ArithFact (0 <= len)} : mword len := +Definition slice {m} (v : mword m) lo len `{ArithFact (0 <=? len)} : mword len := if sumbool_of_bool (orb (len =? 0) (lo <? 0)) then zeros len else @@ -545,7 +597,6 @@ Definition slice {m} (v : mword m) lo len `{ArithFact (0 <= len)} : mword len := else zeros len else autocast (subrange_vec_dec v (lo + len - 1) lo). -(* Lemma slice_is_ok m (v : mword m) lo len (H1 : 0 <= lo) (H2 : 0 < len) (H3: lo + len < m) : slice v lo len = autocast (subrange_vec_dec v (lo + len - 1) lo). @@ -558,20 +609,20 @@ destruct (sumbool_of_bool _). + exfalso. unbool_comparisons. omega. - + f_equal. - f_equal. -*) + + repeat replace_ArithFact_proof. + reflexivity. +Qed. Import ListNotations. -Definition count_leading_zeros {N : Z} (x : mword N) `{ArithFact (N >= 1)} -: {n : Z & ArithFact (0 <= n /\ n <= N)} := - let r : {n : Z & ArithFact (0 <= n /\ n <= N)} := build_ex N in +Definition count_leading_zeros {N : Z} (x : mword N) `{ArithFact (N >=? 1)} +: {n : Z & ArithFact (0 <=? n <=? N)} := + let r : {n : Z & ArithFact (0 <=? n <=? N)} := build_ex N in foreach_Z_up 0 (N - 1) 1 r (fun i _ r => (if ((eq_vec (vec_of_bits [access_vec_dec x i] : mword 1) (vec_of_bits [B1] : mword 1))) then build_ex (Z.sub (Z.sub (length_mword x) i) 1) - : {n : Z & ArithFact (0 <= n /\ n <= N)} + : {n : Z & ArithFact (0 <=? n <=? N)} else r)) . diff --git a/lib/coq/Sail2_prompt.v b/lib/coq/Sail2_prompt.v index fbc0f5b1..aeca1248 100644 --- a/lib/coq/Sail2_prompt.v +++ b/lib/coq/Sail2_prompt.v @@ -30,7 +30,7 @@ match l with foreachM xs vars body end. -Fixpoint foreach_ZM_up' {rv e Vars} (from to step off : Z) (n : nat) `{ArithFact (0 < step)} `{ArithFact (0 <= off)} (vars : Vars) (body : forall (z : Z) `(ArithFact (from <= z <= to)), Vars -> monad rv Vars e) {struct n} : monad rv Vars e. +Fixpoint foreach_ZM_up' {rv e Vars} (from to step off : Z) (n : nat) `{ArithFact (0 <? step)} `{ArithFact (0 <=? off)} (vars : Vars) (body : forall (z : Z) `(ArithFact (from <=? z <=? to)), Vars -> monad rv Vars e) {struct n} : monad rv Vars e. exact ( if sumbool_of_bool (from + off <=? to) then match n with @@ -40,7 +40,7 @@ exact ( else returnm vars). Defined. -Fixpoint foreach_ZM_down' {rv e Vars} (from to step off : Z) (n : nat) `{ArithFact (0 < step)} `{ArithFact (off <= 0)} (vars : Vars) (body : forall (z : Z) `(ArithFact (to <= z <= from)), Vars -> monad rv Vars e) {struct n} : monad rv Vars e. +Fixpoint foreach_ZM_down' {rv e Vars} (from to step off : Z) (n : nat) `{ArithFact (0 <? step)} `{ArithFact (off <=? 0)} (vars : Vars) (body : forall (z : Z) `(ArithFact (to <=? z <=? from)), Vars -> monad rv Vars e) {struct n} : monad rv Vars e. exact ( if sumbool_of_bool (to <=? from + off) then match n with @@ -50,9 +50,9 @@ exact ( else returnm vars). Defined. -Definition foreach_ZM_up {rv e Vars} from to step vars body `{ArithFact (0 < step)} := +Definition foreach_ZM_up {rv e Vars} from to step vars body `{ArithFact (0 <? step)} := foreach_ZM_up' (rv := rv) (e := e) (Vars := Vars) from to step 0 (S (Z.abs_nat (from - to))) vars body. -Definition foreach_ZM_down {rv e Vars} from to step vars body `{ArithFact (0 < step)} := +Definition foreach_ZM_down {rv e Vars} from to step vars body `{ArithFact (0 <? step)} := foreach_ZM_down' (rv := rv) (e := e) (Vars := Vars) from to step 0 (S (Z.abs_nat (from - to))) vars body. (*declare {isabelle} termination_argument foreachM = automatic*) @@ -69,9 +69,9 @@ Definition and_boolM {rv E} (l : monad rv bool E) (r : monad rv bool E) : monad the state monad and program logic rules. They are not currently used in the proof rules because it was more convenient to quantify over them instead. *) Definition and_bool_left_proof {P Q R:bool -> Prop} : - ArithFact (P false) -> - ArithFact (forall l r, P l -> (l = true -> Q r) -> R (andb l r)) -> - ArithFact (R false). + ArithFactP (P false) -> + (forall l r, ArithFactP (P l -> ((l = true -> (Q r)) -> (R (andb l r))))) -> + ArithFactP (R false). intros [p] [h]. constructor. change false with (andb false false). @@ -80,20 +80,20 @@ congruence. Qed. Definition and_bool_full_proof {P Q R:bool -> Prop} {r} : - ArithFact (P true) -> - ArithFact (Q r) -> - ArithFact (forall l r, P l -> (l = true -> Q r) -> R (andb l r)) -> - ArithFact (R r). + ArithFactP (P true) -> + ArithFactP (Q r) -> + (forall l r, ArithFactP ((P l) -> ((l = true -> (Q r)) -> (R (andb l r))))) -> + ArithFactP (R r). intros [p] [q] [h]. constructor. change r with (andb true r). apply h; auto. Qed. -Definition and_boolMP {rv E} {P Q R:bool->Prop} (x : monad rv {b:bool & ArithFact (P b)} E) (y : monad rv {b:bool & ArithFact (Q b)} E) - `{H:ArithFact (forall l r, P l -> (l = true -> Q r) -> R (andb l r))} - : monad rv {b:bool & ArithFact (R b)} E := - x >>= fun '(existT _ x p) => (if x return ArithFact (P x) -> _ then +Definition and_boolMP {rv E} {P Q R:bool->Prop} (x : monad rv {b:bool & ArithFactP (P b)} E) (y : monad rv {b:bool & ArithFactP (Q b)} E) + `{H:forall l r, ArithFactP ((P l) -> ((l = true -> (Q r)) -> (R (andb l r))))} + : monad rv {b:bool & ArithFactP (R b)} E := + x >>= fun '(existT _ x p) => (if x return ArithFactP (P x) -> _ then fun p => y >>= fun '(existT _ y q) => returnm (existT _ y (and_bool_full_proof p q H)) else fun p => returnm (existT _ false (and_bool_left_proof p H))) p. @@ -103,9 +103,9 @@ Definition or_boolM {rv E} (l : monad rv bool E) (r : monad rv bool E) : monad r Definition or_bool_left_proof {P Q R:bool -> Prop} : - ArithFact (P true) -> - ArithFact (forall l r, P l -> (l = false -> Q r) -> R (orb l r)) -> - ArithFact (R true). + ArithFactP (P true) -> + (forall l r, ArithFactP ((P l) -> (((l = false) -> (Q r)) -> (R (orb l r))))) -> + ArithFactP (R true). intros [p] [h]. constructor. change true with (orb true false). @@ -114,25 +114,25 @@ congruence. Qed. Definition or_bool_full_proof {P Q R:bool -> Prop} {r} : - ArithFact (P false) -> - ArithFact (Q r) -> - ArithFact (forall l r, P l -> (l = false -> Q r) -> R (orb l r)) -> - ArithFact (R r). + ArithFactP (P false) -> + ArithFactP (Q r) -> + (forall l r, ArithFactP ((P l) -> (((l = false) -> (Q r)) -> (R (orb l r))))) -> + ArithFactP (R r). intros [p] [q] [h]. constructor. change r with (orb false r). apply h; auto. Qed. -Definition or_boolMP {rv E} {P Q R:bool -> Prop} (l : monad rv {b : bool & ArithFact (P b)} E) (r : monad rv {b : bool & ArithFact (Q b)} E) - `{ArithFact (forall l r, P l -> (l = false -> Q r) -> R (orb l r))} - : monad rv {b : bool & ArithFact (R b)} E := +Definition or_boolMP {rv E} {P Q R:bool -> Prop} (l : monad rv {b : bool & ArithFactP (P b)} E) (r : monad rv {b : bool & ArithFactP (Q b)} E) + `{forall l r, ArithFactP ((P l) -> (((l = false) -> (Q r)) -> (R (orb l r))))} + : monad rv {b : bool & ArithFactP (R b)} E := l >>= fun '(existT _ l p) => - (if l return ArithFact (P l) -> _ then fun p => returnm (existT _ true (or_bool_left_proof p H)) + (if l return ArithFactP (P l) -> _ then fun p => returnm (existT _ true (or_bool_left_proof p H)) else fun p => r >>= fun '(existT _ r q) => returnm (existT _ r (or_bool_full_proof p q H))) p. -Definition build_trivial_ex {rv E} {T:Type} (x:monad rv T E) : monad rv {x : T & ArithFact True} E := - x >>= fun x => returnm (existT _ x (Build_ArithFact _ I)). +Definition build_trivial_ex {rv E} {T:Type} (x:monad rv T E) : monad rv {x : T & ArithFact true} E := + x >>= fun x => returnm (existT _ x (Build_ArithFactP _ eq_refl)). (*val bool_of_bitU_fail : forall 'rv 'e. bitU -> monad 'rv bool 'e*) Definition bool_of_bitU_fail {rv E} (b : bitU) : monad rv bool E := @@ -164,9 +164,10 @@ Definition of_bits_fail {rv A E} `{Bitvector A} (bits : list bitU) : monad rv A (* For termination of recursive functions. We don't name assertions, so use the type class mechanism to find it. *) -Definition _limit_reduces {_limit} (_acc:Acc (Zwf 0) _limit) `{ArithFact (_limit >= 0)} : Acc (Zwf 0) (_limit - 1). +Definition _limit_reduces {_limit} (_acc:Acc (Zwf 0) _limit) `{ArithFact (_limit >=? 0)} : Acc (Zwf 0) (_limit - 1). refine (Acc_inv _acc _). destruct H. +unbool_comparisons. red. omega. Defined. @@ -269,18 +270,18 @@ Fixpoint undefined_word_nat {rv e} n : monad rv (Word.word n) e := returnm (Word.WS b t) end. -Definition undefined_bitvector {rv e} n `{ArithFact (n >= 0)} : monad rv (mword n) e := +Definition undefined_bitvector {rv e} n `{ArithFact (n >=? 0)} : monad rv (mword n) e := undefined_word_nat (Z.to_nat n) >>= fun w => returnm (word_to_mword w). (* If we need to build an existential after a monadic operation, assume that we can do it entirely from the type. *) -Definition build_ex_m {rv e} {T:Type} (x:monad rv T e) {P:T -> Prop} `{H:forall x, ArithFact (P x)} : monad rv {x : T & ArithFact (P x)} e := +Definition build_ex_m {rv e} {T:Type} (x:monad rv T e) {P:T -> Prop} `{H:forall x, ArithFactP (P x)} : monad rv {x : T & ArithFactP (P x)} e := x >>= fun y => returnm (existT _ y (H y)). Definition projT1_m {rv e} {T:Type} {P:T -> Prop} (x: monad rv {x : T & P x} e) : monad rv T e := x >>= fun y => returnm (projT1 y). -Definition derive_m {rv e} {T:Type} {P Q:T -> Prop} (x : monad rv {x : T & P x} e) `{forall x, ArithFact (P x) -> ArithFact (Q x)} : monad rv {x : T & (ArithFact (Q x))} e := +Definition derive_m {rv e} {T:Type} {P Q:T -> Prop} (x : monad rv {x : T & ArithFactP (P x)} e) `{forall x, ArithFactP (P x) -> ArithFactP (Q x)} : monad rv {x : T & (ArithFactP (Q x))} e := x >>= fun y => returnm (build_ex (projT1 y)). diff --git a/lib/coq/Sail2_prompt_monad.v b/lib/coq/Sail2_prompt_monad.v index b26a2ff3..0ff65d28 100644 --- a/lib/coq/Sail2_prompt_monad.v +++ b/lib/coq/Sail2_prompt_monad.v @@ -189,7 +189,7 @@ Definition read_memt_bytes {rv A E} rk (addr : mword A) sz : monad rv (list memo Read_memt rk (Word.wordToNat (get_word addr)) (Z.to_nat sz) returnm. (*val read_memt : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv ('b * bitU) 'e*) -Definition read_memt {rv A B E} `{ArithFact (B >= 0)} rk (addr : mword A) sz : monad rv (mword B * bitU) E := +Definition read_memt {rv A B E} `{ArithFact (B >=? 0)} rk (addr : mword A) sz : monad rv (mword B * bitU) E := bind (read_memt_bytes rk addr sz) (fun '(bytes, tag) => @@ -203,7 +203,7 @@ Definition read_mem_bytes {rv A E} rk (addr : mword A) sz : monad rv (list memor Read_mem rk (Word.wordToNat (get_word addr)) (Z.to_nat sz) returnm. (*val read_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv 'b 'e*) -Definition read_mem {rv A B E} `{ArithFact (B >= 0)} rk (addrsz : Z) (addr : mword A) sz : monad rv (mword B) E := +Definition read_mem {rv A B E} `{ArithFact (B >=? 0)} rk (addrsz : Z) (addr : mword A) sz : monad rv (mword B) E := bind (read_mem_bytes rk addr sz) (fun bytes => diff --git a/lib/coq/Sail2_real.v b/lib/coq/Sail2_real.v index 494e36d4..4800f18b 100644 --- a/lib/coq/Sail2_real.v +++ b/lib/coq/Sail2_real.v @@ -34,3 +34,74 @@ Definition pow_real := powerRZ. Definition print_real (_ : string) (_ : R) : unit := tt. Definition prerr_real (_ : string) (_ : R) : unit := tt. + + + + +Lemma IZRdiv m n : + 0 < m -> 0 < n -> + (IZR (m / n) <= IZR m / IZR n)%R. +intros. +apply Rmult_le_reg_l with (r := IZR n). +auto using IZR_lt. +unfold Rdiv. +rewrite <- Rmult_assoc. +rewrite Rinv_r_simpl_m. +rewrite <- mult_IZR. +apply IZR_le. +apply Z.mul_div_le. +assumption. +discrR. +omega. +Qed. + +(* One annoying use of reals in the ARM spec I've been looking at. *) +Lemma round_up_div m n : + 0 < m -> 0 < n -> + round_up (div_real (to_real m) (to_real n)) = (m + n - 1) / n. +intros. +unfold round_up, round_down, div_real, to_real. +apply Z.eq_opp_l. +apply Z.sub_move_r. +symmetry. +apply up_tech. + +rewrite Ropp_Ropp_IZR. +apply Ropp_le_contravar. +apply Rmult_le_reg_l with (r := IZR n). +auto using IZR_lt. +unfold Rdiv. +rewrite <- Rmult_assoc. +rewrite Rinv_r_simpl_m. +rewrite <- mult_IZR. +apply IZR_le. +assert (diveq : n*((m+n-1)/n) = (m+n-1) - (m+n-1) mod n). +apply Zplus_minus_eq. +rewrite (Z.add_comm ((m+n-1) mod n)). +apply Z.div_mod. +omega. +rewrite diveq. +assert (modmax : (m+n-1) mod n < n). +specialize (Z.mod_pos_bound (m+n-1) n). intuition. +omega. + +discrR; omega. + +rewrite <- Z.opp_sub_distr. +rewrite Ropp_Ropp_IZR. +apply Ropp_lt_contravar. +apply Rmult_lt_reg_l with (r := IZR n). +auto using IZR_lt. +unfold Rdiv. +rewrite <- Rmult_assoc. +rewrite Rinv_r_simpl_m. +2: { discrR. omega. } +rewrite <- mult_IZR. +apply IZR_lt. +rewrite Z.mul_sub_distr_l. +apply Z.le_lt_trans with (m := m+n-1-n*1). +apply Z.sub_le_mono_r. +apply Z.mul_div_le. +assumption. +omega. +Qed. diff --git a/lib/coq/Sail2_state.v b/lib/coq/Sail2_state.v index 618ca3a5..7c751bc7 100644 --- a/lib/coq/Sail2_state.v +++ b/lib/coq/Sail2_state.v @@ -30,6 +30,33 @@ Fixpoint foreachS {A RV Vars E} (xs : list A) (vars : Vars) (body : A -> Vars -> foreachS xs vars body end. +Fixpoint foreach_ZS_up' {rv e Vars} (from to step off : Z) (n : nat) `{ArithFact (0 <? step)} `{ArithFact (0 <=? off)} (vars : Vars) (body : forall (z : Z) `(ArithFact (from <=? z <=? to)), Vars -> monadS rv Vars e) {struct n} : monadS rv Vars e. +exact ( + match sumbool_of_bool (from + off <=? to) with left LE => + match n with + | O => returnS vars + | S n => body (from + off) _ vars >>$= fun vars => foreach_ZS_up' rv e Vars from to step (off + step) n _ _ vars body + end + | right _ => returnS vars + end). +Defined. + +Fixpoint foreach_ZS_down' {rv e Vars} (from to step off : Z) (n : nat) `{ArithFact (0 <? step)} `{ArithFact (off <=? 0)} (vars : Vars) (body : forall (z : Z) `(ArithFact (to <=? z <=? from)), Vars -> monadS rv Vars e) {struct n} : monadS rv Vars e. +exact ( + match sumbool_of_bool (to <=? from + off) with left LE => + match n with + | O => returnS vars + | S n => body (from + off) _ vars >>$= fun vars => foreach_ZS_down' _ _ _ from to step (off - step) n _ _ vars body + end + | right _ => returnS vars + end). +Defined. + +Definition foreach_ZS_up {rv e Vars} from to step vars body `{ArithFact (0 <? step)} := + foreach_ZS_up' (rv := rv) (e := e) (Vars := Vars) from to step 0 (S (Z.abs_nat (from - to))) vars body. +Definition foreach_ZS_down {rv e Vars} from to step vars body `{ArithFact (0 <? step)} := + foreach_ZS_down' (rv := rv) (e := e) (Vars := Vars) from to step 0 (S (Z.abs_nat (from - to))) vars body. + (*val genlistS : forall 'a 'rv 'e. (nat -> monadS 'rv 'a 'e) -> nat -> monadS 'rv (list 'a) 'e*) Definition genlistS {A RV E} (f : nat -> monadS RV A E) n : monadS RV (list A) E := let indices := List.seq 0 n in @@ -43,22 +70,22 @@ Definition and_boolS {RV E} (l r : monadS RV bool E) : monadS RV bool E := Definition or_boolS {RV E} (l r : monadS RV bool E) : monadS RV bool E := l >>$= (fun l => if l then returnS true else r). -Definition and_boolSP {rv E} {P Q R:bool->Prop} (x : monadS rv {b:bool & ArithFact (P b)} E) (y : monadS rv {b:bool & ArithFact (Q b)} E) - `{H:ArithFact (forall l r, P l -> (l = true -> Q r) -> R (andb l r))} - : monadS rv {b:bool & ArithFact (R b)} E := - x >>$= fun '(existT _ x p) => (if x return ArithFact (P x) -> _ then +Definition and_boolSP {rv E} {P Q R:bool->Prop} (x : monadS rv {b:bool & ArithFactP (P b)} E) (y : monadS rv {b:bool & ArithFactP (Q b)} E) + `{H:forall l r, ArithFactP ((P l) -> ((l = true -> (Q r)) -> (R (andb l r))))} + : monadS rv {b:bool & ArithFactP (R b)} E := + x >>$= fun '(existT _ x p) => (if x return ArithFactP (P x) -> _ then fun p => y >>$= fun '(existT _ y q) => returnS (existT _ y (and_bool_full_proof p q H)) else fun p => returnS (existT _ false (and_bool_left_proof p H))) p. -Definition or_boolSP {rv E} {P Q R:bool -> Prop} (l : monadS rv {b : bool & ArithFact (P b)} E) (r : monadS rv {b : bool & ArithFact (Q b)} E) - `{ArithFact (forall l r, P l -> (l = false -> Q r) -> R (orb l r))} - : monadS rv {b : bool & ArithFact (R b)} E := +Definition or_boolSP {rv E} {P Q R:bool -> Prop} (l : monadS rv {b : bool & ArithFactP (P b)} E) (r : monadS rv {b : bool & ArithFactP (Q b)} E) + `{forall l r, ArithFactP ((P l) -> (((l = false) -> (Q r)) -> (R (orb l r))))} + : monadS rv {b : bool & ArithFactP (R b)} E := l >>$= fun '(existT _ l p) => - (if l return ArithFact (P l) -> _ then fun p => returnS (existT _ true (or_bool_left_proof p H)) + (if l return ArithFactP (P l) -> _ then fun p => returnS (existT _ true (or_bool_left_proof p H)) else fun p => r >>$= fun '(existT _ r q) => returnS (existT _ r (or_bool_full_proof p q H))) p. -Definition build_trivial_exS {rv E} {T:Type} (x : monadS rv T E) : monadS rv {x : T & ArithFact True} E := - x >>$= fun x => returnS (existT _ x (Build_ArithFact _ I)). +Definition build_trivial_exS {rv E} {T:Type} (x : monadS rv T E) : monadS rv {x : T & ArithFact true} E := + x >>$= fun x => returnS (existT _ x (Build_ArithFactP _ eq_refl)). (*val bool_of_bitU_fail : forall 'rv 'e. bitU -> monadS 'rv bool 'e*) Definition bool_of_bitU_fail {RV E} (b : bitU) : monadS RV bool E := @@ -84,12 +111,12 @@ Definition bools_of_bits_nondetS {RV E} bits : monadS RV (list bool) E := returnS (bools ++ [b]))). (*val of_bits_nondetS : forall 'rv 'a 'e. Bitvector 'a => list bitU -> monadS 'rv 'a 'e*) -Definition of_bits_nondetS {RV A E} bits `{ArithFact (A >= 0)} : monadS RV (mword A) E := +Definition of_bits_nondetS {RV A E} bits `{ArithFact (A >=? 0)} : monadS RV (mword A) E := bools_of_bits_nondetS bits >>$= (fun bs => returnS (of_bools bs)). (*val of_bits_failS : forall 'rv 'a 'e. Bitvector 'a => list bitU -> monadS 'rv 'a 'e*) -Definition of_bits_failS {RV A E} bits `{ArithFact (A >= 0)} : monadS RV (mword A) E := +Definition of_bits_failS {RV A E} bits `{ArithFact (A >=? 0)} : monadS RV (mword A) E := maybe_failS "of_bits" (of_bits bits). (*val mword_nondetS : forall 'rv 'a 'e. Size 'a => unit -> monadS 'rv (mword 'a) 'e @@ -169,7 +196,7 @@ Fixpoint undefined_word_natS {rv e} n : monadS rv (Word.word n) e := returnS (Word.WS b t) end. -Definition undefined_bitvectorS {rv e} n `{ArithFact (n >= 0)} : monadS rv (mword n) e := +Definition undefined_bitvectorS {rv e} n `{ArithFact (n >=? 0)} : monadS rv (mword n) e := undefined_word_natS (Z.to_nat n) >>$= fun w => returnS (word_to_mword w). diff --git a/lib/coq/Sail2_state_lemmas.v b/lib/coq/Sail2_state_lemmas.v index dd83f239..ef82084f 100644 --- a/lib/coq/Sail2_state_lemmas.v +++ b/lib/coq/Sail2_state_lemmas.v @@ -28,6 +28,42 @@ Add Parametric Morphism {Regs A Vars E : Type} : (@foreachS A Regs Vars E) apply foreachS_cong. Qed. +Lemma foreach_ZS_up_cong rv e Vars from to step vars body body' H : + (forall a pf vars, body a pf vars === body' a pf vars) -> + @foreach_ZS_up rv e Vars from to step vars body H === foreach_ZS_up from to step vars body'. +intro EQ. +unfold foreach_ZS_up. +match goal with +| |- @foreach_ZS_up' _ _ _ _ _ _ _ _ _ ?pf _ _ === _ => generalize pf +end. +generalize 0 at 2 3 4 as off. +revert vars. +induction (S (Z.abs_nat (from - to))); intros; simpl. +* reflexivity. +* destruct (sumbool_of_bool (from + off <=? to)); auto. + rewrite EQ. + setoid_rewrite IHn. + reflexivity. +Qed. + +Lemma foreach_ZS_down_cong rv e Vars from to step vars body body' H : + (forall a pf vars, body a pf vars === body' a pf vars) -> + @foreach_ZS_down rv e Vars from to step vars body H === foreach_ZS_down from to step vars body'. +intro EQ. +unfold foreach_ZS_down. +match goal with +| |- @foreach_ZS_down' _ _ _ _ _ _ _ _ _ ?pf _ _ === _ => generalize pf +end. +generalize 0 at 1 3 4 as off. +revert vars. +induction (S (Z.abs_nat (from - to))); intros; simpl. +* reflexivity. +* destruct (sumbool_of_bool (to <=? from + off)); auto. + rewrite EQ. + setoid_rewrite IHn. + reflexivity. +Qed. + Local Opaque _limit_reduces. Ltac gen_reduces := match goal with |- context[@_limit_reduces ?a ?b ?c] => generalize (@_limit_reduces a b c) end. @@ -160,8 +196,15 @@ Lemma build_trivial_exS_cong {RV T E} x x' : @build_trivial_exS RV T E x === build_trivial_exS x'. intros E1. unfold build_trivial_exS. -rewrite E1. -reflexivity. +apply bindS_cong; auto. +Qed. + +Lemma liftRS_cong {A R Regs E} m m' : + m === m' -> + @liftRS A R Regs E m === liftRS m'. +intros E1. +unfold liftRS. +apply try_catchS_cong; auto. Qed. (* Monad lifting *) @@ -227,11 +270,15 @@ Ltac statecong db := let ty := type of x in match ty with | bool => eapply if_bool_cong; statecong db - | sumbool _ _ => eapply if_sumbool_cong; statecong db + | sumbool _ _ => eapply if_sumbool_cong; statecong db (* There's also a dependent case below *) | _ => apply equiv_reflexive end | |- (foreachS _ _ _) === _ => solve [ eapply foreachS_cong; intros; statecong db ] + | |- (foreach_ZS_up _ _ _ _ _) === _ => + solve [ eapply foreach_ZS_up_cong; intros; statecong db ] + | |- (foreach_ZS_down _ _ _ _ _) === _ => + solve [ eapply foreach_ZS_down_cong; intros; statecong db ] | |- (genlistS _ _) === _ => solve [ eapply genlistS_cong; intros; statecong db ] | |- (whileST _ _ _ _) === _ => @@ -248,6 +295,8 @@ Ltac statecong db := solve [ eapply or_boolSP_cong; intros; statecong db ] | |- (build_trivial_exS _) === _ => solve [ eapply build_trivial_exS_cong; intros; statecong db ] + | |- (liftRS _) === _ => + solve [ eapply liftRS_cong; intros; statecong db ] | |- (let '(matchvar1, matchvar2) := ?e1 in _) === _ => eapply (@equiv_transitive _ _ _ _ (let '(matchvar1,matchvar2) := e1 in _) _); [ destruct e1; etransitivity; [ statecong db | apply equiv_reflexive ] @@ -260,6 +309,10 @@ Ltac statecong db := eapply (@equiv_transitive _ _ _ _ (match e1 with None => _ | Some _ => _ end) _); [ destruct e1; [> etransitivity; [> statecong db | apply equiv_reflexive ] ..] | apply equiv_reflexive ] + | |- (match ?e1 with left _ => _ | right _ => _ end) === _ => + eapply (@equiv_transitive _ _ _ _ (match e1 with left _ => _ | right _ => _ end) _); + [ destruct e1; [> etransitivity; [> statecong db | apply equiv_reflexive ] ..] + | apply equiv_reflexive ] | |- ?X => solve [ apply equiv_reflexive @@ -316,6 +369,19 @@ Hint Extern 0 (liftState _ ?t = _) => end end : liftState. +Lemma liftState_match_distrib_sumbool {Regs Regval A E P Q r x y} {c : sumbool P Q} : + @liftState Regs Regval A E r (match c with left H => x H | right H => y H end) = match c with left H => liftState r (x H) | right H => liftState r (y H) end. +destruct c; reflexivity. +Qed. +(* As above, but also need to beta reduce H into x and y. *) +Hint Extern 0 (liftState _ ?t = _) => + match t with + | match ?x with _ => _ end => + match type of x with + | sumbool _ _ => etransitivity; [apply liftState_match_distrib_sumbool | cbv beta; reflexivity ] + end + end : liftState. + Lemma liftState_let_pair Regs RegVal A B C E r (x : B * C) M : @liftState Regs RegVal A E r (let '(y, z) := x in M y z) = let '(y, z) := x in liftState r (M y z). @@ -456,6 +522,8 @@ Lemma liftState_build_trivial_ex Regs Regval E T r m : @liftState Regs Regval _ E r (@build_trivial_ex _ _ T m) === build_trivial_exS (liftState r m). unfold build_trivial_ex, build_trivial_exS. +unfold ArithFact. +intro. rewrite liftState_bind. reflexivity. Qed. @@ -656,6 +724,52 @@ Qed. Hint Rewrite liftState_foreachM : liftState. Hint Resolve liftState_foreachM : liftState. +Lemma liftState_foreach_ZM_up Regs Regval Vars E from to step vars body H r : + liftState (Regs := Regs) r + (@foreach_ZM_up Regval E Vars from to step vars body H) === + foreach_ZS_up from to step vars (fun z H' a => liftState r (body z H' a)). +unfold foreach_ZM_up, foreach_ZS_up. +match goal with +| |- liftState _ (@foreach_ZM_up' _ _ _ _ _ _ _ _ _ ?pf _ _) === _ => generalize pf +end. +generalize 0 at 2 3 4 as off. +revert vars. +induction (S (Z.abs_nat (from - to))); intros. +* simpl. + rewrite_liftState. + reflexivity. +* simpl. + rewrite_liftState. + destruct (sumbool_of_bool (from + off <=? to)); auto. + repeat replace_ArithFact_proof. + reflexivity. +Qed. +Hint Rewrite liftState_foreach_ZM_up : liftState. +Hint Resolve liftState_foreach_ZM_up : liftState. + +Lemma liftState_foreach_ZM_down Regs Regval Vars E from to step vars body H r : + liftState (Regs := Regs) r + (@foreach_ZM_down Regval E Vars from to step vars body H) === + foreach_ZS_down from to step vars (fun z H' a => liftState r (body z H' a)). +unfold foreach_ZM_down, foreach_ZS_down. +match goal with +| |- liftState _ (@foreach_ZM_down' _ _ _ _ _ _ _ _ _ ?pf _ _) === _ => generalize pf +end. +generalize 0 at 1 3 4 as off. +revert vars. +induction (S (Z.abs_nat (from - to))); intros. +* simpl. + rewrite_liftState. + reflexivity. +* simpl. + rewrite_liftState. + destruct (sumbool_of_bool (to <=? from + off)); auto. + repeat replace_ArithFact_proof. + reflexivity. +Qed. +Hint Rewrite liftState_foreach_ZM_down : liftState. +Hint Resolve liftState_foreach_ZM_down : liftState. + Lemma liftState_genlistM Regs Regval A E r f n : liftState (Regs := Regs) r (@genlistM A Regval E f n) === genlistS (fun x => liftState r (f x)) n. unfold genlistM, genlistS. @@ -706,7 +820,7 @@ Qed. Hint Rewrite liftState_undefined_word_nat : liftState. Hint Resolve liftState_undefined_word_nat : liftState. -Lemma liftState_undefined_bitvector Regs Regval E r n `{ArithFact (n >= 0)} : +Lemma liftState_undefined_bitvector Regs Regval E r n `{ArithFact (n >=? 0)} : liftState (Regs := Regs) (Regval := Regval) (E := E) r (undefined_bitvector n) === undefined_bitvectorS n. unfold undefined_bitvector, undefined_bitvectorS. rewrite_liftState. diff --git a/lib/coq/Sail2_state_monad.v b/lib/coq/Sail2_state_monad.v index bf5c5916..3fb1f8d9 100644 --- a/lib/coq/Sail2_state_monad.v +++ b/lib/coq/Sail2_state_monad.v @@ -182,14 +182,14 @@ Definition read_mem_bytesS {Regs E} (rk : read_kind) addr sz : monadS Regs (list returnS bytes). (*val read_memtS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs ('b * bitU) 'e*) -Definition read_memtS {Regs E A B} (rk : read_kind) (a : mword A) sz `{ArithFact (B >= 0)} : monadS Regs (mword B * bitU) E := +Definition read_memtS {Regs E A B} (rk : read_kind) (a : mword A) sz `{ArithFact (B >=? 0)} : monadS Regs (mword B * bitU) E := let a := Word.wordToNat (get_word a) in read_memt_bytesS rk a (Z.to_nat sz) >>$= (fun '(bytes, tag) => maybe_failS "bits_of_mem_bytes" (of_bits (bits_of_mem_bytes bytes)) >>$= (fun mem_val => returnS (mem_val, tag))). (*val read_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs 'b 'e*) -Definition read_memS {Regs E A B} rk (a : mword A) sz `{ArithFact (B >= 0)} : monadS Regs (mword B) E := +Definition read_memS {Regs E A B} rk (a : mword A) sz `{ArithFact (B >=? 0)} : monadS Regs (mword B) E := read_memtS rk a sz >>$= (fun '(bytes, _) => returnS bytes). diff --git a/lib/coq/Sail2_state_monad_lemmas.v b/lib/coq/Sail2_state_monad_lemmas.v index e9ab36c1..c834a0cb 100644 --- a/lib/coq/Sail2_state_monad_lemmas.v +++ b/lib/coq/Sail2_state_monad_lemmas.v @@ -22,8 +22,8 @@ Global Instance refl_eq_subrelation {A : Type} {R : A -> A -> Prop} `{Reflexive intros x y EQ. subst. reflexivity. Qed. -Hint Extern 4 (_ === _) => reflexivity. -Hint Extern 4 (_ === _) => symmetry. +Hint Extern 4 (_ === _) => reflexivity : core. +Hint Extern 4 (_ === _) => symmetry : core. diff --git a/lib/coq/Sail2_string.v b/lib/coq/Sail2_string.v index a0a23933..1e1b445b 100644 --- a/lib/coq/Sail2_string.v +++ b/lib/coq/Sail2_string.v @@ -8,15 +8,15 @@ Definition string_startswith s expected := let prefix := String.substring 0 (String.length expected) s in generic_eq prefix expected. -Definition string_drop s (n : Z) `{ArithFact (n >= 0)} := +Definition string_drop s (n : Z) `{ArithFact (n >=? 0)} := let n := Z.to_nat n in String.substring n (String.length s - n) s. -Definition string_take s (n : Z) `{ArithFact (n >= 0)} := +Definition string_take s (n : Z) `{ArithFact (n >=? 0)} := let n := Z.to_nat n in String.substring 0 n s. -Definition string_length s : {n : Z & ArithFact (n >= 0)} := +Definition string_length s : {n : Z & ArithFact (n >=? 0)} := build_ex (Z.of_nat (String.length s)). Definition string_append := String.append. @@ -56,7 +56,7 @@ match s with else (acc, len) end end. -Local Definition int_of (s : string) (base : Z) (len : nat) : option (Z * {n : Z & ArithFact (n >= 0)}) := +Local Definition int_of (s : string) (base : Z) (len : nat) : option (Z * {n : Z & ArithFact (n >=? 0)}) := match s with | EmptyString => None | String h t => @@ -74,7 +74,7 @@ end. (* I've stuck closely to OCaml's int_of_string, because that's what's currently used elsewhere. *) -Definition maybe_int_of_prefix (s : string) : option (Z * {n : Z & ArithFact (n >= 0)}) := +Definition maybe_int_of_prefix (s : string) : option (Z * {n : Z & ArithFact (n >=? 0)}) := match s with | EmptyString => None | String "0" (String ("x"|"X") t) => int_of t 16 2 @@ -105,16 +105,16 @@ Fixpoint n_leading_spaces (s:string) : nat := | _ => 0 end. -Definition opt_spc_matches_prefix s : option (unit * {n : Z & ArithFact (n >= 0)}) := +Definition opt_spc_matches_prefix s : option (unit * {n : Z & ArithFact (n >=? 0)}) := Some (tt, build_ex (Z.of_nat (n_leading_spaces s))). -Definition spc_matches_prefix s : option (unit * {n : Z & ArithFact (n >= 0)}) := +Definition spc_matches_prefix s : option (unit * {n : Z & ArithFact (n >=? 0)}) := match n_leading_spaces s with | O => None | S n => Some (tt, build_ex (Z.of_nat (S n))) end. -Definition hex_bits_n_matches_prefix sz `{ArithFact (sz >= 0)} s : option (mword sz * {n : Z & ArithFact (n >= 0)}) := +Definition hex_bits_n_matches_prefix sz `{ArithFact (sz >=? 0)} s : option (mword sz * {n : Z & ArithFact (n >=? 0)}) := match maybe_int_of_prefix s with | None => None | Some (n, len) => @@ -180,6 +180,23 @@ match z with | Zneg p => String "-" (string_of_N (pos_limit p) (Npos p) "") end. +Local Definition asciiA : N := Ascii.N_of_ascii "A". +Local Fixpoint hex_string_of_N (limit : nat) (n : N) (acc : string) : string := +match limit with +| O => acc +| S limit' => + let (d,m) := N.div_eucl n 16 in + let digit := if 10 <=? m then m - 10 + asciiA else m + zero in + let acc := String (Ascii.ascii_of_N digit) acc in + if N.ltb 0 d then hex_string_of_N limit' d acc else acc +end%N. +Definition hex_string_of_int (z : Z) : string := +match z with +| Z0 => "0" +| Zpos p => hex_string_of_N (pos_limit p) (Npos p) "" +| Zneg p => String "-" (hex_string_of_N (pos_limit p) (Npos p) "") +end. + Definition decimal_string_of_bv {a} `{Bitvector a} (bv : a) : string := match unsigned bv with | None => "?" @@ -191,4 +208,5 @@ Definition decimal_string_of_bits {n} (bv : mword n) : string := decimal_string_ (* Some aliases for compatibility. *) Definition dec_str := string_of_int. +Definition hex_str := hex_string_of_int. Definition concat_str := String.append. diff --git a/lib/coq/Sail2_values.v b/lib/coq/Sail2_values.v index b29963b6..9b76ce62 100644 --- a/lib/coq/Sail2_values.v +++ b/lib/coq/Sail2_values.v @@ -5,6 +5,7 @@ Require Export ZArith. Require Import Ascii. Require Export String. Require Import bbv.Word. +Require Export bbv.HexNotationWord. Require Export List. Require Export Sumbool. Require Export DecidableClass. @@ -14,6 +15,7 @@ Require Import Lia. Import ListNotations. Open Scope Z. +Open Scope bool. Module Z_eq_dec. Definition U := Z. @@ -26,27 +28,74 @@ Module ZEqdep := DecidableEqDep (Z_eq_dec). can be added to, and a typeclass to wrap constraint arguments in to trigger automatic solving. *) Create HintDb sail. -Class ArithFact (P : Prop) := { fact : P }. -Lemma use_ArithFact {P} `(ArithFact P) : P. +(* Facts translated from Sail's type system are wrapped in ArithFactP or + ArithFact so that the solver can be invoked automatically by Coq's + typeclass mechanism. Most properties are boolean, which enjoys proof + irrelevance by UIP. *) +Class ArithFactP (P : Prop) := { fact : P }. +Class ArithFact (P : bool) := ArithFactClass : ArithFactP (P = true). +Lemma use_ArithFact {P} `(ArithFact P) : P = true. +unfold ArithFact in *. apply fact. Defined. +Lemma ArithFact_irrelevant (P : bool) (p q : ArithFact P) : p = q. +destruct p,q. +f_equal. +apply Eqdep_dec.UIP_dec. +apply Bool.bool_dec. +Qed. + +Ltac replace_ArithFact_proof := + match goal with |- context[?x] => + match tt with + | _ => is_var x; fail 1 + | _ => + match type of x with ArithFact ?P => + let pf := fresh "pf" in + generalize x as pf; intro pf; + repeat multimatch goal with |- context[?y] => + match type of y with ArithFact P => + match y with + | pf => idtac + | _ => rewrite <- (ArithFact_irrelevant P pf y) + end + end + end + end + end + end. + +Ltac generalize_ArithFact_proof_in H := + match type of H with context f [?x] => + match type of x with ArithFactP (?P = true) => + let pf := fresh "pf" in + cut (forall (pf : ArithFact P), ltac:(let t := context f[pf] in exact t)); + [ clear H; intro H + | intro pf; rewrite <- (ArithFact_irrelevant P x pf); apply H ] + | ArithFact ?P => + let pf := fresh "pf" in + cut (forall (pf : ArithFact P), ltac:(let t := context f[pf] in exact t)); + [ clear H; intro H + | intro pf; rewrite <- (ArithFact_irrelevant P x pf); apply H ] + end + end. + (* Allow setoid rewriting through ArithFact *) Require Import Coq.Classes.Morphisms. Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. + Section Morphism. Local Obligation Tactic := try solve [simpl_relation | firstorder auto]. - -Global Program Instance ArithFact_iff_morphism : - Proper (iff ==> iff) ArithFact. +Global Program Instance ArithFactP_iff_morphism : + Proper (iff ==> iff) ArithFactP. End Morphism. - -Definition build_ex {T:Type} (n:T) {P:T -> Prop} `{H:ArithFact (P n)} : {x : T & ArithFact (P x)} := +Definition build_ex {T:Type} (n:T) {P:T -> Prop} `{H:ArithFactP (P n)} : {x : T & ArithFactP (P x)} := existT _ n H. -Definition build_ex2 {T:Type} {T':T -> Type} (n:T) (m:T' n) {P:T -> Prop} `{H:ArithFact (P n)} : {x : T & T' x & ArithFact (P x)} := +Definition build_ex2 {T:Type} {T':T -> Type} (n:T) (m:T' n) {P:T -> Prop} `{H:ArithFactP (P n)} : {x : T & T' x & ArithFactP (P x)} := existT2 _ _ n m H. Definition generic_eq {T:Type} (x y:T) `{Decidable (x = y)} := Decidable_witness. @@ -75,23 +124,25 @@ destruct Decidable_witness; simpl in *; congruence. Qed. Instance Decidable_eq_from_dec {T:Type} (eqdec: forall x y : T, {x = y} + {x <> y}) : - forall (x y : T), Decidable (eq x y) := { + forall (x y : T), Decidable (eq x y). +refine (fun x y => {| Decidable_witness := proj1_sig (bool_of_sumbool (eqdec x y)) -}. +|}). destruct (eqdec x y); simpl; split; congruence. Defined. -Instance Decidable_eq_unit : forall (x y : unit), Decidable (x = y) := - { Decidable_witness := true }. +Instance Decidable_eq_unit : forall (x y : unit), Decidable (x = y). +refine (fun x y => {| Decidable_witness := true |}). destruct x, y; split; auto. Defined. Instance Decidable_eq_string : forall (x y : string), Decidable (x = y) := Decidable_eq_from_dec String.string_dec. -Instance Decidable_eq_pair {A B : Type} `(DA : forall x y : A, Decidable (x = y), DB : forall x y : B, Decidable (x = y)) : forall x y : A*B, Decidable (x = y) := -{ Decidable_witness := andb (@Decidable_witness _ (DA (fst x) (fst y))) -(@Decidable_witness _ (DB (snd x) (snd y))) }. +Instance Decidable_eq_pair {A B : Type} `(DA : forall x y : A, Decidable (x = y), DB : forall x y : B, Decidable (x = y)) : forall x y : A*B, Decidable (x = y). +refine (fun x y => +{| Decidable_witness := andb (@Decidable_witness _ (DA (fst x) (fst y))) + (@Decidable_witness _ (DB (snd x) (snd y))) |}). destruct x as [x1 x2]. destruct y as [y1 y2]. simpl. @@ -130,16 +181,20 @@ Ltac cmp_record_field x y := ]. +Notation "x <=? y <=? z" := ((x <=? y) && (y <=? z)) (at level 70, y at next level) : Z_scope. +Notation "x <=? y <? z" := ((x <=? y) && (y <? z)) (at level 70, y at next level) : Z_scope. +Notation "x <? y <? z" := ((x <? y) && (y <? z)) (at level 70, y at next level) : Z_scope. +Notation "x <? y <=? z" := ((x <? y) && (y <=? z)) (at level 70, y at next level) : Z_scope. (* Project away range constraints in comparisons *) -Definition ltb_range_l {lo hi} (l : {x & ArithFact (lo <= x /\ x <= hi)}) r := Z.ltb (projT1 l) r. -Definition leb_range_l {lo hi} (l : {x & ArithFact (lo <= x /\ x <= hi)}) r := Z.leb (projT1 l) r. -Definition gtb_range_l {lo hi} (l : {x & ArithFact (lo <= x /\ x <= hi)}) r := Z.gtb (projT1 l) r. -Definition geb_range_l {lo hi} (l : {x & ArithFact (lo <= x /\ x <= hi)}) r := Z.geb (projT1 l) r. -Definition ltb_range_r {lo hi} l (r : {x & ArithFact (lo <= x /\ x <= hi)}) := Z.ltb l (projT1 r). -Definition leb_range_r {lo hi} l (r : {x & ArithFact (lo <= x /\ x <= hi)}) := Z.leb l (projT1 r). -Definition gtb_range_r {lo hi} l (r : {x & ArithFact (lo <= x /\ x <= hi)}) := Z.gtb l (projT1 r). -Definition geb_range_r {lo hi} l (r : {x & ArithFact (lo <= x /\ x <= hi)}) := Z.geb l (projT1 r). +Definition ltb_range_l {lo hi} (l : {x & ArithFact (lo <=? x <=? hi)}) r := Z.ltb (projT1 l) r. +Definition leb_range_l {lo hi} (l : {x & ArithFact (lo <=? x <=? hi)}) r := Z.leb (projT1 l) r. +Definition gtb_range_l {lo hi} (l : {x & ArithFact (lo <=? x <=? hi)}) r := Z.gtb (projT1 l) r. +Definition geb_range_l {lo hi} (l : {x & ArithFact (lo <=? x <=? hi)}) r := Z.geb (projT1 l) r. +Definition ltb_range_r {lo hi} l (r : {x & ArithFact (lo <=? x <=? hi)}) := Z.ltb l (projT1 r). +Definition leb_range_r {lo hi} l (r : {x & ArithFact (lo <=? x <=? hi)}) := Z.leb l (projT1 r). +Definition gtb_range_r {lo hi} l (r : {x & ArithFact (lo <=? x <=? hi)}) := Z.gtb l (projT1 r). +Definition geb_range_r {lo hi} l (r : {x & ArithFact (lo <=? x <=? hi)}) := Z.geb l (projT1 r). Definition ii := Z. Definition nn := nat. @@ -147,23 +202,23 @@ Definition nn := nat. (*val pow : Z -> Z -> Z*) Definition pow m n := m ^ n. -Program Definition pow2 n : {z : Z & ArithFact (2 ^ n <= z <= 2 ^ n)} := existT _ (pow 2 n) _. +Program Definition pow2 n : {z : Z & ArithFact (2 ^ n <=? z <=? 2 ^ n)} := existT _ (pow 2 n) _. Next Obligation. constructor. unfold pow. -auto using Z.le_refl. +auto using Z.leb_refl with bool. Qed. -Lemma ZEuclid_div_pos : forall x y, y > 0 -> x >= 0 -> ZEuclid.div x y >= 0. +Lemma ZEuclid_div_pos : forall x y, 0 < y -> 0 <= x -> 0 <= ZEuclid.div x y. intros. unfold ZEuclid.div. change 0 with (0 * 0). -apply Zmult_ge_compat; auto with zarith. -* apply Z.le_ge. apply Z.sgn_nonneg. apply Z.ge_le. auto with zarith. -* apply Z_div_ge0; auto. apply Z.lt_gt. apply Z.abs_pos. auto with zarith. +apply Zmult_le_compat; auto with zarith. +* apply Z.sgn_nonneg. auto with zarith. +* apply Z_div_pos; auto. apply Z.lt_gt. apply Z.abs_pos. auto with zarith. Qed. -Lemma ZEuclid_pos_div : forall x y, y > 0 -> ZEuclid.div x y >= 0 -> x >= 0. +Lemma ZEuclid_pos_div : forall x y, 0 < y -> 0 <= ZEuclid.div x y -> 0 <= x. intros x y GT. specialize (ZEuclid.div_mod x y); specialize (ZEuclid.mod_always_pos x y); @@ -204,6 +259,13 @@ Qed. Hint Resolve ZEuclid_div_pos ZEuclid_pos_div ZEuclid_div_ge ZEuclid_div_mod0 : sail. +Lemma Z_geb_ge n m : (n >=? m) = true <-> n >= m. +rewrite Z.geb_leb. +split. +* intro. apply Z.le_ge, Z.leb_le. assumption. +* intro. apply Z.ge_le in H. apply Z.leb_le. assumption. +Qed. + (* Definition inline lt := (<) @@ -815,19 +877,25 @@ apply Z2Nat.inj_lt. Close Scope nat. (*val access_list_inc : forall a. list a -> Z -> a*) -Definition access_list_inc {A} (xs : list A) n `{ArithFact (0 <= n)} `{ArithFact (n < length_list xs)} := nth_in_range (Z.to_nat n) xs (nth_Z_nat (use_ArithFact _) (use_ArithFact _)). +Definition access_list_inc {A} (xs : list A) n `{ArithFact (0 <=? n)} `{ArithFact (n <? length_list xs)} : A. +refine (nth_in_range (Z.to_nat n) xs (nth_Z_nat _ _)). +* apply Z.leb_le. + auto using use_ArithFact. +* apply Z.ltb_lt. + auto using use_ArithFact. +Defined. (*val access_list_dec : forall a. list a -> Z -> a*) -Definition access_list_dec {A} (xs : list A) n `{ArithFact (0 <= n)} `{ArithFact (n < length_list xs)} : A. +Definition access_list_dec {A} (xs : list A) n `{H1:ArithFact (0 <=? n)} `{H2:ArithFact (n <? length_list xs)} : A. refine ( let top := (length_list xs) - 1 in @access_list_inc A xs (top - n) _ _). -constructor. apply use_ArithFact in H. apply use_ArithFact in H0. omega. -constructor. apply use_ArithFact in H. apply use_ArithFact in H0. omega. +abstract (constructor; apply use_ArithFact, Z.leb_le in H1; apply use_ArithFact, Z.ltb_lt in H2; apply Z.leb_le; omega). +abstract (constructor; apply use_ArithFact, Z.leb_le in H1; apply use_ArithFact, Z.ltb_lt in H2; apply Z.ltb_lt; omega). Defined. (*val access_list : forall a. bool -> list a -> Z -> a*) -Definition access_list {A} (is_inc : bool) (xs : list A) n `{ArithFact (0 <= n)} `{ArithFact (n < length_list xs)} := +Definition access_list {A} (is_inc : bool) (xs : list A) n `{ArithFact (0 <=? n)} `{ArithFact (n <? length_list xs)} := if is_inc then access_list_inc xs n else access_list_dec xs n. Definition access_list_opt_inc {A} (xs : list A) n := nth_error xs (Z.to_nat n). @@ -884,15 +952,15 @@ match n with | Zpos _ => fun f w => f w end. -Program Definition to_word {n} : n >= 0 -> word (Z.to_nat n) -> mword n := +Program Definition to_word {n} : n >=? 0 = true -> word (Z.to_nat n) -> mword n := match n with | Zneg _ => fun H _ => _ | Z0 => fun _ w => w | Zpos _ => fun _ w => w end. -Definition word_to_mword {n} (w : word (Z.to_nat n)) `{H:ArithFact (n >= 0)} : mword n := - to_word (match H with Build_ArithFact _ H' => H' end) w. +Definition word_to_mword {n} (w : word (Z.to_nat n)) `{H:ArithFact (n >=? 0)} : mword n := + to_word (use_ArithFact H) w. (*val length_mword : forall a. mword a -> Z*) Definition length_mword {n} (w : mword n) := n. @@ -968,7 +1036,7 @@ Definition update_mword {a} (is_inc : bool) (w : mword a) n b := if is_inc then update_mword_inc w n b else update_mword_dec w n b. (*val int_of_mword : forall 'a. bool -> mword 'a -> integer*) -Definition int_of_mword {a} `{ArithFact (a >= 0)} (sign : bool) (w : mword a) := +Definition int_of_mword {a} `{ArithFact (a >=? 0)} (sign : bool) (w : mword a) := if sign then wordToZ (get_word w) else Z.of_N (wordToN (get_word w)). @@ -977,16 +1045,18 @@ Definition mword_of_int len n := let w := wordFromInteger n in if (length_mword w = len) then w else failwith "unexpected word length" *) -Program Definition mword_of_int {len} `{H:ArithFact (len >= 0)} n : mword len := +Program Definition mword_of_int {len} `{H:ArithFact (len >=? 0)} n : mword len := match len with | Zneg _ => _ | Z0 => ZToWord 0 n | Zpos p => ZToWord (Pos.to_nat p) n end. Next Obligation. -destruct H. -auto. +destruct H as [H]. +unfold Z.geb, Z.compare in H. +discriminate. Defined. + (* (* Translating between a type level number (itself n) and an integer *) @@ -1055,20 +1125,9 @@ Instance bitlist_Bitvector {a : Type} `{BitU a} : (Bitvector (list a)) := { }. Class ReasonableSize (a : Z) : Prop := { - isPositive : a >= 0 + isPositive : a >=? 0 = true }. -(* Omega doesn't know about In, but can handle disjunctions. *) -Ltac unfold_In := -repeat match goal with -| H:context [member_Z_list _ _ = true] |- _ => rewrite member_Z_list_In in H -| H:context [In ?x (?y :: ?t)] |- _ => change (In x (y :: t)) with (y = x \/ In x t) in H -| H:context [In ?x []] |- _ => change (In x []) with False in H -| |- context [member_Z_list _ _ = true] => rewrite member_Z_list_In -| |- context [In ?x (?y :: ?t)] => change (In x (y :: t)) with (y = x \/ In x t) -| |- context [In ?x []] => change (In x []) with False -end. - (* Definitions in the context that involve proof for other constraints can break some of the constraint solving tactics, so prune definition bodies down to integer types. *) @@ -1081,17 +1140,54 @@ repeat match goal with X := _ |- _ => match goal with _ : context[X] |- _ => idtac end || clear X end. -Lemma ArithFact_mword (a : Z) (w : mword a) : ArithFact (a >= 0). +Lemma lift_bool_exists (l r : bool) (P : bool -> Prop) : + (l = r -> exists x, P x) -> + (exists x, l = r -> P x). +intro H. +destruct (Bool.bool_dec l r) as [e | ne]. +* destruct (H e) as [x H']; eauto. +* exists true; tauto. +Qed. + +Lemma ArithFact_mword (a : Z) (w : mword a) : ArithFact (a >=? 0). constructor. destruct a. auto with zarith. auto using Z.le_ge, Zle_0_pos. destruct w. Qed. +(* Remove constructor from ArithFact(P)s and if they're used elsewhere + in the context create a copy that rewrites will work on. *) Ltac unwrap_ArithFacts := - repeat match goal with H:(ArithFact _) |- _ => let H' := fresh H in case H as [H']; clear H end. + let gen X := + let Y := fresh "Y" in pose X as Y; generalize Y + in + let unwrap H := + let H' := fresh H in case H as [H']; clear H; + match goal with + | _ : context[H'] |- _ => gen H' + | _ := context[H'] |- _ => gen H' + | |- context[H'] => gen H' + | _ => idtac + end + in + repeat match goal with + | H:(ArithFact _) |- _ => unwrap H + | H:(ArithFactP _) |- _ => unwrap H + end. Ltac unbool_comparisons := repeat match goal with + | H:@eq bool _ _ -> @ex bool _ |- _ => apply lift_bool_exists in H; destruct H + | H:@ex Z _ |- _ => destruct H + (* Omega doesn't know about In, but can handle disjunctions. *) + | H:context [member_Z_list _ _ = true] |- _ => rewrite member_Z_list_In in H + | H:context [In ?x (?y :: ?t)] |- _ => change (In x (y :: t)) with (y = x \/ In x t) in H + | H:context [In ?x []] |- _ => change (In x []) with False in H + | H:?v = true |- _ => is_var v; subst v + | H:?v = false |- _ => is_var v; subst v + | H:true = ?v |- _ => is_var v; subst v + | H:false = ?v |- _ => is_var v; subst v + | H:_ /\ _ |- _ => destruct H | H:context [Z.geb _ _] |- _ => rewrite Z.geb_leb in H | H:context [Z.gtb _ _] |- _ => rewrite Z.gtb_ltb in H | H:context [Z.leb _ _ = true] |- _ => rewrite Z.leb_le in H @@ -1106,15 +1202,29 @@ Ltac unbool_comparisons := | H:context [andb _ _ = false] |- _ => rewrite Bool.andb_false_iff in H | H:context [negb _ = true] |- _ => rewrite Bool.negb_true_iff in H | H:context [negb _ = false] |- _ => rewrite Bool.negb_false_iff in H + | H:context [Bool.eqb _ ?r = true] |- _ => rewrite Bool.eqb_true_iff in H; + try (is_var r; subst r) + | H:context [Bool.eqb _ _ = false] |- _ => rewrite Bool.eqb_false_iff in H | H:context [generic_eq _ _ = true] |- _ => apply generic_eq_true in H | H:context [generic_eq _ _ = false] |- _ => apply generic_eq_false in H | H:context [generic_neq _ _ = true] |- _ => apply generic_neq_true in H | H:context [generic_neq _ _ = false] |- _ => apply generic_neq_false in H | H:context [_ <> true] |- _ => rewrite Bool.not_true_iff_false in H | H:context [_ <> false] |- _ => rewrite Bool.not_false_iff_true in H + | H:context [@eq bool ?l ?r] |- _ => + lazymatch r with + | true => fail + | false => fail + | _ => rewrite (Bool.eq_iff_eq_true l r) in H + end end. Ltac unbool_comparisons_goal := repeat match goal with + (* Important to have these early in the list - setoid_rewrite can + unfold member_Z_list. *) + | |- context [member_Z_list _ _ = true] => rewrite member_Z_list_In + | |- context [In ?x (?y :: ?t)] => change (In x (y :: t)) with (y = x \/ In x t) + | |- context [In ?x []] => change (In x []) with False | |- context [Z.geb _ _] => setoid_rewrite Z.geb_leb | |- context [Z.gtb _ _] => setoid_rewrite Z.gtb_ltb | |- context [Z.leb _ _ = true] => setoid_rewrite Z.leb_le @@ -1129,12 +1239,20 @@ Ltac unbool_comparisons_goal := | |- context [andb _ _ = false] => setoid_rewrite Bool.andb_false_iff | |- context [negb _ = true] => setoid_rewrite Bool.negb_true_iff | |- context [negb _ = false] => setoid_rewrite Bool.negb_false_iff + | |- context [Bool.eqb _ _ = true] => setoid_rewrite Bool.eqb_true_iff + | |- context [Bool.eqb _ _ = false] => setoid_rewrite Bool.eqb_false_iff | |- context [generic_eq _ _ = true] => apply generic_eq_true | |- context [generic_eq _ _ = false] => apply generic_eq_false | |- context [generic_neq _ _ = true] => apply generic_neq_true | |- context [generic_neq _ _ = false] => apply generic_neq_false | |- context [_ <> true] => setoid_rewrite Bool.not_true_iff_false | |- context [_ <> false] => setoid_rewrite Bool.not_false_iff_true + | |- context [@eq bool _ ?r] => + lazymatch r with + | true => fail + | false => fail + | _ => setoid_rewrite Bool.eq_iff_eq_true + end end. (* Split up dependent pairs to get at proofs of properties *) @@ -1359,10 +1477,12 @@ end; (* We may have uncovered more conjunctions *) repeat match goal with H:and _ _ |- _ => destruct H end. +(* Remove details of embedded proofs. *) Ltac generalize_embedded_proofs := repeat match goal with H:context [?X] |- _ => - match type of X with ArithFact _ => - generalize dependent X + match type of X with + | ArithFact _ => generalize dependent X + | ArithFactP _ => generalize dependent X end end; intros. @@ -1416,7 +1536,6 @@ Ltac prepare_for_solver := unbool_comparisons_goal; repeat match goal with H:and _ _ |- _ => destruct H end; remove_unnecessary_casesplit; - unfold_In; (* after unbool_comparisons to deal with && and || *) reduce_list_lengths; reduce_pow; filter_disjunctions; @@ -1425,9 +1544,9 @@ Ltac prepare_for_solver := subst; clean_up_props. -Lemma trivial_range {x : Z} : ArithFact (x <= x /\ x <= x). +Lemma trivial_range {x : Z} : ArithFact ((x <=? x <=? x)). constructor. -auto with zarith. +auto using Z.leb_refl with bool. Qed. Lemma ArithFact_self_proof {P} : forall x : {y : Z & ArithFact (P y)}, ArithFact (P (projT1 x)). @@ -1435,14 +1554,19 @@ intros [x H]. exact H. Qed. +Lemma ArithFactP_self_proof {P} : forall x : {y : Z & ArithFactP (P y)}, ArithFactP (P (projT1 x)). +intros [x H]. +exact H. +Qed. + Ltac fill_in_evar_eq := - match goal with |- ArithFact (?x = ?y) => + match goal with |- ArithFact (?x =? ?y) => (is_evar x || is_evar y); (* compute to allow projections to remove proofs that might not be allowed in the evar *) (* Disabled because cbn may reduce definitions, even after clearbody let x := eval cbn in x in let y := eval cbn in y in*) - idtac "Warning: unknown equality constraint"; constructor; exact (eq_refl _ : x = y) end. + idtac "Warning: unknown equality constraint"; constructor; exact (Z.eqb_refl _ : x =? y = true) end. Ltac bruteforce_bool_exists := match goal with @@ -1477,6 +1601,71 @@ repeat match goal with intros end; nia. +(* Try to get the linear arithmetic solver to do booleans. *) + +Lemma b2z_true x : x = true <-> Z.b2z x = 1. +destruct x; compute; split; congruence. +Qed. + +Lemma b2z_false x : x = false <-> Z.b2z x = 0. +destruct x; compute; split; congruence. +Qed. + +Lemma b2z_tf x : 0 <= Z.b2z x <= 1. +destruct x; simpl; omega. +Qed. + +Lemma b2z_andb a b : + Z.b2z (a && b) = Z.min (Z.b2z a) (Z.b2z b). +destruct a,b; reflexivity. +Qed. +Lemma b2z_orb a b : + Z.b2z (a || b) = Z.max (Z.b2z a) (Z.b2z b). +destruct a,b; reflexivity. +Qed. + +Lemma b2z_eq : forall a b, Z.b2z a = Z.b2z b <-> a = b. +intros [|] [|]; +simpl; +intuition try congruence. +Qed. + +Lemma b2z_negb x : Z.b2z (negb x) = 1 - Z.b2z x. + destruct x ; reflexivity. +Qed. + +Ltac bool_to_Z := + subst; + rewrite ?truefalse, ?falsetrue, ?or_False_l, ?or_False_r in *; + (* I did try phrasing these as rewrites, but Coq was oddly reluctant to use them *) + repeat match goal with + | H:?x = ?x <-> _ |- _ => apply iff_equal_l in H + | H:_ <-> ?x = ?x |- _ => apply iff_equal_r in H + end; + repeat match goal with + | H:context [negb ?v] |- _ => rewrite b2z_negb in H + | |- context [negb ?v] => rewrite b2z_negb + | H:context [?v = true] |- _ => is_var v; rewrite (b2z_true v) in * + | |- context [?v = true] => is_var v; rewrite (b2z_true v) in * + | H:context [?v = false] |- _ => is_var v; rewrite (b2z_false v) in * + | |- context [?v = false] => is_var v; rewrite (b2z_false v) in * + | H:context [?v = ?w] |- _ => rewrite <- (b2z_eq v w) in H + | |- context [?v = ?w] => rewrite <- (b2z_eq v w) + | H:context [Z.b2z (?v && ?w)] |- _ => rewrite (b2z_andb v w) in H + | |- context [Z.b2z (?v && ?w)] => rewrite (b2z_andb v w) + | H:context [Z.b2z (?v || ?w)] |- _ => rewrite (b2z_orb v w) in H + | |- context [Z.b2z (?v || ?w)] => rewrite (b2z_orb v w) + end; + change (Z.b2z true) with 1 in *; + change (Z.b2z false) with 0 in *; + repeat match goal with + | _:context [Z.b2z ?v] |- _ => generalize (b2z_tf v); generalize dependent (Z.b2z v) + | |- context [Z.b2z ?v] => generalize (b2z_tf v); generalize dependent (Z.b2z v) + end. +Ltac solve_bool_with_Z := + bool_to_Z; + intros; + lia. (* A more ambitious brute force existential solver. *) @@ -1495,8 +1684,8 @@ Ltac guess_ex_solver := guess_ex_solver*) | |- @ex bool _ => exists true; guess_ex_solver | |- @ex bool _ => exists false; guess_ex_solver - | x : Z |- @ex Z _ => exists x; guess_ex_solver - | _ => solve [tauto | eauto 3 with zarith sail | omega | intuition] + | x : ?ty |- @ex ?ty _ => exists x; guess_ex_solver + | _ => solve [tauto | eauto 3 with zarith sail | solve_bool_with_Z | omega] end. (* A straightforward solver for simple problems like @@ -1527,6 +1716,7 @@ Ltac simple_ex_iff := match goal with | |- @ex _ _ => eexists; simple_ex_iff | |- _ <-> _ => + symmetry; simple_split_iff; form_iff_true; solve [apply iff_refl | eassumption] @@ -1625,7 +1815,7 @@ Ltac ex_iff_solve := | |- @ex _ _ => eexists; ex_iff_solve (* Range constraints are attached to the right *) | |- _ /\ _ => split; [ex_iff_solve | omega] - | |- _ <-> _ => conjuncts_iff_solve + | |- _ <-> _ => conjuncts_iff_solve || (symmetry; conjuncts_iff_solve) end. @@ -1654,41 +1844,73 @@ Ltac z_comparisons := | exact Z_compare_gt_lt | exact Z_compare_gt_eq ]. + +Ltac bool_ex_solve := +match goal with H : ?l = ?v -> @ex _ _ |- @ex _ _ => + match v with true => idtac | false => idtac end; + destruct l; + repeat match goal with H:?X = ?X -> _ |- _ => specialize (H eq_refl) end; + repeat match goal with H:@ex _ _ |- _ => destruct H end; + unbool_comparisons; + guess_ex_solver +end. -(* Try to get the linear arithmetic solver to do booleans. *) - -Lemma b2z_true x : x = true <-> Z.b2z x = 1. -destruct x; compute; split; congruence. -Qed. - -Lemma b2z_false x : x = false <-> Z.b2z x = 0. -destruct x; compute; split; congruence. -Qed. +(* Solve a boolean equality goal which is just rearranged clauses (e.g, at the + end of the clause_matching_bool_solver, below. *) +Ltac bruteforce_bool_eq := + lazymatch goal with + | |- _ && ?l1 = _ => idtac l1; destruct l1; rewrite ?Bool.andb_true_l, ?Bool.andb_true_r, ?Bool.andb_false_l, ?Bool.andb_false_r; bruteforce_bool_eq + | |- ?l = _ => reflexivity + end. -Lemma b2z_tf x : 0 <= Z.b2z x <= 1. -destruct x; simpl; omega. -Qed. +Ltac clause_matching_bool_solver := +(* Do the left hand and right hand clauses have the same shape? *) +let rec check l r := + lazymatch l with + | ?l1 || ?l2 => + lazymatch r with ?r1 || ?r2 => check l1 r1; check l2 r2 end + | ?l1 =? ?l2 => + lazymatch r with ?r1 =? ?r2 => check l1 r1; check l2 r2 end + | _ => is_evar l + constr_eq l r + end +in +(* Rebuild remaining rhs, dropping extra "true"s. *) +let rec add_clause l r := + match l with + | true => r + | _ => match r with true => l | _ => constr:(l && r) end + end +in +(* Find a clause in r matching l, use unify to instantiate evars, return rest of r *) +let rec find l r := + lazymatch r with + | ?r1 && ?r2 => + match l with + | _ => let r1' := find l r1 in add_clause r1' r2 + | _ => let r2' := find l r2 in add_clause r1 r2' + end + | _ => constr:(ltac:(check l r; unify l r; exact true)) + end +in +(* For each clause in the lhs, find a matching clause in rhs, fill in + remaining evar with left over. TODO: apply to goals without an evar clause *) +match goal with + | |- @ex _ _ => eexists; clause_matching_bool_solver + | |- _ = _ /\ _ <= _ <= _ => split; [clause_matching_bool_solver | omega] + | |- ?l = ?r => + let rec clause l r := + match l with + | ?l1 && ?l2 => + let r2 := clause l1 r in clause l2 r2 + | _ => constr:(ltac:(is_evar l; exact r)) + | _ => find l r + end + in let r' := clause l r in + instantiate (1 := r'); + rewrite ?Bool.andb_true_l, ?Bool.andb_assoc; + bruteforce_bool_eq +end. -Ltac solve_bool_with_Z := - subst; - rewrite ?truefalse, ?falsetrue, ?or_False_l, ?or_False_r in *; - (* I did try phrasing these as rewrites, but Coq was oddly reluctant to use them *) - repeat match goal with - | H:?x = ?x <-> _ |- _ => apply iff_equal_l in H - | H:_ <-> ?x = ?x |- _ => apply iff_equal_r in H - end; - repeat match goal with - | H:context [?v = true] |- _ => is_var v; rewrite (b2z_true v) in * - | |- context [?v = true] => is_var v; rewrite (b2z_true v) in * - | H:context [?v = false] |- _ => is_var v; rewrite (b2z_false v) in * - | |- context [?v = false] => is_var v; rewrite (b2z_false v) in * - end; - repeat match goal with - | _:context [Z.b2z ?v] |- _ => generalize (b2z_tf v); generalize dependent (Z.b2z v) - | |- context [Z.b2z ?v] => generalize (b2z_tf v); generalize dependent (Z.b2z v) - end; - intros; - lia. (* Redefine this to add extra solver tactics *) @@ -1756,7 +1978,6 @@ Ltac main_solver := repeat match goal with H:@ex _ _ |- _ => destruct H end; guess_ex_solver end - | match goal with |- @ex _ _ => guess_ex_solver end (* While firstorder was quite effective at dealing with existentially quantified goals from boolean expressions, it attempts lazy normalization of terms, which blows up on integer comparisons with large constants. @@ -1764,6 +1985,9 @@ Ltac main_solver := (* Don't use auto for the fallback to keep runtime down *) firstorder fail end*) + | bool_ex_solve + | clause_matching_bool_solver + | match goal with |- @ex _ _ => guess_ex_solver end | sail_extra_tactic | idtac "Unable to solve constraint"; dump_context; fail ]. @@ -1777,21 +2001,134 @@ Ltac simple_omega := end; omega. Ltac solve_unknown := - match goal with |- (ArithFact (?x ?y)) => + match goal with + | |- (ArithFact (?x ?y)) => + is_evar x; + idtac "Warning: unknown constraint"; + let t := type of y in + unify x (fun (_ : t) => true); + exact (Build_ArithFactP _ eq_refl : ArithFact true) + | |- (ArithFactP (?x ?y)) => is_evar x; idtac "Warning: unknown constraint"; let t := type of y in unify x (fun (_ : t) => True); - exact (Build_ArithFact _ I) + exact (Build_ArithFactP _ I : ArithFactP True) end. +(* Solving straightforward and_boolMP / or_boolMP goals *) + +Lemma default_and_proof l r r' : + (l = true -> r' = r) -> + l && r' = l && r. + intro H. +destruct l; [specialize (H eq_refl) | clear H ]; auto. +Qed. + +Lemma default_and_proof2 l l' r r' : + l' = l -> + (l = true -> r' = r) -> + l' && r' = l && r. +intros; subst. +auto using default_and_proof. +Qed. + +Lemma default_or_proof l r r' : + (l = false -> r' = r) -> + l || r' = l || r. + intro H. +destruct l; [clear H | specialize (H eq_refl) ]; auto. +Qed. + +Lemma default_or_proof2 l l' r r' : + l' = l -> + (l = false -> r' = r) -> + l' || r' = l || r. +intros; subst. +auto using default_or_proof. +Qed. + +Ltac default_andor := + intros; constructor; intros; + repeat match goal with + | H:@ex _ _ |- _ => destruct H + | H:@eq bool _ _ -> @ex bool _ |- _ => apply lift_bool_exists in H + end; + repeat match goal with |- @ex _ _ => eexists end; + rewrite ?Bool.eqb_true_iff, ?Bool.eqb_false_iff in *; + match goal with + | H:?v = true -> _ |- _ = ?v && _ => eapply default_and_proof; eauto + | H:?v = true -> _ |- _ = ?v && _ => eapply default_and_proof2; eauto + | H:?v = false -> _ |- _ = ?v || _ => eapply default_or_proof; eauto + | H:?v = false -> _ |- _ = ?v || _ => eapply default_or_proof2; eauto + end. + +(* Solving simple and_boolMP / or_boolMP goals where unknown booleans + have been merged together. *) + +Ltac squashed_andor_solver := + clear; + match goal with |- forall l r : bool, ArithFactP (_ -> _ -> _) => idtac end; + intros l r; constructor; intros; + let func := match goal with |- context[?f l r] => f end in + match goal with + | H1 : @ex _ _, H2 : l = _ -> @ex _ _ |- _ => + let x1 := fresh "x1" in + let x2 := fresh "x2" in + let H1' := fresh "H1" in + let H2' := fresh "H2" in + apply lift_bool_exists in H2; + destruct H1 as [x1 H1']; destruct H2 as [x2 H2']; + exists x1, x2 + | H : l = _ -> @ex _ _ |- _ => + let x := fresh "x" in + let H' := fresh "H" in + apply lift_bool_exists in H; + destruct H as [x H']; + exists (func x l) + | H : @ex _ _ |- _ => + let x := fresh "x" in + let H' := fresh "H" in + destruct H as [x H']; + exists (func x r) + end; + repeat match goal with + | H : l = _ -> @ex _ _ |- _ => + let x := fresh "x" in + let H' := fresh "H" in + apply lift_bool_exists in H; + destruct H as [x H']; + exists x + | H : @ex _ _ |- _ => + let x := fresh "x" in + let H' := fresh "H" in + destruct H as [x H']; + exists x + end; + (* Attempt to shrink size of problem *) + try match goal with + | _ : l = _ -> ?v = r |- context[?v] => generalize dependent v; intros + | _ : l = _ -> Bool.eqb ?v r = true |- context[?v] => generalize dependent v; intros + end; + unbool_comparisons; unbool_comparisons_goal; + repeat match goal with + | _ : context[?li =? ?ri] |- _ => + specialize (Z.eqb_eq li ri); generalize dependent (li =? ri); intros + | |- context[?li =? ?ri] => + specialize (Z.eqb_eq li ri); generalize (li =? ri); intros + end; + rewrite <- ?Z.eqb_eq in *; + solve_bool_with_Z. + Ltac run_main_solver_impl := (* Attempt a simple proof first to avoid lengthy preparation steps (especially as the large proof terms can upset subsequent proofs). *) -try (constructor; simple_omega); +try solve [default_andor]; +constructor; +try simple_omega; prepare_for_solver; (*dump_context;*) -constructor; +unbool_comparisons_goal; (* Applying the ArithFact constructor will reveal an = true, so this might do more than it did in prepare_for_solver *) repeat match goal with |- and _ _ => split end; main_solver. @@ -1813,18 +2150,31 @@ Ltac clear_fixpoints := match goal with | H:_ -> ?res |- _ => is_fixpoint res; clear H end. +Ltac clear_proof_bodies := + repeat match goal with + | H := _ : ?ty |- _ => + match type of ty with + | Prop => clearbody H + end + end. Ltac solve_arithfact := + clear_proof_bodies; + try solve [squashed_andor_solver]; (* Do this first so that it can name the intros *) intros; (* To solve implications for derive_m *) clear_fixpoints; (* Avoid using recursive calls *) + cbv beta; (* Goal might be eta-expanded *) solve [ solve_unknown - | match goal with |- ArithFact (?x <= ?x <= ?x) => exact trivial_range end + | assumption + | match goal with |- ArithFact ((?x <=? ?x <=? ?x)) => exact trivial_range end + | eauto 2 with sail (* the low search bound might not be necessary *) | fill_in_evar_eq | match goal with |- context [projT1 ?X] => apply (ArithFact_self_proof X) end + | match goal with |- context [projT1 ?X] => apply (ArithFactP_self_proof X) end (* Trying reflexivity will fill in more complex metavariable examples than - fill_in_evar_eq above, e.g., 8 * n = 8 * ?Goal3 *) - | constructor; reflexivity + fill_in_evar_eq above, e.g., 8 * n =? 8 * ?Goal3 *) + | constructor; apply Z.eqb_eq; reflexivity | constructor; repeat match goal with |- and _ _ => split end; z_comparisons | run_main_solver ]. @@ -1834,6 +2184,7 @@ Ltac solve_arithfact := Ltac run_solver := solve_arithfact. Hint Extern 0 (ArithFact _) => run_solver : typeclass_instances. +Hint Extern 0 (ArithFactP _) => run_solver : typeclass_instances. Hint Unfold length_mword : sail. @@ -1853,13 +2204,11 @@ auto using Z.le_ge, Zle_0_pos. destruct w. Qed. -Hint Extern 0 (ReasonableSize ?A) => (unwrap_ArithFacts; solve [apply ReasonableSize_witness; assumption | constructor; omega]) : typeclass_instances. +Hint Extern 0 (ReasonableSize ?A) => (unwrap_ArithFacts; solve [apply ReasonableSize_witness; assumption | constructor; auto with zarith]) : typeclass_instances. -Definition to_range (x : Z) : {y : Z & ArithFact (x <= y <= x)} := build_ex x. +Definition to_range (x : Z) : {y : Z & ArithFact ((x <=? y <=? x))} := build_ex x. - - -Instance mword_Bitvector {a : Z} `{ArithFact (a >= 0)} : (Bitvector (mword a)) := { +Instance mword_Bitvector {a : Z} `{ArithFact (a >=? 0)} : (Bitvector (mword a)) := { bits_of v := List.map bitU_of_bool (bitlistFromWord (get_word v)); of_bits v := option_map (fun bl => to_word isPositive (fit_bbv_word (wordFromBitlist bl))) (just_list (List.map bool_of_bitU v)); of_bools v := to_word isPositive (fit_bbv_word (wordFromBitlist v)); @@ -2192,7 +2541,7 @@ Fixpoint foreach_Z' {Vars} from to step n (vars : Vars) (body : Z -> Vars -> Var Definition foreach_Z {Vars} from to step vars body := foreach_Z' (Vars := Vars) from to step (S (Z.abs_nat (from - to))) vars body. -Fixpoint foreach_Z_up' {Vars} from to step off n `{ArithFact (0 < step)} `{ArithFact (0 <= off)} (vars : Vars) (body : forall (z : Z) `(ArithFact (from <= z <= to)), Vars -> Vars) {struct n} : Vars := +Fixpoint foreach_Z_up' {Vars} (from to step off : Z) (n:nat) `{ArithFact (0 <? step)} `{ArithFact (0 <=? off)} (vars : Vars) (body : forall (z : Z) `(ArithFact ((from <=? z <=? to))), Vars -> Vars) {struct n} : Vars := if sumbool_of_bool (from + off <=? to) then match n with | O => vars @@ -2200,7 +2549,7 @@ Fixpoint foreach_Z_up' {Vars} from to step off n `{ArithFact (0 < step)} `{Arith end else vars. -Fixpoint foreach_Z_down' {Vars} from to step off n `{ArithFact (0 < step)} `{ArithFact (off <= 0)} (vars : Vars) (body : forall (z : Z) `(ArithFact (to <= z <= from)), Vars -> Vars) {struct n} : Vars := +Fixpoint foreach_Z_down' {Vars} from to step off n `{ArithFact (0 <? step)} `{ArithFact (off <=? 0)} (vars : Vars) (body : forall (z : Z) `(ArithFact ((to <=? z <=? from))), Vars -> Vars) {struct n} : Vars := if sumbool_of_bool (to <=? from + off) then match n with | O => vars @@ -2208,9 +2557,9 @@ Fixpoint foreach_Z_down' {Vars} from to step off n `{ArithFact (0 < step)} `{Ari end else vars. -Definition foreach_Z_up {Vars} from to step vars body `{ArithFact (0 < step)} := +Definition foreach_Z_up {Vars} from to step vars body `{ArithFact (0 <? step)} := foreach_Z_up' (Vars := Vars) from to step 0 (S (Z.abs_nat (from - to))) vars body. -Definition foreach_Z_down {Vars} from to step vars body `{ArithFact (0 < step)} := +Definition foreach_Z_down {Vars} from to step vars body `{ArithFact (0 <? step)} := foreach_Z_down' (Vars := Vars) from to step 0 (S (Z.abs_nat (from - to))) vars body. (*val while : forall vars. vars -> (vars -> bool) -> (vars -> vars) -> vars @@ -2303,27 +2652,27 @@ end (* Arithmetic functions which return proofs that match the expected Sail types in smt.sail. *) -Definition ediv_with_eq n m : {o : Z & ArithFact (o = ZEuclid.div n m)} := build_ex (ZEuclid.div n m). -Definition emod_with_eq n m : {o : Z & ArithFact (o = ZEuclid.modulo n m)} := build_ex (ZEuclid.modulo n m). -Definition abs_with_eq n : {o : Z & ArithFact (o = Z.abs n)} := build_ex (Z.abs n). +Definition ediv_with_eq n m : {o : Z & ArithFact (o =? ZEuclid.div n m)} := build_ex (ZEuclid.div n m). +Definition emod_with_eq n m : {o : Z & ArithFact (o =? ZEuclid.modulo n m)} := build_ex (ZEuclid.modulo n m). +Definition abs_with_eq n : {o : Z & ArithFact (o =? Z.abs n)} := build_ex (Z.abs n). (* Similarly, for ranges (currently in MIPS) *) -Definition eq_range {n m o p} (l : {l & ArithFact (n <= l <= m)}) (r : {r & ArithFact (o <= r <= p)}) : bool := +Definition eq_range {n m o p} (l : {l & ArithFact (n <=? l <=? m)}) (r : {r & ArithFact (o <=? r <=? p)}) : bool := (projT1 l) =? (projT1 r). -Definition add_range {n m o p} (l : {l & ArithFact (n <= l <= m)}) (r : {r & ArithFact (o <= r <= p)}) - : {x & ArithFact (n+o <= x <= m+p)} := +Definition add_range {n m o p} (l : {l & ArithFact (n <=? l <=? m)}) (r : {r & ArithFact (o <=? r <=? p)}) + : {x & ArithFact (n+o <=? x <=? m+p)} := build_ex ((projT1 l) + (projT1 r)). -Definition sub_range {n m o p} (l : {l & ArithFact (n <= l <= m)}) (r : {r & ArithFact (o <= r <= p)}) - : {x & ArithFact (n-p <= x <= m-o)} := +Definition sub_range {n m o p} (l : {l & ArithFact (n <=? l <=? m)}) (r : {r & ArithFact (o <=? r <=? p)}) + : {x & ArithFact (n-p <=? x <=? m-o)} := build_ex ((projT1 l) - (projT1 r)). -Definition negate_range {n m} (l : {l : Z & ArithFact (n <= l <= m)}) - : {x : Z & ArithFact ((- m) <= x <= (- n))} := +Definition negate_range {n m} (l : {l : Z & ArithFact (n <=? l <=? m)}) + : {x : Z & ArithFact ((- m) <=? x <=? (- n))} := build_ex (- (projT1 l)). -Definition min_atom (a : Z) (b : Z) : {c : Z & ArithFact ((c = a \/ c = b) /\ c <= a /\ c <= b)} := +Definition min_atom (a : Z) (b : Z) : {c : Z & ArithFact (((c =? a) || (c =? b)) && (c <=? a) && (c <=? b))} := build_ex (Z.min a b). -Definition max_atom (a : Z) (b : Z) : {c : Z & ArithFact ((c = a \/ c = b) /\ c >= a /\ c >= b)} := +Definition max_atom (a : Z) (b : Z) : {c : Z & ArithFact (((c =? a) || (c =? b)) && (c >=? a) && (c >=? b))} := build_ex (Z.max a b). @@ -2331,15 +2680,18 @@ Definition max_atom (a : Z) (b : Z) : {c : Z & ArithFact ((c = a \/ c = b) /\ c Definition vec (T:Type) (n:Z) := { l : list T & length_list l = n }. Definition vec_length {T n} (v : vec T n) := n. -Definition vec_access_dec {T n} (v : vec T n) m `{ArithFact (0 <= m < n)} : T := +Definition vec_access_dec {T n} (v : vec T n) m `{ArithFact ((0 <=? m <? n))} : T := access_list_dec (projT1 v) m. -Definition vec_access_inc {T n} (v : vec T n) m `{ArithFact (0 <= m < n)} : T := + +Definition vec_access_inc {T n} (v : vec T n) m `{ArithFact (0 <=? m <? n)} : T := access_list_inc (projT1 v) m. -Program Definition vec_init {T} (t : T) (n : Z) `{ArithFact (n >= 0)} : vec T n := +Program Definition vec_init {T} (t : T) (n : Z) `{ArithFact (n >=? 0)} : vec T n := existT _ (repeat [t] n) _. Next Obligation. -rewrite repeat_length; auto using fact. +intros. +cbv beta. +rewrite repeat_length. 2: apply Z_geb_ge, fact. unfold length_list. simpl. auto with zarith. @@ -2387,21 +2739,25 @@ rewrite skipn_length; omega. Qed. -Program Definition vec_update_dec {T n} (v : vec T n) m t `{ArithFact (0 <= m < n)} : vec T n := existT _ (update_list_dec (projT1 v) m t) _. +Program Definition vec_update_dec {T n} (v : vec T n) m t `{ArithFact (0 <=? m <? n)} : vec T n := existT _ (update_list_dec (projT1 v) m t) _. Next Obligation. +intros; cbv beta. unfold update_list_dec. rewrite update_list_inc_length. + destruct v. apply e. -+ destruct H. ++ destruct H as [H]. + unbool_comparisons. destruct v. simpl (projT1 _). rewrite e. omega. Qed. -Program Definition vec_update_inc {T n} (v : vec T n) m t `{ArithFact (0 <= m < n)} : vec T n := existT _ (update_list_inc (projT1 v) m t) _. +Program Definition vec_update_inc {T n} (v : vec T n) m t `{ArithFact (0 <=? m <? n)} : vec T n := existT _ (update_list_inc (projT1 v) m t) _. Next Obligation. +intros; cbv beta. rewrite update_list_inc_length. + destruct v. apply e. + destruct H. + unbool_comparisons. destruct v. simpl (projT1 _). rewrite e. omega. Qed. @@ -2421,6 +2777,7 @@ Program Definition just_vec {A n} (v : vec (option A) n) : option (vec A n) := | Some v' => Some (existT _ v' _) end. Next Obligation. +intros; cbv beta. rewrite <- (just_list_length_Z _ _ Heq_anonymous). destruct v. assumption. @@ -2436,9 +2793,10 @@ refine (if List.list_eq_dec D (projT1 x) (projT1 y) then left _ else right _). Defined. Instance Decidable_eq_vec {T : Type} {n} `(DT : forall x y : T, Decidable (x = y)) : - forall x y : vec T n, Decidable (x = y) := { + forall x y : vec T n, Decidable (x = y). +refine (fun x y => {| Decidable_witness := proj1_sig (bool_of_sumbool (vec_eq_dec (fun x y => generic_dec x y) x y)) -}. +|}). destruct (vec_eq_dec _ x y); simpl; split; congruence. Defined. @@ -2458,51 +2816,58 @@ match a with | None => None end. -Definition sub_nat (x : Z) `{ArithFact (x >= 0)} (y : Z) `{ArithFact (y >= 0)} : - {z : Z & ArithFact (z >= 0)} := +Definition sub_nat (x : Z) `{ArithFact (x >=? 0)} (y : Z) `{ArithFact (y >=? 0)} : + {z : Z & ArithFact (z >=? 0)} := let z := x - y in if sumbool_of_bool (z >=? 0) then build_ex z else build_ex 0. -Definition min_nat (x : Z) `{ArithFact (x >= 0)} (y : Z) `{ArithFact (y >= 0)} : - {z : Z & ArithFact (z >= 0)} := +Definition min_nat (x : Z) `{ArithFact (x >=? 0)} (y : Z) `{ArithFact (y >=? 0)} : + {z : Z & ArithFact (z >=? 0)} := build_ex (Z.min x y). -Definition max_nat (x : Z) `{ArithFact (x >= 0)} (y : Z) `{ArithFact (y >= 0)} : - {z : Z & ArithFact (z >= 0)} := +Definition max_nat (x : Z) `{ArithFact (x >=? 0)} (y : Z) `{ArithFact (y >=? 0)} : + {z : Z & ArithFact (z >=? 0)} := build_ex (Z.max x y). -Definition shl_int_8 (x y : Z) `{HE:ArithFact (x = 8)} `{HR:ArithFact (0 <= y <= 3)}: {z : Z & ArithFact (In z [8;16;32;64])}. +Definition shl_int_8 (x y : Z) `{HE:ArithFact (x =? 8)} `{HR:ArithFact (0 <=? y <=? 3)}: {z : Z & ArithFact (member_Z_list z [8;16;32;64])}. refine (existT _ (shl_int x y) _). destruct HE as [HE]. destruct HR as [HR]. -assert (H : y = 0 \/ y = 1 \/ y = 2 \/ y = 3) by omega. +unbool_comparisons. +assert (y = 0 \/ y = 1 \/ y = 2 \/ y = 3) by omega. constructor. intuition (subst; compute; auto). Defined. -Definition shl_int_32 (x y : Z) `{HE:ArithFact (x = 32)} `{HR:ArithFact (In y [0;1])}: {z : Z & ArithFact (In z [32;64])}. +Definition shl_int_32 (x y : Z) `{HE:ArithFact (x =? 32)} `{HR:ArithFact (member_Z_list y [0;1])}: {z : Z & ArithFact (member_Z_list z [32;64])}. refine (existT _ (shl_int x y) _). destruct HE as [HE]. -destruct HR as [[HR1 | [HR2 | []]]]; +destruct HR as [HR]. +constructor. +unbool_comparisons. +destruct HR as [HR | [HR | []]]; subst; compute; -auto using Build_ArithFact. +auto. Defined. -Definition shr_int_32 (x y : Z) `{HE:ArithFact (0 <= x <= 31)} `{HR:ArithFact (y = 1)}: {z : Z & ArithFact (0 <= z <= 15)}. +Definition shr_int_32 (x y : Z) `{HE:ArithFact (0 <=? x <=? 31)} `{HR:ArithFact (y =? 1)}: {z : Z & ArithFact (0 <=? z <=? 15)}. refine (existT _ (shr_int x y) _). -destruct HE as [HE]. -destruct HR as [HR]; -subst. -unfold shr_int. -rewrite <- Z.div2_spec. -constructor. -rewrite Z.div2_div. -specialize (Z.div_mod x 2). -specialize (Z.mod_pos_bound x 2). -generalize (Z.div x 2). -generalize (x mod 2). -intros. -nia. +abstract ( + destruct HE as [HE]; + destruct HR as [HR]; + unbool_comparisons; + subst; + constructor; + unbool_comparisons_goal; + unfold shr_int; + rewrite <- Z.div2_spec; + rewrite Z.div2_div; + specialize (Z.div_mod x 2); + specialize (Z.mod_pos_bound x 2); + generalize (Z.div x 2); + generalize (x mod 2); + intros; + nia). Defined. Lemma shl_8_ge_0 {n} : shl_int 8 n >= 0. diff --git a/lib/coq/Sail2_values_lemmas.v b/lib/coq/Sail2_values_lemmas.v new file mode 100644 index 00000000..ed8b6af0 --- /dev/null +++ b/lib/coq/Sail2_values_lemmas.v @@ -0,0 +1,392 @@ +Require Import Sail2_values. + +(* + +lemma while_domI: + fixes V :: "'vars \<Rightarrow> nat" + assumes "\<And>vars. cond vars \<Longrightarrow> V (body vars) < V vars" + shows "while_dom (vars, cond, body)" + by (induction vars rule: measure_induct_rule[where f = V]) + (use assms in \<open>auto intro: while.domintros\<close>) + +lemma nat_of_int_nat_simps[simp]: "nat_of_int = nat" by (auto simp: nat_of_int_def) + +termination reverse_endianness_list by (lexicographic_order simp add: drop_list_def) +declare reverse_endianness_list.simps[simp del] +declare take_list_def[simp] +declare drop_list_def[simp] +*) +Import ListNotations. +Require Program.Wf. + +Lemma skipn_length T n (xs : list T) : + n <> 0%nat -> + xs <> [] -> + (List.length (skipn n xs) < List.length xs)%nat. +revert n. +induction xs. +* congruence. +* destruct n. + + congruence. + + intros _ _. simpl. + destruct xs. + - destruct n; simpl; auto. + - destruct n; auto. + apply Nat.lt_lt_succ_r. + apply IHxs; congruence. +Qed. + +Program Fixpoint take_chunks {a} (n : nat) (xs : list a) {measure (List.length xs)} : list (list a) := + match xs with + | [] => [] + | _ => match n with O => [] | _ => (firstn n xs)::take_chunks n (skipn n xs) end + end. +Next Obligation. +apply skipn_length; auto. +Qed. + +(* +lemma take_chunks_length_leq_n: "length xs \<le> n \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> take_chunks n xs = [xs]" + by (cases n) auto + +lemma take_chunks_append: "n dvd length a \<Longrightarrow> take_chunks n (a @ b) = take_chunks n a @ take_chunks n b" + by (induction n a rule: take_chunks.induct) (auto simp: dvd_imp_le) + +lemma Suc8_plus8: "Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc x))))))) = 8 + x" + by auto + +lemma byte_chunks_take_chunks_8: + assumes "8 dvd length xs" + shows "byte_chunks xs = Some (take_chunks 8 xs)" +proof - + have Suc8_plus8: "Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc x))))))) = 8 + x" for x + by auto + from assms show ?thesis + by (induction xs rule: byte_chunks.induct) (auto simp: Suc8_plus8 nat_dvd_not_less) +qed + +lemma reverse_endianness_list_rev_take_chunks: + "reverse_endianness_list bits = List.concat (rev (take_chunks 8 bits))" + by (induction "8 :: nat" bits rule: take_chunks.induct) + (auto simp: reverse_endianness_list.simps) + +lemma reverse_endianness_list_simps: + "length bits \<le> 8 \<Longrightarrow> reverse_endianness_list bits = bits" + "length bits > 8 \<Longrightarrow> reverse_endianness_list bits = reverse_endianness_list (drop 8 bits) @ take 8 bits" + by (cases bits; auto simp: reverse_endianness_list_rev_take_chunks)+ + +lemma reverse_endianness_list_append: + assumes "8 dvd length a" + shows "reverse_endianness_list (a @ b) = reverse_endianness_list b @ reverse_endianness_list a" + using assms by (auto simp: reverse_endianness_list_rev_take_chunks take_chunks_append) + +lemma length_reverse_endianness_list[simp]: + "length (reverse_endianness_list l) = length l" + by (induction l rule: reverse_endianness_list.induct) (auto simp: reverse_endianness_list.simps) + +lemma reverse_endianness_list_take_8[simp]: + "reverse_endianness_list (take 8 bits) = take 8 bits" + by (auto simp: reverse_endianness_list_simps) + +lemma reverse_reverse_endianness_list[simp]: + assumes "8 dvd length l" + shows "reverse_endianness_list (reverse_endianness_list l) = l" +proof (use assms in \<open>induction l rule: reverse_endianness_list.induct[case_names Step]\<close>) + case (Step bits) + then show ?case + by (auto simp: reverse_endianness_list.simps[of bits] reverse_endianness_list_append) +qed + +declare repeat.simps[simp del] + +lemma length_repeat[simp]: "length (repeat xs n) = nat n * length xs" +proof (induction xs n rule: repeat.induct[case_names Step]) + case (Step xs n) + then show ?case unfolding repeat.simps[of xs n] + by (auto simp del: mult_Suc simp: mult_Suc[symmetric]) +qed + +lemma nth_repeat: + assumes "i < nat n * length xs" + shows "repeat xs n ! i = xs ! (i mod length xs)" +proof (use assms in \<open>induction xs n arbitrary: i rule: repeat.induct[case_names Step]\<close>) + case (Step xs n i) + show ?case + using Step.prems Step.IH[of "i - length xs"] + unfolding repeat.simps[of xs n] + by (auto simp: nth_append mod_geq[symmetric] nat_diff_distrib diff_mult_distrib) +qed + +termination index_list + by (relation "measure (\<lambda>(i, j, step). nat ((j - i + step) * sgn step))") auto + +lemma index_list_Zero[simp]: "index_list i j 0 = []" + by auto + +lemma index_list_singleton[simp]: "n \<noteq> 0 \<Longrightarrow> index_list i i n = [i]" + by auto + +lemma index_list_simps: + "0 < step \<Longrightarrow> from \<le> to \<Longrightarrow> index_list from to step = from # index_list (from + step) to step" + "0 < step \<Longrightarrow> from > to \<Longrightarrow> index_list from to step = []" + "0 > step \<Longrightarrow> from \<ge> to \<Longrightarrow> index_list from to step = from # index_list (from + step) to step" + "0 > step \<Longrightarrow> from < to \<Longrightarrow> index_list from to step = []" + by auto + +lemma index_list_step1_upto[simp]: "index_list i j 1 = [i..j]" + by (induction i j "1 :: int" rule: index_list.induct) + (auto simp: index_list_simps upto.simps) + +lemma length_upto[simp]: "i \<le> j \<Longrightarrow> length [i..j] = nat (j - i + 1)" + by (induction i j rule: upto.induct) (auto simp: upto.simps) + +lemma nth_upto[simp]: "i + int n \<le> j \<Longrightarrow> [i..j] ! n = i + int n" + by (induction i j arbitrary: n rule: upto.induct) + (auto simp: upto.simps nth_Cons split: nat.splits) + +declare index_list.simps[simp del] + +lemma genlist_add_upt[simp]: "genlist ((+) start) len = [start..<start + len]" + by (auto simp: genlist_def map_add_upt add.commute cong: map_cong) + +lemma just_list_map_Some[simp]: "just_list (map Some v) = Some v" by (induction v) auto + +lemma just_list_None_iff[simp]: "just_list xs = None \<longleftrightarrow> None \<in> set xs" + by (induction xs) (auto split: option.splits) + +lemma just_list_None_member_None: "None \<in> set xs \<Longrightarrow> just_list xs = None" + by auto + +lemma just_list_Some_iff[simp]: "just_list xs = Some ys \<longleftrightarrow> xs = map Some ys" + by (induction xs arbitrary: ys) (auto split: option.splits) + +lemma just_list_cases: + assumes "just_list xs = y" + obtains (None) "None \<in> set xs" and "y = None" + | (Some) ys where "xs = map Some ys" and "y = Some ys" + using assms by (cases y) auto + +lemma repeat_singleton_replicate[simp]: + "repeat [x] n = replicate (nat n) x" +proof (induction n) + case (nonneg n) + have "nat (1 + int m) = Suc m" for m by auto + then show ?case by (induction n) (auto simp: repeat.simps) +next + case (neg n) + then show ?case by (auto simp: repeat.simps) +qed + +lemma and_bit_B1[simp]: "and_bit B1 b = b" + by (cases b) auto + +lemma and_bit_idem[simp]: "and_bit b b = b" + by (cases b) auto + +lemma and_bit_eq_iff: + "and_bit b b' = B0 \<longleftrightarrow> (b = B0 \<or> b' = B0)" + "and_bit b b' = BU \<longleftrightarrow> (b = BU \<or> b' = BU) \<and> b \<noteq> B0 \<and> b' \<noteq> B0" + "and_bit b b' = B1 \<longleftrightarrow> (b = B1 \<and> b' = B1)" + by (cases b; cases b'; auto)+ + +lemma foldl_and_bit_eq_iff: + shows "foldl and_bit b bs = B0 \<longleftrightarrow> (b = B0 \<or> B0 \<in> set bs)" (is ?B0) + and "foldl and_bit b bs = B1 \<longleftrightarrow> (b = B1 \<and> set bs \<subseteq> {B1})" (is ?B1) + and "foldl and_bit b bs = BU \<longleftrightarrow> (b = BU \<or> BU \<in> set bs) \<and> b \<noteq> B0 \<and> B0 \<notin> set bs" (is ?BU) +proof - + have "?B0 \<and> ?B1 \<and> ?BU" + proof (induction bs arbitrary: b) + case (Cons b' bs) + show ?case using Cons.IH by (cases b; cases b') auto + qed auto + then show ?B0 and ?B1 and ?BU by auto +qed + +lemma bool_of_bitU_simps[simp]: + "bool_of_bitU B0 = Some False" + "bool_of_bitU B1 = Some True" + "bool_of_bitU BU = None" + by (auto simp: bool_of_bitU_def) + +lemma bitops_bitU_of_bool[simp]: + "and_bit (bitU_of_bool x) (bitU_of_bool y) = bitU_of_bool (x \<and> y)" + "or_bit (bitU_of_bool x) (bitU_of_bool y) = bitU_of_bool (x \<or> y)" + "xor_bit (bitU_of_bool x) (bitU_of_bool y) = bitU_of_bool ((x \<or> y) \<and> \<not>(x \<and> y))" + "not_bit (bitU_of_bool x) = bitU_of_bool (\<not>x)" + "not_bit \<circ> bitU_of_bool = bitU_of_bool \<circ> Not" + by (auto simp: bitU_of_bool_def not_bit_def) + +lemma image_bitU_of_bool_B0_B1: "bitU_of_bool ` bs \<subseteq> {B0, B1}" + by (auto simp: bitU_of_bool_def split: if_splits) + +lemma bool_of_bitU_bitU_of_bool[simp]: + "bool_of_bitU \<circ> bitU_of_bool = Some" + "bool_of_bitU \<circ> (bitU_of_bool \<circ> f) = Some \<circ> f" + "bool_of_bitU (bitU_of_bool x) = Some x" + by (intro ext, auto simp: bool_of_bitU_def bitU_of_bool_def)+ + +abbreviation "BC_bitU_list \<equiv> instance_Sail2_values_Bitvector_list_dict instance_Sail2_values_BitU_Sail2_values_bitU_dict" +lemmas BC_bitU_list_def = instance_Sail2_values_Bitvector_list_dict_def instance_Sail2_values_BitU_Sail2_values_bitU_dict_def +abbreviation "BC_mword \<equiv> instance_Sail2_values_Bitvector_Machine_word_mword_dict" +lemmas BC_mword_defs = instance_Sail2_values_Bitvector_Machine_word_mword_dict_def + access_mword_def access_mword_inc_def access_mword_dec_def + (*update_mword_def update_mword_inc_def update_mword_dec_def*) + subrange_list_def subrange_list_inc_def subrange_list_dec_def + update_subrange_list_def update_subrange_list_inc_def update_subrange_list_dec_def + +declare size_itself_int_def[simp] +declare size_itself_def[simp] +declare word_size[simp] + +lemma int_of_mword_simps[simp]: + "int_of_mword False w = uint w" + "int_of_mword True w = sint w" + "int_of_bv BC_mword False w = Some (uint w)" + "int_of_bv BC_mword True w = Some (sint w)" + by (auto simp: int_of_mword_def int_of_bv_def BC_mword_defs) + +lemma BC_mword_simps[simp]: + "unsigned_method BC_mword a = Some (uint a)" + "signed_method BC_mword a = Some (sint a)" + "length_method BC_mword (a :: ('a :: len) word) = int (LENGTH('a))" + by (auto simp: BC_mword_defs) + +lemma of_bits_mword_of_bl[simp]: + assumes "just_list (map bool_of_bitU bus) = Some bs" + shows "of_bits_method BC_mword bus = Some (of_bl bs)" + and "of_bits_failwith BC_mword bus = of_bl bs" + using assms by (auto simp: BC_mword_defs of_bits_failwith_def maybe_failwith_def) + +lemma nat_of_bits_aux_bl_to_bin_aux: + "nat_of_bools_aux acc bs = nat (bl_to_bin_aux bs (int acc))" + by (induction acc bs rule: nat_of_bools_aux.induct) + (auto simp: Bit_def intro!: arg_cong[where f = nat] arg_cong2[where f = bl_to_bin_aux] split: if_splits) + +lemma nat_of_bits_bl_to_bin[simp]: + "nat_of_bools bs = nat (bl_to_bin bs)" + by (auto simp: nat_of_bools_def bl_to_bin_def nat_of_bits_aux_bl_to_bin_aux) + +lemma unsigned_bits_of_mword[simp]: + "unsigned_method BC_bitU_list (bits_of_method BC_mword a) = Some (uint a)" + by (auto simp: BC_bitU_list_def BC_mword_defs unsigned_of_bits_def unsigned_of_bools_def) +*) +Definition mem_bytes_of_word {a} (w : mword a) : list (list bitU) := + List.rev (take_chunks 8 (bits_of w)). +(* +lemma mem_bytes_of_bits_mem_bytes_of_word[simp]: + assumes "8 dvd LENGTH('a)" + shows "mem_bytes_of_bits BC_mword (w :: 'a::len word) = Some (mem_bytes_of_word w)" + using assms + by (auto simp: mem_bytes_of_bits_def bytes_of_bits_def BC_mword_defs byte_chunks_take_chunks_8 mem_bytes_of_word_def) + +lemma bits_of_bitU_list[simp]: + "bits_of_method BC_bitU_list v = v" + "of_bits_method BC_bitU_list v = Some v" + by (auto simp: BC_bitU_list_def) + +lemma subrange_list_inc_drop_take: + "subrange_list_inc xs i j = drop (nat i) (take (nat (j + 1)) xs)" + by (auto simp: subrange_list_inc_def split_at_def) + +lemma subrange_list_dec_drop_take: + assumes "i \<ge> 0" and "j \<ge> 0" + shows "subrange_list_dec xs i j = drop (length xs - nat (i + 1)) (take (length xs - nat j) xs)" + using assms unfolding subrange_list_dec_def + by (auto simp: subrange_list_inc_drop_take add.commute diff_diff_add nat_minus_as_int) + +lemma update_subrange_list_inc_drop_take: + assumes "i \<ge> 0" and "j \<ge> i" + shows "update_subrange_list_inc xs i j xs' = take (nat i) xs @ xs' @ drop (nat (j + 1)) xs" + using assms unfolding update_subrange_list_inc_def + by (auto simp: split_at_def min_def) + +lemma update_subrange_list_dec_drop_take: + assumes "j \<ge> 0" and "i \<ge> j" + shows "update_subrange_list_dec xs i j xs' = take (length xs - nat (i + 1)) xs @ xs' @ drop (length xs - nat j) xs" + using assms unfolding update_subrange_list_dec_def update_subrange_list_inc_def + by (auto simp: split_at_def min_def Let_def add.commute diff_diff_add nat_minus_as_int) + +declare access_list_inc_def[simp] + +lemma access_list_dec_rev_nth: + assumes "0 \<le> i" and "nat i < length xs" + shows "access_list_dec xs i = rev xs ! (nat i)" + using assms + by (auto simp: access_list_dec_def rev_nth intro!: arg_cong2[where f = List.nth]) + +lemma access_bv_dec_mword[simp]: + fixes w :: "('a::len) word" + assumes "0 \<le> n" and "nat n < LENGTH('a)" + shows "access_bv_dec BC_mword w n = bitU_of_bool (w !! (nat n))" + using assms unfolding access_bv_dec_def access_list_def + by (auto simp: access_list_dec_rev_nth BC_mword_defs rev_map test_bit_bl) + +lemma access_list_dec_nth[simp]: + assumes "0 \<le> i" + shows "access_list_dec xs i = xs ! (length xs - nat (i + 1))" + using assms + by (auto simp: access_list_dec_def add.commute diff_diff_add nat_minus_as_int) + +lemma update_list_inc_update[simp]: + "update_list_inc xs n x = xs[nat n := x]" + by (auto simp: update_list_inc_def) + +lemma update_list_dec_update[simp]: + "update_list_dec xs n x = xs[length xs - nat (n + 1) := x]" + by (auto simp: update_list_dec_def add.commute diff_diff_add nat_minus_as_int) + +lemma update_list_dec_update_rev: + "0 \<le> n \<Longrightarrow> nat n < length xs \<Longrightarrow> update_list_dec xs n x = rev ((rev xs)[nat n := x])" + by (auto simp: update_list_dec_def add.commute diff_diff_add nat_minus_as_int rev_update) + +lemma access_list_dec_update_list_dec[simp]: + "0 \<le> n \<Longrightarrow> nat n < length xs \<Longrightarrow> access_list_dec (update_list_dec xs n x) n = x" + by (auto simp: access_list_dec_rev_nth update_list_dec_update_rev) + +lemma bools_of_nat_aux_simps[simp]: + "\<And>len. len \<le> 0 \<Longrightarrow> bools_of_nat_aux len x acc = acc" + "\<And>len. bools_of_nat_aux (int (Suc len)) x acc = + bools_of_nat_aux (int len) (x div 2) ((if x mod 2 = 1 then True else False) # acc)" + by auto +declare bools_of_nat_aux.simps[simp del] + +lemma bools_of_nat_aux_bin_to_bl_aux: + "bools_of_nat_aux len n acc = bin_to_bl_aux (nat len) (int n) acc" +proof (cases len) + case (nonneg len') + show ?thesis unfolding nonneg + proof (induction len' arbitrary: n acc) + case (Suc len'' n acc) + then show ?case + using zmod_int[of n 2] + by (auto simp del: of_nat_simps simp add: bin_rest_def bin_last_def zdiv_int) + qed auto +qed auto + +lemma bools_of_nat_bin_to_bl[simp]: + "bools_of_nat len n = bin_to_bl (nat len) (int n)" + by (auto simp: bools_of_nat_def bools_of_nat_aux_bin_to_bl_aux) + +lemma add_one_bool_ignore_overflow_aux_rbl_succ[simp]: + "add_one_bool_ignore_overflow_aux xs = rbl_succ xs" + by (induction xs) auto + +lemma add_one_bool_ignore_overflow_rbl_succ[simp]: + "add_one_bool_ignore_overflow xs = rev (rbl_succ (rev xs))" + unfolding add_one_bool_ignore_overflow_def by auto + +lemma map_Not_bin_to_bl: + "map Not (bin_to_bl_aux len n acc) = bin_to_bl_aux len (-n - 1) (map Not acc)" +proof (induction len arbitrary: n acc) + case (Suc len n acc) + moreover have "(- (n div 2) - 1) = ((-n - 1) div 2)" by auto + moreover have "(n mod 2 = 0) = ((- n - 1) mod 2 = 1)" by presburger + ultimately show ?case by (auto simp: bin_rest_def bin_last_def) +qed auto + +lemma bools_of_int_bin_to_bl[simp]: + "bools_of_int len n = bin_to_bl (nat len) n" + by (auto simp: bools_of_int_def Let_def map_Not_bin_to_bl rbl_succ[unfolded bin_to_bl_def]) + +end +*)
\ No newline at end of file diff --git a/lib/hol/Makefile b/lib/hol/Makefile index c863a05b..ccd871dc 100644 --- a/lib/hol/Makefile +++ b/lib/hol/Makefile @@ -1,7 +1,7 @@ LEM_DIR?=$(shell opam config var lem:share) LEMSRC = \ - ../../src/lem_interp/sail2_instr_kinds.lem \ + ../../src/gen_lib/sail2_instr_kinds.lem \ ../../src/gen_lib/sail2_values.lem \ ../../src/gen_lib/sail2_operators.lem \ ../../src/gen_lib/sail2_operators_mwords.lem \ diff --git a/lib/isabelle/Makefile b/lib/isabelle/Makefile index 465b4c36..42071a8c 100644 --- a/lib/isabelle/Makefile +++ b/lib/isabelle/Makefile @@ -18,17 +18,17 @@ all: thys thys: $(THYS) heap-img: thys $(EXTRA_THYS) ROOT -ifeq ($(wildcard $(LEM_ISA_LIB)/ROOT),) - $(error isabelle-lib directory of Lem not found. Please set the LEM_ISA_LIB environment variable) -endif - isabelle build -b -d $(LEM_ISA_LIB) -D . + if [ -z "$(wildcard $(LEM_ISA_LIB)/ROOT)" ]; \ + then echo isabelle-lib directory of Lem not found. Please set the LEM_ISA_LIB environment variable; false; \ + else isabelle build -b -d $(LEM_ISA_LIB) -D . ; \ + fi manual: heap-img manual/Manual.thy manual/ROOT manual/document/root.tex cp output/document/session_graph.pdf manual/document/Sail_session_graph.pdf make -C $(SAIL_RISCV) riscv_duopod isabelle build -d $(LEM_ISA_LIB) -d . -d $(SAIL_RISCV)/generated_definitions/isabelle -D manual -Sail2_instr_kinds.thy: ../../src/lem_interp/sail2_instr_kinds.lem +Sail2_instr_kinds.thy: ../../src/gen_lib/sail2_instr_kinds.lem lem -isa -outdir . -auxiliary_level none -lib ../../src/lem_interp -lib ../../src/gen_lib $< Sail2_values.thy: ../../src/gen_lib/sail2_values.lem Sail2_instr_kinds.thy diff --git a/lib/main.ml b/lib/main.ml index c1b6fcae..a3541c69 100644 --- a/lib/main.ml +++ b/lib/main.ml @@ -60,7 +60,8 @@ let options = Arg.align [ | [fname;addr] -> (fname, Nat_big_num.of_string addr) | _ -> raise (Arg.Bad (s ^ " not of form <filename>@<addr>")) in opt_raw_files := (file, addr) :: !opt_raw_files), - "<file@0xADDR> load a raw binary in memory at given address.")] + "<file@0xADDR> load a raw binary in memory at given address."); + ("-cycle-limit", Arg.Set_int (Sail_lib.opt_cycle_limit), "<int> exit after given number of instructions executed.")] let usage_msg = "Sail OCaml RTS options:" diff --git a/lib/regfp.sail b/lib/regfp.sail index 070ff524..86b3cf17 100644 --- a/lib/regfp.sail +++ b/lib/regfp.sail @@ -31,6 +31,7 @@ union diafp = { DIAFP_reg : regfp } +$ifdef ARM_SPEC enum read_kind = { Read_plain, Read_reserve, @@ -38,6 +39,7 @@ enum read_kind = { Read_exclusive, Read_exclusive_acquire, Read_stream, + Read_ifetch, Read_RISCV_acquire, Read_RISCV_strong_acquire, Read_RISCV_reserved, @@ -45,6 +47,22 @@ enum read_kind = { Read_RISCV_reserved_strong_acquire, Read_X86_locked } +$else +enum read_kind = { + Read_plain, + Read_reserve, + Read_acquire, + Read_exclusive, + Read_exclusive_acquire, + Read_stream, + Read_RISCV_acquire, + Read_RISCV_strong_acquire, + Read_RISCV_reserved, + Read_RISCV_reserved_acquire, + Read_RISCV_reserved_strong_acquire, + Read_X86_locked +} +$endif enum write_kind = { Write_plain, @@ -142,6 +160,20 @@ val __barrier = { ocaml: "Platform.barrier", c: "platform_barrier", _: "barrier" } : barrier_kind -> unit effect {barr} +val __branch_announce + = { ocaml: "Platform.branch_announce", c: "platform_branch_announce", _ : "branch_announce" } + : forall (constant 'addrsize : Int), 'addrsize in {32, 64}. + (int('addrsize), bits('addrsize)) -> unit + +val __cache_maintenance + = { ocaml: "Platform.cache_maintenance", c: "platform_cache_maintenance", _ : "cache_maintenance" } + : forall (constant 'addrsize : Int), 'addrsize in {32, 64}. + (cache_op_kind, int('addrsize), bits('addrsize)) -> unit + +val __instr_announce + = { ocaml: "Platform.instr_announce", c: "platform_instr_announce", _: "instr_announce" } + : forall 'n, 'n > 0. + bits('n) -> unit /* val __write : forall 'n, 'n > 0. (write_kind, bits(64), int('n), bits(8 * 'n)) -> bool effect {eamem,wmv} @@ -837,6 +837,15 @@ fbits bitvector_access(const lbits op, const sail_int n_mpz) return (fbits) mpz_tstbit(*op.bits, n); } +fbits update_fbits(const fbits op, const uint64_t n, const fbits bit) +{ + if ((bit & 1) == 1) { + return op | (bit << n); + } else { + return op & ~(bit << n); + } +} + void sail_unsigned(sail_int *rop, const lbits op) { /* Normal form of bv_t is always positive so just return the bits. */ @@ -288,6 +288,8 @@ void sail_truncateLSB(lbits *rop, const lbits op, const sail_int len); fbits bitvector_access(const lbits op, const sail_int n_mpz); +fbits update_fbits(const fbits op, const uint64_t n, const fbits bit); + void sail_unsigned(sail_int *rop, const lbits op); void sail_signed(sail_int *rop, const lbits op); @@ -1,6 +1,6 @@ opam-version: "1.2" name: "sail" -version: "0.10" +version: "0.12" maintainer: "Sail Devs <cl-sail-dev@lists.cam.ac.uk>" authors: [ "Alasdair Armstrong" @@ -37,5 +37,6 @@ depends: [ "conf-zlib" "base64" {< "3.0.0"} "yojson" + "pprint" ] available: [ocaml-version >= "4.06.1"] @@ -1,6 +1,6 @@ # META file of package sail: description = "Sail is a language for describing the instruction-set architecture (ISA) semantics of processors." -requires = "linenoise lem linksem omd base64 yojson" +requires = "linenoise lem linksem omd base64 yojson pprint" version = "0.8" archive(byte) = "libsail.cma" archive(native) = "libsail.cmxa" diff --git a/src/Makefile b/src/Makefile index a002d4f3..00475654 100644 --- a/src/Makefile +++ b/src/Makefile @@ -72,7 +72,11 @@ all: sail lib doc full: sail lib doc ast.lem: ../language/sail.ott - ott -sort false -generate_aux_rules true -o ast.lem -picky_multiple_parses true ../language/sail.ott + ott -sort false -generate_aux_rules true -o ast.lem -picky_multiple_parses true ../language/sail.ott + +sail_pp.ml: ../language/sail.ott + ott -sort false -generate_aux_rules true -picky_multiple_parses true -ocaml_pp sail_pp.ml ../language/sail.ott + jib.lem: ../language/jib.ott ast.lem ott -sort false -generate_aux_rules true -o jib.lem -picky_multiple_parses true ../language/jib.ott @@ -2,17 +2,16 @@ true: -traverse, debug, use_menhir <**/parser.ml>: bin_annot, annot <**/*.ml> and not <**/parser.ml>: bin_annot, annot -<sail.{byte,native}>: package(zarith), package(linksem), package(lem), package(omd), package(base64), use_pprint -<isail.{byte,native}>: package(zarith), package(linenoise), package(linksem), package(lem), package(omd), package(base64), package(yojson), use_pprint +<sail.{byte,native}>: package(zarith), package(linksem), package(lem), package(omd), package(base64), package(pprint) +<isail.{byte,native}>: package(zarith), package(linenoise), package(linksem), package(lem), package(omd), package(base64), package(yojson), package(pprint) <isail.ml>: package(linenoise), package(yojson) <elf_loader.ml>: package(linksem) <latex.ml>: package(omd) -<**/*.m{l,li}>: package(lem), package(base64) +<**/*.m{l,li}>: package(lem), package(base64), package(pprint) <gen_lib>: include <jib>: include -<pprint> or <pprint/src>: include # disable partial match and unused variable warnings <**/*.ml>: warn_y diff --git a/src/ast_util.ml b/src/ast_util.ml index 065b443c..e318a423 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -60,7 +60,7 @@ let lvar_typ = function | Local (_, typ) -> typ | Register (_, _, typ) -> typ | Enum typ -> typ - | Unbound -> failwith "No type for unbound variable" + | Unbound -> Reporting.unreachable Parse_ast.Unknown __POS__ "No type for unbound variable" let no_annot = (Parse_ast.Unknown, ()) @@ -847,7 +847,7 @@ and string_of_typ_aux = function | Typ_fn (typ_args, typ_ret, eff) -> "(" ^ string_of_list ", " string_of_typ typ_args ^ ") -> " ^ string_of_typ typ_ret ^ " effect " ^ string_of_effect eff - | Typ_bidir (typ1, typ2) -> string_of_typ typ1 ^ " <-> " ^ string_of_typ typ2 + | Typ_bidir (typ1, typ2, eff) -> string_of_typ typ1 ^ " <-> " ^ string_of_typ typ2 ^ " effect " ^ string_of_effect eff | Typ_exist (kids, nc, typ) -> "{" ^ string_of_list " " string_of_kinded_id kids ^ ", " ^ string_of_n_constraint nc ^ ". " ^ string_of_typ typ ^ "}" and string_of_typ_arg = function @@ -1170,10 +1170,12 @@ and typ_compare (Typ_aux (t1,_)) (Typ_aux (t2,_)) = | 0 -> effect_compare e1 e2 | n -> n) | n -> n) - | Typ_bidir (t1,t2), Typ_bidir (t3,t4) -> + | Typ_bidir (t1,t2,e1), Typ_bidir (t3,t4,e2) -> (match typ_compare t1 t3 with - | 0 -> typ_compare t2 t3 - | n -> n) + | 0 -> (match typ_compare t2 t4 with + | 0 -> effect_compare e1 e2 + | n -> n) + | n -> n) | Typ_tup ts1, Typ_tup ts2 -> Util.compare_list typ_compare ts1 ts2 | Typ_exist (ks1,nc1,t1), Typ_exist (ks2,nc2,t2) -> (match Util.compare_list KOpt.compare ks1 ks2 with @@ -1247,7 +1249,7 @@ let rec lexp_to_exp (LEXP_aux (lexp_aux, annot) as le) = | LEXP_vector_concat [] -> rewrap (E_vector []) | LEXP_vector_concat (lexp :: lexps) -> List.fold_left (fun exp lexp -> rewrap (E_vector_append (exp, lexp_to_exp lexp))) (lexp_to_exp lexp) lexps - | LEXP_deref exp -> rewrap (E_app (mk_id "reg_deref", [exp])) + | LEXP_deref exp -> rewrap (E_app (mk_id "__deref", [exp])) let is_unit_typ = function | Typ_aux (Typ_id u, _) -> string_of_id u = "unit" @@ -1378,7 +1380,7 @@ and kopts_of_typ (Typ_aux (t,_)) = | Typ_id _ -> KOptSet.empty | Typ_var kid -> KOptSet.singleton (mk_kopt K_type kid) | Typ_fn (ts, t, _) -> List.fold_left KOptSet.union (kopts_of_typ t) (List.map kopts_of_typ ts) - | Typ_bidir (t1, t2) -> KOptSet.union (kopts_of_typ t1) (kopts_of_typ t2) + | Typ_bidir (t1, t2, _) -> KOptSet.union (kopts_of_typ t1) (kopts_of_typ t2) | Typ_tup ts -> List.fold_left (fun s t -> KOptSet.union s (kopts_of_typ t)) KOptSet.empty ts @@ -1438,11 +1440,11 @@ and tyvars_of_typ (Typ_aux (t,_)) = | Typ_id _ -> KidSet.empty | Typ_var kid -> KidSet.singleton kid | Typ_fn (ts, t, _) -> List.fold_left KidSet.union (tyvars_of_typ t) (List.map tyvars_of_typ ts) - | Typ_bidir (t1, t2) -> KidSet.union (tyvars_of_typ t1) (tyvars_of_typ t2) + | Typ_bidir (t1, t2, _) -> KidSet.union (tyvars_of_typ t1) (tyvars_of_typ t2) | Typ_tup ts -> List.fold_left (fun s t -> KidSet.union s (tyvars_of_typ t)) KidSet.empty ts - | Typ_app (_,tas) -> + | Typ_app (_,tas) -> List.fold_left (fun s ta -> KidSet.union s (tyvars_of_typ_arg ta)) KidSet.empty tas | Typ_exist (kids, nc, t) -> @@ -1661,6 +1663,41 @@ let hex_to_bin hex = |> List.map Sail_lib.char_of_bit |> (fun bits -> String.init (List.length bits) (List.nth bits)) +let explode s = + let rec exp i l = if i < 0 then l else exp (i - 1) (s.[i] :: l) in + exp (String.length s - 1) [] + +let vector_string_to_bit_list (L_aux (lit, l)) = + + let hexchar_to_binlist = function + | '0' -> ['0';'0';'0';'0'] + | '1' -> ['0';'0';'0';'1'] + | '2' -> ['0';'0';'1';'0'] + | '3' -> ['0';'0';'1';'1'] + | '4' -> ['0';'1';'0';'0'] + | '5' -> ['0';'1';'0';'1'] + | '6' -> ['0';'1';'1';'0'] + | '7' -> ['0';'1';'1';'1'] + | '8' -> ['1';'0';'0';'0'] + | '9' -> ['1';'0';'0';'1'] + | 'A' -> ['1';'0';'1';'0'] + | 'B' -> ['1';'0';'1';'1'] + | 'C' -> ['1';'1';'0';'0'] + | 'D' -> ['1';'1';'0';'1'] + | 'E' -> ['1';'1';'1';'0'] + | 'F' -> ['1';'1';'1';'1'] + | _ -> raise (Reporting.err_unreachable l __POS__ "hexchar_to_binlist given unrecognized character") in + + let s_bin = match lit with + | L_hex s_hex -> List.flatten (List.map hexchar_to_binlist (explode (String.uppercase_ascii s_hex))) + | L_bin s_bin -> explode s_bin + | _ -> raise (Reporting.err_unreachable l __POS__ "s_bin given non vector literal") in + + List.map (function '0' -> L_aux (L_zero, gen_loc l) + | '1' -> L_aux (L_one, gen_loc l) + | _ -> raise (Reporting.err_unreachable (gen_loc l) __POS__ "binary had non-zero or one")) s_bin + + (* Functions for working with locations *) let locate_id f (Id_aux (name, l)) = Id_aux (name, f l) @@ -1726,7 +1763,7 @@ and locate_typ f (Typ_aux (typ_aux, l)) = | Typ_var kid -> Typ_var (locate_kid f kid) | Typ_fn (arg_typs, ret_typ, effect) -> Typ_fn (List.map (locate_typ f) arg_typs, locate_typ f ret_typ, locate_effect f effect) - | Typ_bidir (typ1, typ2) -> Typ_bidir (locate_typ f typ1, locate_typ f typ2) + | Typ_bidir (typ1, typ2, effect) -> Typ_bidir (locate_typ f typ1, locate_typ f typ2, locate_effect f effect) | Typ_tup typs -> Typ_tup (List.map (locate_typ f) typs) | Typ_exist (kopts, constr, typ) -> Typ_exist (List.map (locate_kinded_id f) kopts, locate_nc f constr, locate_typ f typ) | Typ_app (id, typ_args) -> Typ_app (locate_id f id, List.map (locate_typ_arg f) typ_args) @@ -1945,7 +1982,7 @@ and typ_subst_aux sv subst = function | _ -> Typ_var kid end | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst sv subst) arg_typs, typ_subst sv subst ret_typ, effs) - | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst sv subst typ1, typ_subst sv subst typ2) + | Typ_bidir (typ1, typ2, effs) -> Typ_bidir (typ_subst sv subst typ1, typ_subst sv subst typ2, effs) | Typ_tup typs -> Typ_tup (List.map (typ_subst sv subst) typs) | Typ_app (f, args) -> Typ_app (f, List.map (typ_arg_subst sv subst) args) | Typ_exist (kopts, nc, typ) when KidSet.mem sv (KidSet.of_list (List.map kopt_kid kopts)) -> @@ -2043,7 +2080,7 @@ let subst_kids_nc, subst_kids_typ, subst_kids_typ_arg = | Typ_var _ -> ty | Typ_fn (t1,t2,e) -> re (Typ_fn (List.map (s_styp substs) t1, s_styp substs t2,e)) - | Typ_bidir (t1, t2) -> re (Typ_bidir (s_styp substs t1, s_styp substs t2)) + | Typ_bidir (t1,t2,e) -> re (Typ_bidir (s_styp substs t1, s_styp substs t2,e)) | Typ_tup ts -> re (Typ_tup (List.map (s_styp substs) ts)) | Typ_app (id,tas) -> re (Typ_app (id,List.map (s_starg substs) tas)) | Typ_exist (kopts,nc,t) -> diff --git a/src/ast_util.mli b/src/ast_util.mli index f6bf1fcc..6be8ca34 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -472,6 +472,8 @@ val subst : id -> 'a exp -> 'a exp -> 'a exp val hex_to_bin : string -> string +val vector_string_to_bit_list : lit -> lit list + (** {2 Manipulating locations} *) (** locate takes an expression and recursively sets the location in diff --git a/src/constant_fold.ml b/src/constant_fold.ml index 7a7067ef..35417ac8 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -91,7 +91,7 @@ and exp_of_value = let safe_primops = List.fold_left (fun m k -> StringMap.remove k m) - Value.primops + !Value.primops [ "print_endline"; "prerr_endline"; "putchar"; @@ -191,7 +191,17 @@ let rec run frame = let initial_state ast env = Interpreter.initial_state ~registers:false ast env safe_primops -let rw_exp target ok not_ok istate = +type fixed = { + registers: tannot exp Bindings.t; + fields: tannot exp Bindings.t Bindings.t; + } + +let no_fixed = { + registers = Bindings.empty; + fields = Bindings.empty; + } + +let rw_exp fixed target ok not_ok istate = let evaluate e_aux annot = let initial_monad = Interpreter.return (E_aux (e_aux, annot)) in try @@ -219,6 +229,34 @@ let rw_exp target ok not_ok istate = | E_app (id, args) when fold_to_unit id -> ok (); E_aux (E_lit (L_aux (L_unit, fst annot)), annot) + | E_id id -> + begin match Bindings.find_opt id fixed.registers with + | Some exp -> + ok (); exp + | None -> + E_aux (e_aux, annot) + end + + | E_field (E_aux (E_id id, _), field) -> + begin match Bindings.find_opt id fixed.fields with + | Some fields -> + begin match Bindings.find_opt field fields with + | Some exp -> + ok (); exp + | None -> + E_aux (e_aux, annot) + end + | None -> + E_aux (e_aux, annot) + end + + (* Short-circuit boolean operators with constants *) + | E_app (id, [(E_aux (E_lit (L_aux (L_false, _)), _) as false_exp); _]) when string_of_id id = "and_bool" -> + ok (); false_exp + + | E_app (id, [(E_aux (E_lit (L_aux (L_true, _)), _) as true_exp); _]) when string_of_id id = "or_bool" -> + ok (); true_exp + | E_app (id, args) when List.for_all is_constant args -> let env = env_of_annot annot in (* We want to fold all primitive operations, but avoid folding @@ -252,9 +290,9 @@ let rw_exp target ok not_ok istate = in fold_exp { id_exp_alg with e_aux = (fun (e_aux, annot) -> rw_funcall e_aux annot)} -let rewrite_exp_once target = rw_exp target (fun _ -> ()) (fun _ -> ()) +let rewrite_exp_once target = rw_exp no_fixed target (fun _ -> ()) (fun _ -> ()) -let rec rewrite_constant_function_calls' target ast = +let rec rewrite_constant_function_calls' fixed target ast = let rewrite_count = ref 0 in let ok () = incr rewrite_count in let not_ok () = decr rewrite_count in @@ -262,16 +300,78 @@ let rec rewrite_constant_function_calls' target ast = let rw_defs = { rewriters_base with - rewrite_exp = (fun _ -> rw_exp target ok not_ok istate) + rewrite_exp = (fun _ -> rw_exp fixed target ok not_ok istate) } in let ast = rewrite_defs_base rw_defs ast in (* We keep iterating until we have no more re-writes to do *) if !rewrite_count > 0 - then rewrite_constant_function_calls' target ast + then rewrite_constant_function_calls' fixed target ast else ast -let rewrite_constant_function_calls target ast = +let rewrite_constant_function_calls fixed target ast = if !optimize_constant_fold then - rewrite_constant_function_calls' target ast + rewrite_constant_function_calls' fixed target ast else ast + +type to_constant = + | Register of id * typ * tannot exp + | Register_field of id * id * typ * tannot exp + +let () = + let open Interactive in + let open Printf in + + let update_fixed fixed = function + | Register (id, _, exp) -> + { fixed with registers = Bindings.add id exp fixed.registers } + | Register_field (id, field, _, exp) -> + let prev_fields = match Bindings.find_opt id fixed.fields with Some f -> f | None -> Bindings.empty in + let updated_fields = Bindings.add field exp prev_fields in + { fixed with fields = Bindings.add id updated_fields fixed.fields } + in + + ArgString ("target", fun target -> ArgString ("assignments", fun assignments -> Action (fun () -> + let assignments = Str.split (Str.regexp " +") assignments in + let assignments = + List.map (fun assignment -> + match String.split_on_char '=' assignment with + | [reg; value] -> + begin match String.split_on_char '.' reg with + | [reg; field] -> + let reg = mk_id reg in + let field = mk_id field in + begin match Env.lookup_id reg !env with + | Register (_, _, Typ_aux (Typ_id rec_id, _)) -> + let (_, fields) = Env.get_record rec_id !env in + let typ = match List.find_opt (fun (typ, id) -> Id.compare id field = 0) fields with + | Some (typ, _) -> typ + | None -> failwith (sprintf "Register %s does not have a field %s" (string_of_id reg) (string_of_id field)) + in + let exp = Initial_check.exp_of_string value in + let exp = check_exp !env exp typ in + Register_field (reg, field, typ, exp) + | _ -> + failwith (sprintf "Register %s is not defined as a record in the current environment" (string_of_id reg)) + end + | _ -> + let reg = mk_id reg in + begin match Env.lookup_id reg !env with + | Register (_, _, typ) -> + let exp = Initial_check.exp_of_string value in + let exp = check_exp !env exp typ in + Register (reg, typ, exp) + | _ -> + failwith (sprintf "Register %s is not defined in the current environment" (string_of_id reg)) + end + end + | _ -> failwith (sprintf "Could not parse '%s' as an assignment <register>=<value>" assignment) + ) assignments in + let assignments = List.fold_left update_fixed no_fixed assignments in + + ast := rewrite_constant_function_calls' assignments target !ast))) + |> register_command + ~name:"fix_registers" + ~help:"Fix the value of specified registers, specified as a \ + list of <register>=<value>. Can also fix a specific \ + register field as <register>.<field>=<value>." diff --git a/src/constant_propagation_mutrec.ml b/src/constant_propagation_mutrec.ml index 6cc6d28c..03d8e154 100644 --- a/src/constant_propagation_mutrec.ml +++ b/src/constant_propagation_mutrec.ml @@ -97,7 +97,8 @@ let generate_fun_id id args = that will be propagated in *) let generate_val_spec env id args l annot = match Env.get_val_spec_orig id env with - | tq, Typ_aux (Typ_fn (arg_typs, ret_typ, eff), _) -> + | tq, (Typ_aux (Typ_fn (arg_typs, ret_typ, eff), _) as fn_typ) -> + (* Get instantiation of type variables at call site *) let orig_ksubst (kid, typ_arg) = match typ_arg with | A_aux ((A_nexp _ | A_bool _), _) -> (orig_kid kid, typ_arg) @@ -110,21 +111,38 @@ let generate_val_spec env id args l annot = |> List.map orig_ksubst |> List.fold_left (fun s (v,i) -> KBindings.add v i s) KBindings.empty in + (* Apply instantiation to original function type. Also collect the + type variables in the new type together their kinds for the new + val spec. *) + let kopts_of_typ env typ = + tyvars_of_typ typ |> KidSet.elements + |> List.map (fun kid -> mk_kopt (Env.get_typ_var kid env) kid) + |> KOptSet.of_list + in let ret_typ' = KBindings.fold typ_subst ksubsts ret_typ in - let arg_typs' = - List.map (KBindings.fold typ_subst ksubsts) arg_typs - |> List.map2 (fun arg typ -> if is_const_exp arg then [] else [typ]) args - |> List.concat - |> function [] -> [unit_typ] | typs -> typs + let (arg_typs', kopts') = + List.fold_right2 (fun arg typ (arg_typs', kopts') -> + if is_const_exp arg then + (arg_typs', kopts') + else + let typ' = KBindings.fold typ_subst ksubsts typ in + let arg_kopts = kopts_of_typ (env_of arg) typ' in + (typ' :: arg_typs', KOptSet.union arg_kopts kopts')) + args arg_typs ([], kopts_of_typ (env_of_tannot annot) ret_typ') in + let arg_typs' = if arg_typs' = [] then [unit_typ] else arg_typs' in let typ' = mk_typ (Typ_fn (arg_typs', ret_typ', eff)) in - let tyvars = tyvars_of_typ typ' in - let tq' = - quant_items tq |> - List.filter (fun qi -> KidSet.subset (tyvars_of_quant_item qi) tyvars) |> - mk_typquant + (* Construct new val spec *) + let constraints' = + quant_split tq |> snd + |> List.map (KBindings.fold constraint_subst ksubsts) + |> List.filter (fun nc -> KidSet.subset (tyvars_of_constraint nc) (tyvars_of_typ typ')) + in + let quant_items' = + List.map mk_qi_kopt (KOptSet.elements kopts') @ + List.map mk_qi_nc constraints' in - let typschm = mk_typschm tq' typ' in + let typschm = mk_typschm (mk_typquant quant_items') typ' in mk_val_spec (VS_val_spec (typschm, generate_fun_id id args, [], false)), ksubsts | _, Typ_aux (_, l) -> diff --git a/src/gdbmi.ml b/src/gdbmi.ml new file mode 100644 index 00000000..faf3ac11 --- /dev/null +++ b/src/gdbmi.ml @@ -0,0 +1,257 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Printf +open Gdbmi_types + +let parse_gdb_response str = + let lexbuf = Lexing.from_string str in + Gdbmi_parser.response_eof Gdbmi_lexer.token lexbuf + +type gdb_session = (in_channel * out_channel * in_channel) option + +let gdb_command = ref "gdb-multiarch" + +let gdb_token_counter = ref 0 + +let gdb_token () = + incr gdb_token_counter; + !gdb_token_counter + +let not_connected = Reporting.err_general Parse_ast.Unknown "Not connected to gdb" + +let rec wait_for' regexp stdout = + let line = input_line stdout in + if Str.string_match regexp line 0 then ( + line + ) else ( + print_endline Util.(line |> dim |> clear); + wait_for' regexp stdout + ) + +let wait_for token stdout = + let regexp = Str.regexp (sprintf "^%i\\^" token) in + wait_for' regexp stdout + +let wait_for_gdb stdout = + let regexp = Str.regexp_string "(gdb)" in + wait_for' regexp stdout + +let send_sync session cmd = + match session with + | None -> raise not_connected + | Some (stdout, stdin, _) -> + let token = gdb_token () in + let cmd = sprintf "%i-%s\n" token cmd in + print_string Util.(cmd |> yellow |> clear); + flush stdin; + output_string stdin cmd; + flush stdin; + wait_for token stdout + +let send_regular session cmd = + match session with + | None -> raise not_connected + | Some (stdout, stdin, _) -> + let token = gdb_token () in + print_endline Util.(cmd |> yellow |> clear); + flush stdin; + output_string stdin (cmd ^ "\n"); + flush stdin; + ignore (wait_for_gdb stdout) + +let synced_registers = ref [] + +let gdb_sync session = + let gdb_register_names = parse_gdb_response (send_sync session "data-list-register-names") in + let gdb_register_values = parse_gdb_response (send_sync session "data-list-register-values x") in + let names = match gdb_register_names with + | Result (_, "done", output) -> + List.assoc "register-names" output |> gdb_seq |> List.map gdb_string + | _ -> failwith "GDB could not get register names" + in + let values = match gdb_register_values with + | Result (_, "done", output) -> + List.assoc "register-values" output + |> gdb_seq + |> List.map gdb_assoc + |> List.map (List.assoc "value") + |> List.map gdb_string + | _ -> failwith "GDB could not get register names" + in + synced_registers := List.combine names values + +let gdb_list_registers session = + gdb_sync session; + List.iter (fun (name, value) -> + print_endline (sprintf "%s: %s" name value) + ) !synced_registers + +let gdb_read_mem session addr data_size = + let open Value in + let cmd = sprintf "data-read-memory %s x 1 1 %i" (Sail_lib.string_of_bits addr) (Big_int.to_int data_size) in + (* An example response looks something like: + + 7^done,addr="0x0000000040009e64",nr-bytes="4",total-bytes="4",next-row="0x0000000040009e68", + prev-row="0x0000000040009e60",next-page="0x0000000040009e68",prev-page="0x0000000040009e60", + memory=[{addr="0x0000000040009e64",data=["0x03","0xfc","0x5a","0xd3"]}] + *) + match parse_gdb_response (send_sync session cmd) with + | Result (_, "done", output) -> + List.assoc "memory" output |> gdb_seq + |> List.hd |> gdb_assoc + |> List.assoc "data" |> gdb_seq + |> List.rev_map (fun byte -> Sail_lib.byte_of_int (int_of_string (gdb_string byte))) + |> List.concat + + | _ -> failwith "Unexpected response from GDB" + +let value_gdb_read_ram session = + let open Value in + function + | [addr_size; data_size; _; addr] -> + mk_vector (gdb_read_mem session (coerce_bv addr) (coerce_int data_size)) + + | _ -> failwith "gdb_read_ram" + +let gdb_effect_interp session state eff = + let open Value in + let open Interpreter in + let lstate, gstate = state in + match eff with + | Read_mem (rk, addr, len, cont) -> + let result = mk_vector (gdb_read_mem session (coerce_bv addr) (coerce_int len)) in + cont result state + | Read_reg (name, cont) -> + begin match List.assoc_opt name !synced_registers with + | Some value -> + let value = mk_vector (Sail_lib.to_bits' (64, Big_int.of_string value)) in + cont value state + | None -> + cont (Bindings.find (mk_id name) gstate.registers) state + end + | Write_reg (name, v, cont) -> + let id = mk_id name in + if Bindings.mem id gstate.registers then + let state' = (lstate, { gstate with registers = Bindings.add id v gstate.registers }) in + cont () state' + else + failwith ("Write of nonexistent register: " ^ name) + | _ -> + failwith "Unsupported in GDB state" + +let gdb_hooks session = + Value.add_primop "read_ram" (value_gdb_read_ram session); + Interpreter.set_effect_interp (gdb_effect_interp session) + +let () = + let open Interactive in + let session = ref None in + + let gdb_start arg = + let stdout, stdin, stderr = Unix.open_process_full (sprintf "%s --interpreter=mi" !gdb_command) [||] in + session := Some (stdout, stdin, stderr); + wait_for_gdb stdout |> ignore; + if arg = "" then () else print_endline (send_sync !session arg) + in + + let gdb_send arg = + if arg = "" then () else print_endline (send_sync !session arg) + in + + register_command + ~name:"gdb_command" + ~help:"Use specified gdb. Default is gdb-multiarch. This is the \ + correct version on Ubuntu, but other Linux distros and \ + operating systems may differ in how they package gdb with \ + support for multiple architectures." + (ArgString ("gdb", fun arg -> Action (fun () -> gdb_command := arg))); + + register_command + ~name:"gdb_start" + ~help:"Start a child GDB process sending :0 as the first command, waiting for it to complete" + (ArgString ("command", fun cmd -> Action (fun () -> gdb_start cmd))); + + (ArgString ("port", fun port -> Action (fun () -> + if port = "" then + gdb_start "target-select remote localhost:1234" + else + gdb_start ("target-select remote localhost:" ^ port) + ))) |> register_command + ~name:"gdb_qemu" + ~help:"Connect GDB to a remote QEMU target on localhost port :0 (default is 1234, as per -s option for QEMU)"; + + register_command + ~name:"gdb_send" + ~help:"Send a GDB/MI command to a child GDB process and wait for it to complete" + (ArgString ("command", fun cmd -> Action (fun () -> gdb_send cmd))); + + register_command + ~name:"gdb_sync" + ~help:"Sync sail registers with GDB" + (Action (fun () -> gdb_sync !session)); + + register_command + ~name:"gdb_list_registers" + ~help:"Sync sail registers with GDB and list them" + (Action (fun () -> gdb_list_registers !session)); + + register_command + ~name:"gdb_hooks" + ~help:"Make reading and writing memory go via GDB" + (Action (fun () -> gdb_hooks !session)); + + (ArgString ("symbol_file", fun file -> Action (fun () -> + send_regular !session ("symbol-file " ^ file) + ))) |> register_command + ~name:"gdb_symbol_file" + ~help:"Load debugging symbols into GDB"; diff --git a/src/gdbmi_lexer.mll b/src/gdbmi_lexer.mll new file mode 100644 index 00000000..d55ea3cb --- /dev/null +++ b/src/gdbmi_lexer.mll @@ -0,0 +1,101 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +{ + +open Gdbmi_parser + +let unescaped s = Scanf.sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x) + +} + +let ws = [' ''\t']+ +let letter = ['a'-'z''A'-'Z''?'] +let digit = ['0'-'9'] +let hexdigit = ['0'-'9''A'-'F''a'-'f'] +let alphanum = letter|digit +let startident = letter +let ident = alphanum|['-'] +let escape_sequence = ('\\' ['\\''\"''\'''n''t''b''r']) | ('\\' digit digit digit) | ('\\' 'x' hexdigit hexdigit) + +rule token = parse + | ws + { token lexbuf } + | "\n" + { Lexing.new_line lexbuf; + token lexbuf } + | "=" { Eq } + | "[" { Lsquare } + | "]" { Rsquare } + | "{" { Lcurly } + | "}" { Rcurly } + | "," { Comma } + | "^" { Caret } + | digit+ as i { Num (int_of_string i) } + | startident ident* as i { Id i } + | '"' { String (string (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) lexbuf) } + | eof { Eof } + +and string pos b = parse + | ([^'"''\n''\\']*'\n' as i) { Lexing.new_line lexbuf; + Buffer.add_string b i; + string pos b lexbuf } + | ([^'"''\n''\\']* as i) { Buffer.add_string b i; string pos b lexbuf } + | escape_sequence as i { Buffer.add_string b i; string pos b lexbuf } + | '\\' '\n' ws { Lexing.new_line lexbuf; string pos b lexbuf } + | '\\' { assert false (*raise (Reporting.Fatal_error (Reporting.Err_syntax (pos, + "illegal backslash escape in string"*) } + | '"' { let s = unescaped(Buffer.contents b) in + (*try Ulib.UTF8.validate s; s + with Ulib.UTF8.Malformed_code -> + raise (Reporting.Fatal_error (Reporting.Err_syntax (pos, + "String literal is not valid utf8"))) *) s } + | eof { assert false (*raise (Reporting.Fatal_error (Reporting.Err_syntax (pos, + "String literal not terminated")))*) }
\ No newline at end of file diff --git a/src/gdbmi_parser.mly b/src/gdbmi_parser.mly new file mode 100644 index 00000000..5ae5027f --- /dev/null +++ b/src/gdbmi_parser.mly @@ -0,0 +1,85 @@ +/**************************************************************************/ +/* Sail */ +/* */ +/* Copyright (c) 2013-2017 */ +/* Kathyrn Gray */ +/* Shaked Flur */ +/* Stephen Kell */ +/* Gabriel Kerneis */ +/* Robert Norton-Wright */ +/* Christopher Pulte */ +/* Peter Sewell */ +/* Alasdair Armstrong */ +/* Brian Campbell */ +/* Thomas Bauereiss */ +/* Anthony Fox */ +/* Jon French */ +/* Dominic Mulligan */ +/* Stephen Kell */ +/* Mark Wassell */ +/* */ +/* All rights reserved. */ +/* */ +/* This software was developed by the University of Cambridge Computer */ +/* Laboratory as part of the Rigorous Engineering of Mainstream Systems */ +/* (REMS) project, funded by EPSRC grant EP/K008528/1. */ +/* */ +/* Redistribution and use in source and binary forms, with or without */ +/* modification, are permitted provided that the following conditions */ +/* are met: */ +/* 1. Redistributions of source code must retain the above copyright */ +/* notice, this list of conditions and the following disclaimer. */ +/* 2. Redistributions in binary form must reproduce the above copyright */ +/* notice, this list of conditions and the following disclaimer in */ +/* the documentation and/or other materials provided with the */ +/* distribution. */ +/* */ +/* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' */ +/* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED */ +/* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A */ +/* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR */ +/* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, */ +/* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT */ +/* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF */ +/* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND */ +/* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, */ +/* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT */ +/* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF */ +/* SUCH DAMAGE. */ +/**************************************************************************/ + +%{ + +open Gdbmi_types + +%} + +%token Eof +%token Eq Lsquare Rsquare Lcurly Rcurly Comma Caret +%token <string> String Id +%token <int> Num + +%start response_eof +%type <Gdbmi_types.response> response_eof + +%% + +map_elem: + | Id Eq output + { ($1, $3) } + +output: + | String + { String $1 } + | Lsquare separated_list(Comma, output) Rsquare + { Seq $2 } + | Lcurly separated_list(Comma, map_elem) Rcurly + { Assoc $2 } + +response: + | Num Caret Id Comma separated_list(Comma, map_elem) + { Result ($1, $3, $5) } + +response_eof: + | response Eof + { $1 }
\ No newline at end of file diff --git a/src/gdbmi_types.ml b/src/gdbmi_types.ml new file mode 100644 index 00000000..13877a83 --- /dev/null +++ b/src/gdbmi_types.ml @@ -0,0 +1,69 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +type output = + | Assoc of (string * output) list + | Seq of output list + | String of string + +let gdb_seq = function + | Seq xs -> xs + | _ -> failwith "Expected GDB sequence" + +let gdb_string = function + | String xs -> xs + | _ -> failwith "Expected GDB string" + +let gdb_assoc = function + | Assoc xs -> xs + | _ -> failwith "Expected GDB associative list" + +type response = + | Result of int * string * (string * output) list diff --git a/src/lem_interp/sail2_instr_kinds.lem b/src/gen_lib/sail2_instr_kinds.lem index f3cdfbc9..f3cdfbc9 100644 --- a/src/lem_interp/sail2_instr_kinds.lem +++ b/src/gen_lib/sail2_instr_kinds.lem diff --git a/src/gen_lib/sail2_operators_bitlists.lem b/src/gen_lib/sail2_operators_bitlists.lem index c9892e4c..15daa545 100644 --- a/src/gen_lib/sail2_operators_bitlists.lem +++ b/src/gen_lib/sail2_operators_bitlists.lem @@ -38,6 +38,9 @@ let sign_extend bits len = exts_bits len bits val zeros : integer -> list bitU let zeros len = repeat [B0] len +val ones : integer -> list bitU +let ones len = repeat [B1] len + val vector_truncate : list bitU -> integer -> list bitU let vector_truncate bs len = extz_bv len bs diff --git a/src/gen_lib/sail2_values.lem b/src/gen_lib/sail2_values.lem index f657803f..69bf0852 100644 --- a/src/gen_lib/sail2_values.lem +++ b/src/gen_lib/sail2_values.lem @@ -423,6 +423,26 @@ let char_of_nibble = function | _ -> Nothing end +let nibble_of_char = function + | #'0' -> Just (B0, B0, B0, B0) + | #'1' -> Just (B0, B0, B0, B1) + | #'2' -> Just (B0, B0, B1, B0) + | #'3' -> Just (B0, B0, B1, B1) + | #'4' -> Just (B0, B1, B0, B0) + | #'5' -> Just (B0, B1, B0, B1) + | #'6' -> Just (B0, B1, B1, B0) + | #'7' -> Just (B0, B1, B1, B1) + | #'8' -> Just (B1, B0, B0, B0) + | #'9' -> Just (B1, B0, B0, B1) + | #'A' -> Just (B1, B0, B1, B0) + | #'B' -> Just (B1, B0, B1, B1) + | #'C' -> Just (B1, B1, B0, B0) + | #'D' -> Just (B1, B1, B0, B1) + | #'E' -> Just (B1, B1, B1, B0) + | #'F' -> Just (B1, B1, B1, B1) + | _ -> Nothing + end + let rec hexstring_of_bits bs = match bs with | b1 :: b2 :: b3 :: b4 :: bs -> let n = char_of_nibble (b1, b2, b3, b4) in @@ -436,12 +456,14 @@ let rec hexstring_of_bits bs = match bs with end declare {isabelle; hol} termination_argument hexstring_of_bits = automatic -let show_bitlist bs = +let show_bitlist_prefix c bs = match hexstring_of_bits bs with - | Just s -> toString (#'0' :: #'x' :: s) - | Nothing -> toString (#'0' :: #'b' :: map bitU_char bs) + | Just s -> toString (c :: #'x' :: s) + | Nothing -> toString (c :: #'b' :: map bitU_char bs) end +let show_bitlist bs = show_bitlist_prefix #'0' bs + (*** List operations *) let inline (^^) = append_list diff --git a/src/initial_check.ml b/src/initial_check.ml index 1aebdbc2..f808af49 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -153,7 +153,7 @@ let rec to_ast_typ ctx (P.ATyp_aux (aux, l)) = | _ -> [to_ast_typ ctx from_typ] in Typ_fn (from_typs, to_ast_typ ctx to_typ, to_ast_effects effects) - | P.ATyp_bidir (typ1, typ2) -> Typ_bidir (to_ast_typ ctx typ1, to_ast_typ ctx typ2) + | P.ATyp_bidir (typ1, typ2, effects) -> Typ_bidir (to_ast_typ ctx typ1, to_ast_typ ctx typ2, to_ast_effects effects) | P.ATyp_tup typs -> Typ_tup (List.map (to_ast_typ ctx) typs) | P.ATyp_app (P.Id_aux (P.Id "int", il), [n]) -> Typ_app (Id_aux (Id "atom", il), [to_ast_typ_arg ctx n K_int]) @@ -931,8 +931,8 @@ let generate_undefineds vs_ids (Defs defs) = in let undefined_tu = function | Tu_aux (Tu_ty_id (Typ_aux (Typ_tup typs, _), id), _) -> - mk_exp (E_app (id, List.map (fun _ -> mk_lit_exp L_undef) typs)) - | Tu_aux (Tu_ty_id (typ, id), _) -> mk_exp (E_app (id, [mk_lit_exp L_undef])) + mk_exp (E_app (id, List.map (fun typ -> mk_exp (E_cast (typ, mk_lit_exp L_undef))) typs)) + | Tu_aux (Tu_ty_id (typ, id), _) -> mk_exp (E_app (id, [mk_exp (E_cast (typ, mk_lit_exp L_undef))])) in let p_tup = function | [pat] -> pat diff --git a/src/interactive.ml b/src/interactive.ml index 12a1be64..2cca944c 100644 --- a/src/interactive.ml +++ b/src/interactive.ml @@ -48,21 +48,85 @@ (* SUCH DAMAGE. *) (**************************************************************************) +open Ast +open Ast_util +open Printf + let opt_interactive = ref false let opt_emacs_mode = ref false let opt_suppress_banner = ref false let env = ref Type_check.initial_env -let ast = ref (Ast.Defs []) +let ast = ref (Defs []) let arg str = ("<" ^ str ^ ">") |> Util.yellow |> Util.clear let command str = - (":" ^ str) |> Util.green |> Util.clear + str |> Util.green |> Util.clear + +type action = + | ArgString of string * (string -> action) + | ArgInt of string * (int -> action) + | Action of (unit -> unit) let commands = ref [] +let reflect_typ action = + let open Type_check in + let rec arg_typs = function + | ArgString (_, next) -> string_typ :: arg_typs (next "") + | ArgInt (_, next) -> int_typ :: arg_typs (next 0) + | Action _ -> [] + in + function_typ (arg_typs action) unit_typ no_effect + +let generate_help name help action = + let rec args = function + | ArgString (hint, next) -> arg hint :: args (next "") + | ArgInt (hint, next) -> arg hint :: args (next 0) + | Action _ -> [] + in + let args = args action in + let help = match String.split_on_char ':' help with + | [] -> assert false + | (prefix :: splits) -> + List.map (fun split -> + match String.split_on_char ' ' split with + | [] -> assert false + | (subst :: rest) -> + if Str.string_match (Str.regexp "^[0-9]+") subst 0 then + let num_str = Str.matched_string subst in + let num_end = Str.match_end () in + let punct = String.sub subst num_end (String.length subst - num_end) in + List.nth args (int_of_string num_str) ^ punct ^ " " ^ String.concat " " rest + else + command (":" ^ subst) ^ " " ^ String.concat " " rest + ) splits + |> String.concat "" + |> (fun rest -> prefix ^ rest) + in + sprintf "%s %s - %s" Util.(name |> green |> clear) (String.concat ", " args) help + +let run_action cmd argument action = + let args = String.split_on_char ',' argument in + let rec call args action = + match args, action with + | (x :: xs), ArgString (hint, next) -> + call xs (next (String.trim x)) + | (x :: xs), ArgInt (hint, next) -> + let x = String.trim x in + if Str.string_match (Str.regexp "^[0-9]+$") x 0 then + call xs (next (int_of_string x)) + else + print_endline (sprintf "%s argument %s must be an non-negative integer" (command cmd) (arg hint)) + | _, Action act -> + act () + | _, _ -> + print_endline (sprintf "Bad arguments for %s, see (%s %s)" (command cmd) (command ":help") (command cmd)) + in + call args action + let register_command ~name:name ~help:help action = commands := (":" ^ name, (help, action)) :: !commands diff --git a/src/interactive.mli b/src/interactive.mli index b1df0630..933d0a46 100644 --- a/src/interactive.mli +++ b/src/interactive.mli @@ -62,6 +62,17 @@ val env : Env.t ref val arg : string -> string val command : string -> string -val commands : (string * (string * (string -> unit))) list ref +type action = + | ArgString of string * (string -> action) + | ArgInt of string * (int -> action) + | Action of (unit -> unit) -val register_command : name:string -> help:string -> (string -> unit) -> unit +val reflect_typ : action -> typ + +val commands : (string * (string * action)) list ref + +val register_command : name:string -> help:string -> action -> unit + +val generate_help : string -> string -> action -> string + +val run_action : string -> string -> action -> unit diff --git a/src/interpreter.ml b/src/interpreter.ml index dd322369..4c048c09 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -203,7 +203,6 @@ let throw v = Yield (Exception v) let call (f : id) (args : value list) : return_value monad = Yield (Call (f, args, fun v -> Pure v)) - let read_mem rk addr len : value monad = Yield (Read_mem (rk, addr, len, (fun v -> Pure v))) @@ -286,6 +285,7 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = match e_aux with | E_block [] -> wrap (E_lit (L_aux (L_unit, Parse_ast.Unknown))) | E_block [exp] when is_value exp -> return exp + | E_block [E_aux (E_block _, _) as exp] -> return exp | E_block (exp :: exps) when is_value exp -> wrap (E_block exps) | E_block (exp :: exps) -> step exp >>= fun exp' -> wrap (E_block (exp' :: exps)) @@ -825,7 +825,8 @@ let rec eval_frame' = function | Yield (Get_primop (name, cont)), _ -> begin try - let op = StringMap.find name gstate.primops in + (* If we are in the toplevel interactive interpreter allow the set of primops to be changed dynamically *) + let op = StringMap.find name (if !Interactive.opt_interactive then !Value.primops else gstate.primops) in eval_frame' (Step (out, state, cont op, stack)) with Not_found -> eval_frame' (Step (out, state, fail ("No such primop: " ^ name), stack)) @@ -926,8 +927,9 @@ let default_effect_interp state eff = failwith ("Register write disallowed by allow_registers setting: " ^ name) end +let effect_interp = ref default_effect_interp - +let set_effect_interp interp = effect_interp := interp let rec run_frame frame = match frame with @@ -938,7 +940,7 @@ let rec run_frame frame = | Break frame -> run_frame (eval_frame frame) | Effect_request (out, state, stack, eff) -> - run_frame (default_effect_interp state eff) + run_frame (!effect_interp state eff) let eval_exp state exp = run_frame (Step (lazy "", state, return exp, [])) diff --git a/src/isail.ml b/src/isail.ml index 1c635af0..02908321 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -56,6 +56,7 @@ open Interpreter open Pretty_print_sail module Slice = Slice +module Gdbmi = Gdbmi type mode = | Evaluation of frame @@ -108,27 +109,72 @@ let sail_logo = in List.map banner logo @ [""] @ help @ [""] -let vs_ids = ref (val_spec_ids !Interactive.ast) +let sep = "-----------------------------------------------------" |> Util.blue |> Util.clear -let interactive_state = ref (initial_state ~registers:false !Interactive.ast !Interactive.env Value.primops) +let vs_ids = ref (val_spec_ids !Interactive.ast) -let sep = "-----------------------------------------------------" |> Util.blue |> Util.clear +let interactive_state = ref (initial_state ~registers:false !Interactive.ast !Interactive.env !Value.primops) +(* We can't set up the elf commands in elf_loader.ml because it's used + by Sail OCaml emulators at runtime, so set them up here. *) let () = let open Interactive in let open Elf_loader in - let open Printf in - register_command ~name:"elf" ~help:(sprintf ":elf %s - Load an elf file" (arg "file")) load_elf; + ArgString ("file", fun file -> Action (fun () -> load_elf file)) + |> register_command ~name:"elf" ~help:"Load an elf file"; + + ArgString ("addr", fun addr_s -> ArgString ("file", fun filename -> Action (fun () -> + let addr = Big_int.of_string addr_s in + load_binary addr filename + ))) |> register_command ~name:"bin" ~help:"Load a raw binary file at :0. Use :elf to load an ELF" - (fun iarg -> - match Util.split_on_char ' ' iarg with - | [addr_s; filename] -> - let addr = Big_int.of_string addr_s in - load_binary addr filename - | _ -> - printf "Invalid argument for :bin, expected %s %s" (arg "addr") (arg "file") - ) |> register_command ~name:"bin" ~help:(sprintf ":bin %s %s - Load a binary file at a given address" (arg "addr") (arg "file")) +(* This is a feature that lets us take interpreter commands like :foo + x, y and turn the into functions that can be called by sail as + foo(x, y), which lets us use sail to script itself. The + sail_scripting_primops_once variable ensures we only add the + commands to the interpreter primops list once, although we may have + to reset the AST and env changes when we :load and :unload + files by calling this function multiple times. *) +let sail_scripting_primops_once = ref true + +let setup_sail_scripting () = + let open Interactive in + + let sail_command_name cmd = "sail_" ^ String.sub cmd 1 (String.length cmd - 1) in + + let val_specs = + List.map (fun (cmd, (_, action)) -> + let name = sail_command_name cmd in + let typschm = mk_typschm (mk_typquant []) (reflect_typ action) in + mk_val_spec (VS_val_spec (typschm, mk_id name, [("_", name)], false)) + ) !commands in + let val_specs, env' = Type_check.check !env (Defs val_specs) in + ast := append_ast !ast val_specs; + env := env'; + + if !sail_scripting_primops_once then ( + List.iter (fun (cmd, (help, action)) -> + let open Value in + let name = sail_command_name cmd in + let impl values = + let rec call values action = + match values, action with + | (v :: vs), ArgString (_, next) -> + call vs (next (coerce_string v)) + | (v :: vs), ArgInt (_, next) -> + call vs (next (Big_int.to_int (coerce_int v))) + | _, Action act -> + act (); V_unit + | _, _ -> + failwith help + in + call values action + in + Value.add_primop name impl + ) !commands; + sail_scripting_primops_once := false + ) let print_program () = match !current_mode with @@ -169,7 +215,7 @@ let rec run () = | Effect_request (out, state, stack, eff) -> begin try - current_mode := Evaluation (Interpreter.default_effect_interp state eff) + current_mode := Evaluation (!Interpreter.effect_interp state eff) with | Failure str -> print_endline str; current_mode := Normal end; @@ -204,7 +250,7 @@ let rec run_steps n = | Effect_request (out, state, stack, eff) -> begin try - current_mode := Evaluation (Interpreter.default_effect_interp state eff) + current_mode := Evaluation (!Interpreter.effect_interp state eff) with | Failure str -> print_endline str; current_mode := Normal end; @@ -282,7 +328,7 @@ let help = (color green ":commands") (color green ":help") (color yellow "<command>") | cmd -> match List.assoc_opt cmd !Interactive.commands with - | Some (help, _) -> help + | Some (help_message, action) -> Interactive.generate_help cmd help_message action | None -> sprintf "Either invalid command passed to help, or no documentation for %s. Try %s." (color green cmd) (color green ":help :help") @@ -347,7 +393,7 @@ let load_session upto file = | Some upto_file when Filename.basename upto_file = file -> None | Some upto_file -> let (_, ast, env) = - load_files ~check:true !Interactive.env [Filename.concat (Filename.dirname upto_file) file] + Process_file.load_files ~check:true options !Interactive.env [Filename.concat (Filename.dirname upto_file) file] in Interactive.ast := append_ast !Interactive.ast ast; Interactive.env := env; @@ -463,15 +509,15 @@ let handle_input' input = begin match cmd with | ":l" | ":load" -> let files = Util.split_on_char ' ' arg in - let (_, ast, env) = load_files !Interactive.env files in + let (_, ast, env) = Process_file.load_files options !Interactive.env files in Interactive.ast := append_ast !Interactive.ast ast; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; Interactive.env := env; vs_ids := val_spec_ids !Interactive.ast | ":u" | ":unload" -> Interactive.ast := Ast.Defs []; Interactive.env := Type_check.initial_env; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; vs_ids := val_spec_ids !Interactive.ast; (* See initial_check.mli for an explanation of why we need this. *) Initial_check.have_undefined_builtins := false; @@ -493,7 +539,7 @@ let handle_input' input = let ast, env = Type_check.check !Interactive.env (Defs [DEF_val (mk_letbind (mk_pat (P_id (mk_id v))) exp)]) in Interactive.ast := append_ast !Interactive.ast ast; Interactive.env := env; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; | _ -> print_endline "Invalid arguments for :let" end | ":def" -> @@ -501,7 +547,7 @@ let handle_input' input = let ast, env = Type_check.check !Interactive.env ast in Interactive.ast := append_ast !Interactive.ast ast; Interactive.env := env; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; | ":list_rewrites" -> let print_rewrite (name, rw) = print_endline (name ^ " " ^ Util.(String.concat " " (describe_rewrite rw) |> yellow |> clear)) @@ -537,17 +583,17 @@ let handle_input' input = let new_ast, new_env = Process_file.rewrite_ast_target arg !Interactive.env !Interactive.ast in Interactive.ast := new_ast; Interactive.env := new_env; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops | ":prover_regstate" -> let env, ast = prover_regstate (Some arg) !Interactive.ast !Interactive.env in Interactive.env := env; Interactive.ast := ast; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops | ":recheck" -> let ast, env = Type_check.check Type_check.initial_env !Interactive.ast in Interactive.env := env; Interactive.ast := ast; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; vs_ids := val_spec_ids !Interactive.ast | ":recheck_types" -> let ast, env = Type_check.check Type_check.initial_env !Interactive.ast in @@ -555,14 +601,14 @@ let handle_input' input = Interactive.ast := ast; vs_ids := val_spec_ids !Interactive.ast | ":compile" -> - let out_name = match !opt_file_out with + let out_name = match !Process_file.opt_file_out with | None -> "out.sail" | Some f -> f ^ ".sail" in target (Some arg) out_name !Interactive.ast !Interactive.env | _ -> match List.assoc_opt cmd !Interactive.commands with - | Some (_, action) -> action arg + | Some (_, action) -> Interactive.run_action cmd arg action | None -> unrecognised_command cmd end | Expression str -> @@ -582,9 +628,9 @@ let handle_input' input = begin try load_into_session arg; - let (_, ast, env) = load_files ~check:true !Interactive.env [arg] in + let (_, ast, env) = Process_file.load_files ~check:true options !Interactive.env [arg] in Interactive.ast := append_ast !Interactive.ast ast; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; Interactive.env := env; vs_ids := val_spec_ids !Interactive.ast; print_endline ("(message \"Checked " ^ arg ^ " done\")\n"); @@ -595,7 +641,7 @@ let handle_input' input = | ":unload" -> Interactive.ast := Ast.Defs []; Interactive.env := Type_check.initial_env; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; vs_ids := val_spec_ids !Interactive.ast; Initial_check.have_undefined_builtins := false; Process_file.clear_symbols () @@ -670,7 +716,7 @@ let handle_input' input = begin try interactive_state := state; - current_mode := Evaluation (Interpreter.default_effect_interp state eff); + current_mode := Evaluation (!Interpreter.effect_interp state eff); print_program () with | Failure str -> print_endline str; current_mode := Normal @@ -774,28 +820,26 @@ let () = ); (* Read the script file if it is set with the -is option, and excute them *) - begin - match !opt_interactive_script with - | None -> () - | Some file -> - let chan = open_in file in - try - while true do - let line = input_line chan in - handle_input line; - done; - with - | End_of_file -> () + begin match !opt_interactive_script with + | None -> () + | Some file -> + let chan = open_in file in + try + while true do + let line = input_line chan in + handle_input line; + done; + with + | End_of_file -> () end; LNoise.history_load ~filename:"sail_history" |> ignore; LNoise.history_set ~max_length:100 |> ignore; - if !Interactive.opt_interactive then - begin - if not !Interactive.opt_emacs_mode then - List.iter print_endline sail_logo - else (current_mode := Emacs; Util.opt_colors := false); - user_input handle_input - end - else () + if !Interactive.opt_interactive then ( + if not !Interactive.opt_emacs_mode then + List.iter print_endline sail_logo + else (current_mode := Emacs; Util.opt_colors := false); + setup_sail_scripting (); + user_input handle_input + ) diff --git a/src/jib/c_backend.ml b/src/jib/c_backend.ml index 98ee5bc1..2b144d35 100644 --- a/src/jib/c_backend.ml +++ b/src/jib/c_backend.ml @@ -100,7 +100,9 @@ let zencode_uid (id, ctyps) = match ctyps with | [] -> Util.zencode_string (string_of_id id) | _ -> Util.zencode_string (string_of_id id ^ "#" ^ Util.string_of_list "_" string_of_ctyp ctyps) - + +let ctor_bindings = List.fold_left (fun map (id, ctyp) -> UBindings.add id ctyp map) UBindings.empty + (**************************************************************************) (* 2. Converting sail types to C types *) (**************************************************************************) @@ -108,90 +110,9 @@ let zencode_uid (id, ctyps) = let max_int n = Big_int.pred (Big_int.pow_int_positive 2 (n - 1)) let min_int n = Big_int.negate (Big_int.pow_int_positive 2 (n - 1)) -(** Convert a sail type into a C-type. This function can be quite - slow, because it uses ctx.local_env and SMT to analyse the Sail - types and attempts to fit them into the smallest possible C - types, provided ctx.optimize_smt is true (default) **) -let rec ctyp_of_typ ctx typ = - let Typ_aux (typ_aux, l) as typ = Env.expand_synonyms ctx.tc_env typ in - match typ_aux with - | Typ_id id when string_of_id id = "bit" -> CT_bit - | Typ_id id when string_of_id id = "bool" -> CT_bool - | Typ_id id when string_of_id id = "int" -> CT_lint - | Typ_id id when string_of_id id = "nat" -> CT_lint - | Typ_id id when string_of_id id = "unit" -> CT_unit - | Typ_id id when string_of_id id = "string" -> CT_string - | Typ_id id when string_of_id id = "real" -> CT_real - - | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool - - | Typ_app (id, args) when string_of_id id = "itself" -> - ctyp_of_typ ctx (Typ_aux (Typ_app (mk_id "atom", args), l)) - | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" || string_of_id id = "implicit" -> - begin match destruct_range Env.empty typ with - | None -> assert false (* Checked if range type in guard *) - | Some (kids, constr, n, m) -> - let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env }in - match nexp_simp n, nexp_simp m with - | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) - when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> - CT_fint 64 - | n, m -> - if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then - CT_fint 64 - else - CT_lint - end - - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> - CT_list (ctyp_of_typ ctx typ) - - (* When converting a sail bitvector type into C, we have three options in order of efficiency: - - If the length is obviously static and smaller than 64, use the fixed bits type (aka uint64_t), fbits. - - If the length is less than 64, then use a small bits type, sbits. - - If the length may be larger than 64, use a large bits type lbits. *) - | Typ_app (id, [A_aux (A_nexp n, _); - A_aux (A_order ord, _)]) - when string_of_id id = "bitvector" -> - let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in - begin match nexp_simp n with - | Nexp_aux (Nexp_constant n, _) when Big_int.less_equal n (Big_int.of_int 64) -> CT_fbits (Big_int.to_int n, direction) - | n when prove __POS__ ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits (64, direction) - | _ -> CT_lbits direction - end - - | Typ_app (id, [A_aux (A_nexp n, _); - A_aux (A_order ord, _); - A_aux (A_typ typ, _)]) - when string_of_id id = "vector" -> - let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in - CT_vector (direction, ctyp_of_typ ctx typ) - - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "register" -> - CT_ref (ctyp_of_typ ctx typ) - - | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> UBindings.bindings) - | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.variants -> CT_variant (id, Bindings.find id ctx.variants |> UBindings.bindings) - | Typ_id id when Bindings.mem id ctx.enums -> CT_enum (id, Bindings.find id ctx.enums |> IdSet.elements) - - | Typ_tup typs -> CT_tup (List.map (ctyp_of_typ ctx) typs) - - | Typ_exist _ -> - (* Use Type_check.destruct_exist when optimising with SMT, to - ensure that we don't cause any type variable clashes in - local_env, and that we can optimize the existential based upon - it's constraints. *) - begin match destruct_exist (Env.expand_synonyms ctx.local_env typ) with - | Some (kids, nc, typ) -> - let env = add_existential l kids nc ctx.local_env in - ctyp_of_typ { ctx with local_env = env } typ - | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!") - end - - | Typ_var kid -> CT_poly - - | _ -> c_error ~loc:l ("No C type for type " ^ string_of_typ typ) - +(** This function is used to split types into those we allocate on the + stack, versus those which need to live on the heap, or otherwise + require some additional memory management *) let rec is_stack_ctyp ctyp = match ctyp with | CT_fbits _ | CT_sbits _ | CT_bit | CT_unit | CT_bool | CT_enum _ -> true | CT_fint n -> n <= 64 @@ -199,7 +120,7 @@ let rec is_stack_ctyp ctyp = match ctyp with | CT_lint -> false | CT_lbits _ when !optimize_fixed_bits -> true | CT_lbits _ -> false - | CT_real | CT_string | CT_list _ | CT_vector _ -> false + | CT_real | CT_string | CT_list _ | CT_vector _ | CT_fvector _ -> false | CT_struct (_, fields) -> List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) fields | CT_variant (_, ctors) -> false (* List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) ctors *) (* FIXME *) | CT_tup ctyps -> List.for_all is_stack_ctyp ctyps @@ -207,346 +128,442 @@ let rec is_stack_ctyp ctyp = match ctyp with | CT_poly -> true | CT_constant n -> Big_int.less_equal (min_int 64) n && Big_int.greater_equal n (max_int 64) -let is_stack_typ ctx typ = is_stack_ctyp (ctyp_of_typ ctx typ) - -let is_fbits_typ ctx typ = - match ctyp_of_typ ctx typ with - | CT_fbits _ -> true - | _ -> false - -let is_sbits_typ ctx typ = - match ctyp_of_typ ctx typ with - | CT_sbits _ -> true - | _ -> false - -let ctor_bindings = List.fold_left (fun map (id, ctyp) -> UBindings.add id ctyp map) UBindings.empty - -(**************************************************************************) -(* 3. Optimization of primitives and literals *) -(**************************************************************************) - -let hex_char = - let open Sail2_values in - function - | '0' -> [B0; B0; B0; B0] - | '1' -> [B0; B0; B0; B1] - | '2' -> [B0; B0; B1; B0] - | '3' -> [B0; B0; B1; B1] - | '4' -> [B0; B1; B0; B0] - | '5' -> [B0; B1; B0; B1] - | '6' -> [B0; B1; B1; B0] - | '7' -> [B0; B1; B1; B1] - | '8' -> [B1; B0; B0; B0] - | '9' -> [B1; B0; B0; B1] - | 'A' | 'a' -> [B1; B0; B1; B0] - | 'B' | 'b' -> [B1; B0; B1; B1] - | 'C' | 'c' -> [B1; B1; B0; B0] - | 'D' | 'd' -> [B1; B1; B0; B1] - | 'E' | 'e' -> [B1; B1; B1; B0] - | 'F' | 'f' -> [B1; B1; B1; B1] - | _ -> failwith "Invalid hex character" - -let literal_to_fragment (L_aux (l_aux, _) as lit) = - match l_aux with - | L_num n when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> - Some (V_lit (VL_int n, CT_fint 64)) - | L_hex str when String.length str <= 16 -> - let padding = 16 - String.length str in - let padding = Util.list_init padding (fun _ -> Sail2_values.B0) in - let content = Util.string_to_list str |> List.map hex_char |> List.concat in - Some (V_lit (VL_bits (padding @ content, true), CT_fbits (String.length str * 4, true))) - | L_unit -> Some (V_lit (VL_unit, CT_unit)) - | L_true -> Some (V_lit (VL_bool true, CT_bool)) - | L_false -> Some (V_lit (VL_bool false, CT_bool)) - | _ -> None - -let c_literals ctx = - let rec c_literal env l = function - | AV_lit (lit, typ) as v when is_stack_ctyp (ctyp_of_typ { ctx with local_env = env } typ) -> - begin - match literal_to_fragment lit with - | Some cval -> AV_cval (cval, typ) - | None -> v - end - | AV_tuple avals -> AV_tuple (List.map (c_literal env l) avals) - | v -> v - in - map_aval c_literal - -let rec is_bitvector = function - | [] -> true - | AV_lit (L_aux (L_zero, _), _) :: avals -> is_bitvector avals - | AV_lit (L_aux (L_one, _), _) :: avals -> is_bitvector avals - | _ :: _ -> false - -let rec value_of_aval_bit = function - | AV_lit (L_aux (L_zero, _), _) -> Sail2_values.B0 - | AV_lit (L_aux (L_one, _), _) -> Sail2_values.B1 - | _ -> assert false - -(** Used to make sure the -Ofixed_int and -Ofixed_bits don't interfere - with assumptions made about optimizations in the common case. *) -let rec never_optimize = function - | CT_lbits _ | CT_lint -> true - | _ -> false - -let rec c_aval ctx = function - | AV_lit (lit, typ) as v -> - begin - match literal_to_fragment lit with - | Some cval -> AV_cval (cval, typ) - | None -> v - end - | AV_cval (cval, typ) -> AV_cval (cval, typ) - (* An id can be converted to a C fragment if it's type can be - stack-allocated. *) - | AV_id (id, lvar) as v -> - begin - match lvar with - | Local (_, typ) -> - let ctyp = ctyp_of_typ ctx typ in - if is_stack_ctyp ctyp && not (never_optimize ctyp) then - begin - try - (* We need to check that id's type hasn't changed due to flow typing *) - let _, ctyp' = Bindings.find id ctx.locals in - if ctyp_equal ctyp ctyp' then - AV_cval (V_id (name id, ctyp), typ) - else - (* id's type changed due to flow - typing, so it's really still heap allocated! *) - v - with - (* Hack: Assuming global letbindings don't change from flow typing... *) - Not_found -> AV_cval (V_id (name id, ctyp), typ) - end - else - v - | Register (_, _, typ) -> - let ctyp = ctyp_of_typ ctx typ in - if is_stack_ctyp ctyp && not (never_optimize ctyp) then - AV_cval (V_id (name id, ctyp), typ) - else - v - | _ -> v - end - | AV_vector (v, typ) when is_bitvector v && List.length v <= 64 -> - let bitstring = VL_bits (List.map value_of_aval_bit v, true) in - AV_cval (V_lit (bitstring, CT_fbits (List.length v, true)), typ) - | AV_tuple avals -> AV_tuple (List.map (c_aval ctx) avals) - | aval -> aval - -let c_fragment = function - | AV_cval (cval, _) -> cval - | _ -> assert false - let v_mask_lower i = V_lit (VL_bits (Util.list_init i (fun _ -> Sail2_values.B1), true), CT_fbits (i, true)) -(* Map over all the functions in an aexp. *) -let rec analyze_functions ctx f (AE_aux (aexp, env, l)) = - let ctx = { ctx with local_env = env } in - let aexp = match aexp with - | AE_app (id, vs, typ) -> f ctx id vs typ +module C_config : Config = struct - | AE_cast (aexp, typ) -> AE_cast (analyze_functions ctx f aexp, typ) +(** Convert a sail type into a C-type. This function can be quite + slow, because it uses ctx.local_env and SMT to analyse the Sail + types and attempts to fit them into the smallest possible C + types, provided ctx.optimize_smt is true (default) **) + let rec convert_typ ctx typ = + let Typ_aux (typ_aux, l) as typ = Env.expand_synonyms ctx.tc_env typ in + match typ_aux with + | Typ_id id when string_of_id id = "bit" -> CT_bit + | Typ_id id when string_of_id id = "bool" -> CT_bool + | Typ_id id when string_of_id id = "int" -> CT_lint + | Typ_id id when string_of_id id = "nat" -> CT_lint + | Typ_id id when string_of_id id = "unit" -> CT_unit + | Typ_id id when string_of_id id = "string" -> CT_string + | Typ_id id when string_of_id id = "real" -> CT_real + + | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool + + | Typ_app (id, args) when string_of_id id = "itself" -> + convert_typ ctx (Typ_aux (Typ_app (mk_id "atom", args), l)) + | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" || string_of_id id = "implicit" -> + begin match destruct_range Env.empty typ with + | None -> assert false (* Checked if range type in guard *) + | Some (kids, constr, n, m) -> + let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env }in + match nexp_simp n, nexp_simp m with + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> + CT_fint 64 + | n, m -> + if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then + CT_fint 64 + else + CT_lint + end - | AE_assign (id, typ, aexp) -> AE_assign (id, typ, analyze_functions ctx f aexp) + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> + CT_list (convert_typ ctx typ) + + (* When converting a sail bitvector type into C, we have three options in order of efficiency: + - If the length is obviously static and smaller than 64, use the fixed bits type (aka uint64_t), fbits. + - If the length is less than 64, then use a small bits type, sbits. + - If the length may be larger than 64, use a large bits type lbits. *) + | Typ_app (id, [A_aux (A_nexp n, _); + A_aux (A_order ord, _)]) + when string_of_id id = "bitvector" -> + let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in + begin match nexp_simp n with + | Nexp_aux (Nexp_constant n, _) when Big_int.less_equal n (Big_int.of_int 64) -> CT_fbits (Big_int.to_int n, direction) + | n when prove __POS__ ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits (64, direction) + | _ -> CT_lbits direction + end - | AE_write_ref (id, typ, aexp) -> AE_write_ref (id, typ, analyze_functions ctx f aexp) + | Typ_app (id, [A_aux (A_nexp n, _); + A_aux (A_order ord, _); + A_aux (A_typ typ, _)]) + when string_of_id id = "vector" -> + let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in + CT_vector (direction, convert_typ ctx typ) + + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "register" -> + CT_ref (convert_typ ctx typ) + + | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> UBindings.bindings) + | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.variants -> CT_variant (id, Bindings.find id ctx.variants |> UBindings.bindings) + | Typ_id id when Bindings.mem id ctx.enums -> CT_enum (id, Bindings.find id ctx.enums |> IdSet.elements) + + | Typ_tup typs -> CT_tup (List.map (convert_typ ctx) typs) + + | Typ_exist _ -> + (* Use Type_check.destruct_exist when optimising with SMT, to + ensure that we don't cause any type variable clashes in + local_env, and that we can optimize the existential based + upon it's constraints. *) + begin match destruct_exist (Env.expand_synonyms ctx.local_env typ) with + | Some (kids, nc, typ) -> + let env = add_existential l kids nc ctx.local_env in + convert_typ { ctx with local_env = env } typ + | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!") + end - | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, analyze_functions ctx f aexp) + | Typ_var kid -> CT_poly - | AE_let (mut, id, typ1, aexp1, (AE_aux (_, env2, _) as aexp2), typ2) -> - let aexp1 = analyze_functions ctx f aexp1 in - (* Use aexp2's environment because it will contain constraints for id *) - let ctyp1 = ctyp_of_typ { ctx with local_env = env2 } typ1 in - let ctx = { ctx with locals = Bindings.add id (mut, ctyp1) ctx.locals } in - AE_let (mut, id, typ1, aexp1, analyze_functions ctx f aexp2, typ2) + | _ -> c_error ~loc:l ("No C type for type " ^ string_of_typ typ) - | AE_block (aexps, aexp, typ) -> AE_block (List.map (analyze_functions ctx f) aexps, analyze_functions ctx f aexp, typ) + let is_stack_typ ctx typ = is_stack_ctyp (convert_typ ctx typ) - | AE_if (aval, aexp1, aexp2, typ) -> - AE_if (aval, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2, typ) + let is_fbits_typ ctx typ = + match convert_typ ctx typ with + | CT_fbits _ -> true + | _ -> false - | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) + let is_sbits_typ ctx typ = + match convert_typ ctx typ with + | CT_sbits _ -> true + | _ -> false - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> - let aexp1 = analyze_functions ctx f aexp1 in - let aexp2 = analyze_functions ctx f aexp2 in - let aexp3 = analyze_functions ctx f aexp3 in - let aexp4 = analyze_functions ctx f aexp4 in - (* Currently we assume that loop indexes are always safe to put into an int64 *) - let ctx = { ctx with locals = Bindings.add id (Immutable, CT_fint 64) ctx.locals } in - AE_for (id, aexp1, aexp2, aexp3, order, aexp4) + (**************************************************************************) + (* 3. Optimization of primitives and literals *) + (**************************************************************************) + + let hex_char = + let open Sail2_values in + function + | '0' -> [B0; B0; B0; B0] + | '1' -> [B0; B0; B0; B1] + | '2' -> [B0; B0; B1; B0] + | '3' -> [B0; B0; B1; B1] + | '4' -> [B0; B1; B0; B0] + | '5' -> [B0; B1; B0; B1] + | '6' -> [B0; B1; B1; B0] + | '7' -> [B0; B1; B1; B1] + | '8' -> [B1; B0; B0; B0] + | '9' -> [B1; B0; B0; B1] + | 'A' | 'a' -> [B1; B0; B1; B0] + | 'B' | 'b' -> [B1; B0; B1; B1] + | 'C' | 'c' -> [B1; B1; B0; B0] + | 'D' | 'd' -> [B1; B1; B0; B1] + | 'E' | 'e' -> [B1; B1; B1; B0] + | 'F' | 'f' -> [B1; B1; B1; B1] + | _ -> failwith "Invalid hex character" + + let literal_to_fragment (L_aux (l_aux, _) as lit) = + match l_aux with + | L_num n when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> + Some (V_lit (VL_int n, CT_fint 64)) + | L_hex str when String.length str <= 16 -> + let padding = 16 - String.length str in + let padding = Util.list_init padding (fun _ -> Sail2_values.B0) in + let content = Util.string_to_list str |> List.map hex_char |> List.concat in + Some (V_lit (VL_bits (padding @ content, true), CT_fbits (String.length str * 4, true))) + | L_unit -> Some (V_lit (VL_unit, CT_unit)) + | L_true -> Some (V_lit (VL_bool true, CT_bool)) + | L_false -> Some (V_lit (VL_bool false, CT_bool)) + | _ -> None + + let c_literals ctx = + let rec c_literal env l = function + | AV_lit (lit, typ) as v when is_stack_ctyp (convert_typ { ctx with local_env = env } typ) -> + begin + match literal_to_fragment lit with + | Some cval -> AV_cval (cval, typ) + | None -> v + end + | AV_tuple avals -> AV_tuple (List.map (c_literal env l) avals) + | v -> v + in + map_aval c_literal + + let rec is_bitvector = function + | [] -> true + | AV_lit (L_aux (L_zero, _), _) :: avals -> is_bitvector avals + | AV_lit (L_aux (L_one, _), _) :: avals -> is_bitvector avals + | _ :: _ -> false + + let rec value_of_aval_bit = function + | AV_lit (L_aux (L_zero, _), _) -> Sail2_values.B0 + | AV_lit (L_aux (L_one, _), _) -> Sail2_values.B1 + | _ -> assert false + + (** Used to make sure the -Ofixed_int and -Ofixed_bits don't + interfere with assumptions made about optimizations in the common + case. *) + let rec never_optimize = function + | CT_lbits _ | CT_lint -> true + | _ -> false - | AE_case (aval, cases, typ) -> - let analyze_case (AP_aux (_, env, _) as pat, aexp1, aexp2) = - let pat_bindings = Bindings.bindings (apat_types pat) in - let ctx = { ctx with local_env = env } in - let ctx = - List.fold_left (fun ctx (id, typ) -> { ctx with locals = Bindings.add id (Immutable, ctyp_of_typ ctx typ) ctx.locals }) ctx pat_bindings + let rec c_aval ctx = function + | AV_lit (lit, typ) as v -> + begin + match literal_to_fragment lit with + | Some cval -> AV_cval (cval, typ) + | None -> v + end + | AV_cval (cval, typ) -> AV_cval (cval, typ) + (* An id can be converted to a C fragment if it's type can be + stack-allocated. *) + | AV_id (id, lvar) as v -> + begin + match lvar with + | Local (_, typ) -> + let ctyp = convert_typ ctx typ in + if is_stack_ctyp ctyp && not (never_optimize ctyp) then + begin + try + (* We need to check that id's type hasn't changed due to flow typing *) + let _, ctyp' = Bindings.find id ctx.locals in + if ctyp_equal ctyp ctyp' then + AV_cval (V_id (name id, ctyp), typ) + else + (* id's type changed due to flow typing, so it's + really still heap allocated! *) + v + with + (* Hack: Assuming global letbindings don't change from flow typing... *) + Not_found -> AV_cval (V_id (name id, ctyp), typ) + end + else + v + | Register (_, _, typ) -> + let ctyp = convert_typ ctx typ in + if is_stack_ctyp ctyp && not (never_optimize ctyp) then + AV_cval (V_id (name id, ctyp), typ) + else + v + | _ -> v + end + | AV_vector (v, typ) when is_bitvector v && List.length v <= 64 -> + let bitstring = VL_bits (List.map value_of_aval_bit v, true) in + AV_cval (V_lit (bitstring, CT_fbits (List.length v, true)), typ) + | AV_tuple avals -> AV_tuple (List.map (c_aval ctx) avals) + | aval -> aval + + let c_fragment = function + | AV_cval (cval, _) -> cval + | _ -> assert false + + (* Map over all the functions in an aexp. *) + let rec analyze_functions ctx f (AE_aux (aexp, env, l)) = + let ctx = { ctx with local_env = env } in + let aexp = match aexp with + | AE_app (id, vs, typ) -> f ctx id vs typ + + | AE_cast (aexp, typ) -> AE_cast (analyze_functions ctx f aexp, typ) + + | AE_assign (id, typ, aexp) -> AE_assign (id, typ, analyze_functions ctx f aexp) + + | AE_write_ref (id, typ, aexp) -> AE_write_ref (id, typ, analyze_functions ctx f aexp) + + | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, analyze_functions ctx f aexp) + + | AE_let (mut, id, typ1, aexp1, (AE_aux (_, env2, _) as aexp2), typ2) -> + let aexp1 = analyze_functions ctx f aexp1 in + (* Use aexp2's environment because it will contain constraints for id *) + let ctyp1 = convert_typ { ctx with local_env = env2 } typ1 in + let ctx = { ctx with locals = Bindings.add id (mut, ctyp1) ctx.locals } in + AE_let (mut, id, typ1, aexp1, analyze_functions ctx f aexp2, typ2) + + | AE_block (aexps, aexp, typ) -> AE_block (List.map (analyze_functions ctx f) aexps, analyze_functions ctx f aexp, typ) + + | AE_if (aval, aexp1, aexp2, typ) -> + AE_if (aval, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2, typ) + + | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) + + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> + let aexp1 = analyze_functions ctx f aexp1 in + let aexp2 = analyze_functions ctx f aexp2 in + let aexp3 = analyze_functions ctx f aexp3 in + let aexp4 = analyze_functions ctx f aexp4 in + (* Currently we assume that loop indexes are always safe to put into an int64 *) + let ctx = { ctx with locals = Bindings.add id (Immutable, CT_fint 64) ctx.locals } in + AE_for (id, aexp1, aexp2, aexp3, order, aexp4) + + | AE_case (aval, cases, typ) -> + let analyze_case (AP_aux (_, env, _) as pat, aexp1, aexp2) = + let pat_bindings = Bindings.bindings (apat_types pat) in + let ctx = { ctx with local_env = env } in + let ctx = + List.fold_left (fun ctx (id, typ) -> { ctx with locals = Bindings.add id (Immutable, convert_typ ctx typ) ctx.locals }) ctx pat_bindings + in + pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2 in - pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2 - in - AE_case (aval, List.map analyze_case cases, typ) + AE_case (aval, List.map analyze_case cases, typ) - | AE_try (aexp, cases, typ) -> - AE_try (analyze_functions ctx f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) cases, typ) + | AE_try (aexp, cases, typ) -> + AE_try (analyze_functions ctx f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) cases, typ) - | AE_field _ | AE_record_update _ | AE_val _ | AE_return _ | AE_throw _ as v -> v - in - AE_aux (aexp, env, l) + | AE_field _ | AE_record_update _ | AE_val _ | AE_return _ | AE_throw _ as v -> v + in + AE_aux (aexp, env, l) -let analyze_primop' ctx id args typ = - let no_change = AE_app (id, args, typ) in - let args = List.map (c_aval ctx) args in - let extern = if Env.is_extern id ctx.tc_env "c" then Env.get_extern id ctx.tc_env "c" else failwith "Not extern" in + let analyze_primop' ctx id args typ = + let no_change = AE_app (id, args, typ) in + let args = List.map (c_aval ctx) args in + let extern = if Env.is_extern id ctx.tc_env "c" then Env.get_extern id ctx.tc_env "c" else failwith "Not extern" in - let v_one = V_lit (VL_int (Big_int.of_int 1), CT_fint 64) in - let v_int n = V_lit (VL_int (Big_int.of_int n), CT_fint 64) in + let v_one = V_lit (VL_int (Big_int.of_int 1), CT_fint 64) in + let v_int n = V_lit (VL_int (Big_int.of_int n), CT_fint 64) in - match extern, args with - | "eq_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - begin match cval_ctyp v1 with - | CT_fbits _ | CT_sbits _ -> + match extern, args with + | "eq_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + begin match cval_ctyp v1 with + | CT_fbits _ | CT_sbits _ -> AE_val (AV_cval (V_call (Eq, [v1; v2]), typ)) - | _ -> no_change - end + | _ -> no_change + end - | "neq_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - begin match cval_ctyp v1 with - | CT_fbits _ | CT_sbits _ -> - AE_val (AV_cval (V_call (Neq, [v1; v2]), typ)) - | _ -> no_change - end + | "neq_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + begin match cval_ctyp v1 with + | CT_fbits _ | CT_sbits _ -> + AE_val (AV_cval (V_call (Neq, [v1; v2]), typ)) + | _ -> no_change + end - | "eq_int", [AV_cval (v1, _); AV_cval (v2, _)] -> - AE_val (AV_cval (V_call (Eq, [v1; v2]), typ)) + | "eq_int", [AV_cval (v1, _); AV_cval (v2, _)] -> + AE_val (AV_cval (V_call (Eq, [v1; v2]), typ)) - | "eq_bit", [AV_cval (v1, _); AV_cval (v2, _)] -> - AE_val (AV_cval (V_call (Eq, [v1; v2]), typ)) + | "eq_bit", [AV_cval (v1, _); AV_cval (v2, _)] -> + AE_val (AV_cval (V_call (Eq, [v1; v2]), typ)) - | "zeros", [_] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - let n = Big_int.to_int n in - AE_val (AV_cval (V_lit (VL_bits (Util.list_init n (fun _ -> Sail2_values.B0), true), CT_fbits (n, true)), typ)) - | _ -> no_change - end + | "zeros", [_] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + let n = Big_int.to_int n in + AE_val (AV_cval (V_lit (VL_bits (Util.list_init n (fun _ -> Sail2_values.B0), true), CT_fbits (n, true)), typ)) + | _ -> no_change + end - | "zero_extend", [AV_cval (v, _); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_cval (V_call (Zero_extend (Big_int.to_int n), [v]), typ)) - | _ -> no_change - end + | "zero_extend", [AV_cval (v, _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_cval (V_call (Zero_extend (Big_int.to_int n), [v]), typ)) + | _ -> no_change + end - | "sign_extend", [AV_cval (v, _); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_cval (V_call (Sign_extend (Big_int.to_int n), [v]), typ)) - | _ -> no_change - end + | "sign_extend", [AV_cval (v, _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_cval (V_call (Sign_extend (Big_int.to_int n), [v]), typ)) + | _ -> no_change + end - | "lteq", [AV_cval (v1, _); AV_cval (v2, _)] -> - AE_val (AV_cval (V_call (Ilteq, [v1; v2]), typ)) - | "gteq", [AV_cval (v1, _); AV_cval (v2, _)] -> - AE_val (AV_cval (V_call (Igteq, [v1; v2]), typ)) - | "lt", [AV_cval (v1, _); AV_cval (v2, _)] -> - AE_val (AV_cval (V_call (Ilt, [v1; v2]), typ)) - | "gt", [AV_cval (v1, _); AV_cval (v2, _)] -> - AE_val (AV_cval (V_call (Igt, [v1; v2]), typ)) - - | "append", [AV_cval (v1, _); AV_cval (v2, _)] -> - begin match ctyp_of_typ ctx typ with - | CT_fbits _ | CT_sbits _ -> - AE_val (AV_cval (V_call (Concat, [v1; v2]), typ)) - | _ -> no_change - end + | "lteq", [AV_cval (v1, _); AV_cval (v2, _)] -> + AE_val (AV_cval (V_call (Ilteq, [v1; v2]), typ)) + | "gteq", [AV_cval (v1, _); AV_cval (v2, _)] -> + AE_val (AV_cval (V_call (Igteq, [v1; v2]), typ)) + | "lt", [AV_cval (v1, _); AV_cval (v2, _)] -> + AE_val (AV_cval (V_call (Ilt, [v1; v2]), typ)) + | "gt", [AV_cval (v1, _); AV_cval (v2, _)] -> + AE_val (AV_cval (V_call (Igt, [v1; v2]), typ)) + + | "append", [AV_cval (v1, _); AV_cval (v2, _)] -> + begin match convert_typ ctx typ with + | CT_fbits _ | CT_sbits _ -> + AE_val (AV_cval (V_call (Concat, [v1; v2]), typ)) + | _ -> no_change + end - | "not_bits", [AV_cval (v, _)] -> - AE_val (AV_cval (V_call (Bvnot, [v]), typ)) + | "not_bits", [AV_cval (v, _)] -> + AE_val (AV_cval (V_call (Bvnot, [v]), typ)) - | "add_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - AE_val (AV_cval (V_call (Bvadd, [v1; v2]), typ)) + | "add_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + AE_val (AV_cval (V_call (Bvadd, [v1; v2]), typ)) - | "sub_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - AE_val (AV_cval (V_call (Bvsub, [v1; v2]), typ)) + | "sub_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + AE_val (AV_cval (V_call (Bvsub, [v1; v2]), typ)) - | "and_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - AE_val (AV_cval (V_call (Bvand, [v1; v2]), typ)) + | "and_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + AE_val (AV_cval (V_call (Bvand, [v1; v2]), typ)) - | "or_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - AE_val (AV_cval (V_call (Bvor, [v1; v2]), typ)) + | "or_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + AE_val (AV_cval (V_call (Bvor, [v1; v2]), typ)) - | "xor_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - AE_val (AV_cval (V_call (Bvxor, [v1; v2]), typ)) + | "xor_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + AE_val (AV_cval (V_call (Bvxor, [v1; v2]), typ)) - | "vector_subrange", [AV_cval (vec, _); AV_cval (f, _); AV_cval (t, _)] -> - begin match ctyp_of_typ ctx typ with - | CT_fbits (n, true) -> - AE_val (AV_cval (V_call (Slice n, [vec; t]), typ)) - | _ -> no_change - end + | "vector_subrange", [AV_cval (vec, _); AV_cval (f, _); AV_cval (t, _)] -> + begin match convert_typ ctx typ with + | CT_fbits (n, true) -> + AE_val (AV_cval (V_call (Slice n, [vec; t]), typ)) + | _ -> no_change + end - | "slice", [AV_cval (vec, _); AV_cval (start, _); AV_cval (len, _)] -> - begin match ctyp_of_typ ctx typ with - | CT_fbits (n, _) -> - AE_val (AV_cval (V_call (Slice n, [vec; start]), typ)) - | CT_sbits (64, _) -> - AE_val (AV_cval (V_call (Sslice 64, [vec; start; len]), typ)) - | _ -> no_change - end + | "slice", [AV_cval (vec, _); AV_cval (start, _); AV_cval (len, _)] -> + begin match convert_typ ctx typ with + | CT_fbits (n, _) -> + AE_val (AV_cval (V_call (Slice n, [vec; start]), typ)) + | CT_sbits (64, _) -> + AE_val (AV_cval (V_call (Sslice 64, [vec; start; len]), typ)) + | _ -> no_change + end - | "vector_access", [AV_cval (vec, _); AV_cval (n, _)] -> - AE_val (AV_cval (V_call (Bvaccess, [vec; n]), typ)) + | "vector_access", [AV_cval (vec, _); AV_cval (n, _)] -> + AE_val (AV_cval (V_call (Bvaccess, [vec; n]), typ)) - | "add_int", [AV_cval (op1, _); AV_cval (op2, _)] -> - begin match destruct_range Env.empty typ with - | None -> no_change - | Some (kids, constr, n, m) -> - match nexp_simp n, nexp_simp m with - | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + | "add_int", [AV_cval (op1, _); AV_cval (op2, _)] -> + begin match destruct_range Env.empty typ with + | None -> no_change + | Some (kids, constr, n, m) -> + match nexp_simp n, nexp_simp m with + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> - AE_val (AV_cval (V_call (Iadd, [op1; op2]), typ)) - | n, m when prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) -> - AE_val (AV_cval (V_call (Iadd, [op1; op2]), typ)) - | _ -> no_change - end + AE_val (AV_cval (V_call (Iadd, [op1; op2]), typ)) + | n, m when prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) -> + AE_val (AV_cval (V_call (Iadd, [op1; op2]), typ)) + | _ -> no_change + end - | "replicate_bits", [AV_cval (vec, vtyp); _] -> - begin match destruct_vector ctx.tc_env typ, destruct_vector ctx.tc_env vtyp with - | Some (Nexp_aux (Nexp_constant n, _), _, _), Some (Nexp_aux (Nexp_constant m, _), _, _) - when Big_int.less_equal n (Big_int.of_int 64) -> - let times = Big_int.div n m in - if Big_int.equal (Big_int.mul m times) n then - AE_val (AV_cval (V_call (Replicate (Big_int.to_int times), [vec]), typ)) - else + | "replicate_bits", [AV_cval (vec, vtyp); _] -> + begin match destruct_vector ctx.tc_env typ, destruct_vector ctx.tc_env vtyp with + | Some (Nexp_aux (Nexp_constant n, _), _, _), Some (Nexp_aux (Nexp_constant m, _), _, _) + when Big_int.less_equal n (Big_int.of_int 64) -> + let times = Big_int.div n m in + if Big_int.equal (Big_int.mul m times) n then + AE_val (AV_cval (V_call (Replicate (Big_int.to_int times), [vec]), typ)) + else + no_change + | _, _ -> no_change - | _, _ -> - no_change - end - - | "undefined_bit", _ -> - AE_val (AV_cval (V_lit (VL_bit Sail2_values.B0, CT_bit), typ)) + end - | "undefined_bool", _ -> - AE_val (AV_cval (V_lit (VL_bool false, CT_bool), typ)) + | "undefined_bit", _ -> + AE_val (AV_cval (V_lit (VL_bit Sail2_values.B0, CT_bit), typ)) - | _, _ -> - no_change + | "undefined_bool", _ -> + AE_val (AV_cval (V_lit (VL_bool false, CT_bool), typ)) -let analyze_primop ctx id args typ = - let no_change = AE_app (id, args, typ) in - if !optimize_primops then - try analyze_primop' ctx id args typ with - | Failure str -> + | _, _ -> no_change - else - no_change + + let analyze_primop ctx id args typ = + let no_change = AE_app (id, args, typ) in + if !optimize_primops then + try analyze_primop' ctx id args typ with + | Failure str -> + no_change + else + no_change + + let optimize_anf ctx aexp = + analyze_functions ctx analyze_primop (c_literals ctx aexp) + + + let unroll_loops () = None + let specialize_calls = false + let ignore_64 = false + let struct_value = false + let use_real = false +end (** Functions that have heap-allocated return types are implemented by passing a pointer a location where the return value should be @@ -571,9 +588,9 @@ let fix_early_heap_return ret ret_ctyp instrs = before @ [iblock (rewrite_return instrs)] @ rewrite_return after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (_, l)) :: after -> before - @ [iif cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] + @ [iif l cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] @ rewrite_return after | before, I_aux (I_funcall (CL_id (Return _, ctyp), extern, fid, args), aux) :: after -> before @@ -608,9 +625,9 @@ let fix_early_stack_return ret ret_ctyp instrs = before @ [iblock (rewrite_return instrs)] @ rewrite_return after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (_, l)) :: after -> before - @ [iif cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] + @ [iif l cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] @ rewrite_return after | before, I_aux (I_funcall (CL_id (Return _, ctyp), extern, fid, args), aux) :: after -> before @@ -631,7 +648,7 @@ let fix_early_stack_return ret ret_ctyp instrs = rewrite_return instrs let rec insert_heap_returns ret_ctyps = function - | (CDEF_spec (id, _, ret_ctyp) as cdef) :: cdefs -> + | (CDEF_spec (id, _, _, ret_ctyp) as cdef) :: cdefs -> cdef :: insert_heap_returns (Bindings.add id ret_ctyp ret_ctyps) cdefs | CDEF_fundef (id, None, args, body) :: cdefs -> @@ -1022,7 +1039,7 @@ let optimize recursive_functions cdefs = let sgen_id id = Util.zencode_string (string_of_id id) let sgen_uid uid = zencode_uid uid -let sgen_name id = string_of_name id +let sgen_name id = string_of_name ~deref_current_exception:true ~zencode:true id let codegen_id id = string (sgen_id id) let codegen_uid id = string (sgen_uid id) @@ -1033,7 +1050,7 @@ let sgen_function_id id = let sgen_function_uid uid = let str = zencode_uid uid in !opt_prefix ^ String.sub str 1 (String.length str - 1) - + let codegen_function_id id = string (sgen_function_id id) let rec sgen_ctyp = function @@ -1052,6 +1069,7 @@ let rec sgen_ctyp = function | CT_variant (id, _) -> "struct " ^ sgen_id id | CT_list _ as l -> Util.zencode_string (string_of_ctyp l) | CT_vector _ as v -> Util.zencode_string (string_of_ctyp v) + | CT_fvector (_, ord, typ) -> sgen_ctyp (CT_vector (ord, typ)) | CT_string -> "sail_string" | CT_real -> "real" | CT_ref ctyp -> sgen_ctyp ctyp ^ "*" @@ -1073,6 +1091,7 @@ let rec sgen_ctyp_name = function | CT_variant (id, _) -> sgen_id id | CT_list _ as l -> Util.zencode_string (string_of_ctyp l) | CT_vector _ as v -> Util.zencode_string (string_of_ctyp v) + | CT_fvector (_, ord, typ) -> sgen_ctyp_name (CT_vector (ord, typ)) | CT_string -> "sail_string" | CT_real -> "real" | CT_ref ctyp -> "ref_" ^ sgen_ctyp_name ctyp @@ -1094,24 +1113,27 @@ let sgen_mask n = else failwith "Tried to create a mask literal for a vector greater than 64 bits." -let sgen_value = function +let rec sgen_value = function | VL_bits ([], _) -> "UINT64_C(0)" | VL_bits (bs, true) -> "UINT64_C(" ^ Sail2_values.show_bitlist bs ^ ")" | VL_bits (bs, false) -> "UINT64_C(" ^ Sail2_values.show_bitlist (List.rev bs) ^ ")" | VL_int i -> Big_int.to_string i ^ "l" | VL_bool true -> "true" | VL_bool false -> "false" - | VL_null -> "NULL" | VL_unit -> "UNIT" | VL_bit Sail2_values.B0 -> "UINT64_C(0)" | VL_bit Sail2_values.B1 -> "UINT64_C(1)" | VL_bit Sail2_values.BU -> failwith "Undefined bit found in value" | VL_real str -> str | VL_string str -> "\"" ^ str ^ "\"" - + | VL_empty_list -> "NULL" + | VL_enum element -> Util.zencode_string element + | VL_ref r -> "&" ^ Util.zencode_string r + | VL_undefined -> + Reporting.unreachable Parse_ast.Unknown __POS__ "Cannot generate C value for an undefined literal" + let rec sgen_cval = function - | V_id (id, ctyp) -> string_of_name id - | V_ref (id, _) -> "&" ^ string_of_name id + | V_id (id, ctyp) -> sgen_name id | V_lit (vl, ctyp) -> sgen_value vl | V_call (op, cvals) -> sgen_call op cvals | V_field (f, field) -> @@ -1133,8 +1155,6 @@ let rec sgen_cval = function and sgen_call op cvals = let open Printf in match op, cvals with - | Bit_to_bool, [v] -> - sprintf "((bool) %s)" (sgen_cval v) | Bnot, [v] -> "!(" ^ sgen_cval v ^ ")" | List_hd, [v] -> sprintf "(%s).hd" ("*" ^ sgen_cval v) @@ -1306,6 +1326,7 @@ let sgen_cval_param cval = let rec sgen_clexp = function | CL_id (Have_exception _, _) -> "have_exception" | CL_id (Current_exception _, _) -> "current_exception" + | CL_id (Throw_location _, _) -> "throw_location" | CL_id (Return _, _) -> assert false | CL_id (Name (id, _), _) -> "&" ^ sgen_id id | CL_field (clexp, field) -> "&((" ^ sgen_clexp clexp ^ ")->" ^ zencode_uid field ^ ")" @@ -1317,6 +1338,7 @@ let rec sgen_clexp = function let rec sgen_clexp_pure = function | CL_id (Have_exception _, _) -> "have_exception" | CL_id (Current_exception _, _) -> "current_exception" + | CL_id (Throw_location _, _) -> "throw_location" | CL_id (Return _, _) -> assert false | CL_id (Name (id, _), _) -> sgen_id id | CL_field (clexp, field) -> sgen_clexp_pure clexp ^ "." ^ zencode_uid field @@ -1400,21 +1422,26 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = ^^ jump 2 2 (separate_map hardline (codegen_instr fid ctx) instrs) ^^ hardline ^^ string " }" - | I_funcall (x, extern, f, args) -> + | I_funcall (x, special_extern, f, args) -> let c_args = Util.string_of_list ", " sgen_cval args in let ctyp = clexp_ctyp x in - let is_extern = Env.is_extern (fst f) ctx.tc_env "c" || extern in + let is_extern = Env.is_extern (fst f) ctx.tc_env "c" || special_extern in let fname = - if Env.is_extern (fst f) ctx.tc_env "c" then - Env.get_extern (fst f) ctx.tc_env "c" - else if extern then + if special_extern then string_of_id (fst f) + else if Env.is_extern (fst f) ctx.tc_env "c" then + Env.get_extern (fst f) ctx.tc_env "c" else sgen_function_uid f in let fname = match fname, ctyp with | "internal_pick", _ -> Printf.sprintf "pick_%s" (sgen_ctyp_name ctyp) + | "cons", _ -> + begin match snd f with + | [ctyp] -> Util.zencode_string ("cons#" ^ string_of_ctyp ctyp) + | _ -> c_error "cons without specified type" + end | "eq_anything", _ -> begin match args with | cval :: _ -> Printf.sprintf "eq_%s" (sgen_ctyp_name (cval_ctyp cval)) @@ -1765,6 +1792,8 @@ let codegen_type_def ctx = function ^^ string "struct zexception *current_exception = NULL;" ^^ hardline ^^ string "bool have_exception = false;" + ^^ hardline + ^^ string "sail_string *throw_location = NULL;" else empty @@ -1994,7 +2023,7 @@ let codegen_def' ctx = function string (Printf.sprintf "// register %s" (string_of_id id)) ^^ hardline ^^ string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id)) - | CDEF_spec (id, arg_ctyps, ret_ctyp) -> + | CDEF_spec (id, _, arg_ctyps, ret_ctyp) -> let static = if !opt_static then "static " else "" in if Env.is_extern id ctx.tc_env "c" then empty @@ -2009,7 +2038,7 @@ let codegen_def' ctx = function | None -> c_error ~loc:(id_loc id) ("No valspec found for " ^ string_of_id id) in - + (* Check that the function has the correct arity at this point. *) if List.length arg_ctyps <> List.length args then c_error ~loc:(id_loc id) ("function arguments " @@ -2095,7 +2124,7 @@ type c_gen_typ = let rec ctyp_dependencies = function | CT_tup ctyps -> List.concat (List.map ctyp_dependencies ctyps) @ [CTG_tup ctyps] | CT_list ctyp -> ctyp_dependencies ctyp @ [CTG_list ctyp] - | CT_vector (direction, ctyp) -> ctyp_dependencies ctyp @ [CTG_vector (direction, ctyp)] + | CT_vector (direction, ctyp) | CT_fvector (_, direction, ctyp) -> ctyp_dependencies ctyp @ [CTG_vector (direction, ctyp)] | CT_ref ctyp -> ctyp_dependencies ctyp | CT_struct (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) | CT_variant (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) @@ -2169,20 +2198,17 @@ let rec get_recursive_functions (Defs defs) = | [] -> IdSet.empty let jib_of_ast env ast = - let ctx = - initial_ctx - ~convert_typ:ctyp_of_typ - ~optimize_anf:(fun ctx aexp -> analyze_functions ctx analyze_primop (c_literals ctx aexp)) - env - in - Jib_compile.compile_ast ctx ast + let module Jibc = Make(C_config) in + let ctx = initial_ctx (add_special_functions env) in + Jibc.compile_ast ctx ast let compile_ast env output_chan c_includes ast = try let recursive_functions = Spec_analysis.top_sort_defs ast |> get_recursive_functions in let cdefs, ctx = jib_of_ast env ast in - Jib_interactive.ir := cdefs; + let cdefs', _ = Jib_optimize.remove_tuples cdefs ctx in + Jib_interactive.ir := cdefs'; let cdefs = insert_heap_returns Bindings.empty cdefs in let cdefs = optimize recursive_functions cdefs in @@ -2199,10 +2225,15 @@ let compile_ast env output_chan c_includes ast = let exn_boilerplate = if not (Bindings.mem (mk_id "exception") ctx.variants) then ([], []) else ([ " current_exception = sail_malloc(sizeof(struct zexception));"; - " CREATE(zexception)(current_exception);" ], - [ " KILL(zexception)(current_exception);"; + " CREATE(zexception)(current_exception);"; + " throw_location = sail_malloc(sizeof(sail_string));"; + " CREATE(sail_string)(throw_location);" ], + [ " if (have_exception) {fprintf(stderr, \"Exiting due to uncaught exception: %s\\n\", *throw_location);}"; + " KILL(zexception)(current_exception);"; " sail_free(current_exception);"; - " if (have_exception) {fprintf(stderr, \"Exiting due to uncaught exception\\n\"); exit(EXIT_FAILURE);}" ]) + " KILL(sail_string)(throw_location);"; + " sail_free(throw_location);"; + " if (have_exception) {exit(EXIT_FAILURE);}" ]) in let letbind_initializers = diff --git a/src/jib/c_backend.mli b/src/jib/c_backend.mli index 2f748fd7..e627ebd8 100644 --- a/src/jib/c_backend.mli +++ b/src/jib/c_backend.mli @@ -106,8 +106,5 @@ val optimize_alias : bool ref val optimize_fixed_int : bool ref val optimize_fixed_bits : bool ref -(** Convert a typ to a IR ctyp *) -val ctyp_of_typ : Jib_compile.ctx -> Ast.typ -> ctyp - val jib_of_ast : Env.t -> tannot Ast.defs -> cdef list * Jib_compile.ctx val compile_ast : Env.t -> out_channel -> string list -> tannot Ast.defs -> unit diff --git a/src/jib/jib_compile.ml b/src/jib/jib_compile.ml index 0efac940..4282ae30 100644 --- a/src/jib/jib_compile.ml +++ b/src/jib/jib_compile.ml @@ -58,6 +58,7 @@ open Value2 open Anf let opt_memo_cache = ref false +let opt_track_throw = ref true let optimize_aarch64_fast_struct = ref false @@ -151,38 +152,38 @@ type ctx = enums : IdSet.t Bindings.t; variants : (ctyp UBindings.t) Bindings.t; valspecs : (ctyp list * ctyp) Bindings.t; - tc_env : Env.t; local_env : Env.t; + tc_env : Env.t; locals : (mut * ctyp) Bindings.t; letbinds : int list; no_raw : bool; - convert_typ : ctx -> typ -> ctyp; - optimize_anf : ctx -> typ aexp -> typ aexp; - specialize_calls : bool; - ignore_64 : bool; - struct_value : bool; - use_real : bool; } -let initial_ctx ~convert_typ:convert_typ ~optimize_anf:optimize_anf env = +let initial_ctx env = { records = Bindings.empty; enums = Bindings.empty; variants = Bindings.empty; valspecs = Bindings.empty; - tc_env = env; local_env = env; + tc_env = env; locals = Bindings.empty; letbinds = []; no_raw = false; - convert_typ = convert_typ; - optimize_anf = optimize_anf; - specialize_calls = false; - ignore_64 = false; - struct_value = false; - use_real = false; } -let ctyp_of_typ ctx typ = ctx.convert_typ ctx typ +module type Config = sig + val convert_typ : ctx -> typ -> ctyp + val optimize_anf : ctx -> typ aexp -> typ aexp + val unroll_loops : unit -> int option + val specialize_calls : bool + val ignore_64 : bool + val struct_value : bool + val use_real : bool +end + +module Make(C: Config) = struct + +let ctyp_of_typ ctx typ = C.convert_typ ctx typ let rec chunkify n xs = match Util.take n xs, Util.drop n xs with @@ -210,12 +211,12 @@ let rec compile_aval l ctx = function end | AV_ref (id, typ) -> - [], V_ref (name id, ctyp_of_typ ctx (lvar_typ typ)), [] + [], V_lit (VL_ref (string_of_id id), CT_ref (ctyp_of_typ ctx (lvar_typ typ))), [] | AV_lit (L_aux (L_string str, _), typ) -> [], V_lit ((VL_string (String.escaped str)), ctyp_of_typ ctx typ), [] - | AV_lit (L_aux (L_num n, _), typ) when ctx.ignore_64 -> + | AV_lit (L_aux (L_num n, _), typ) when C.ignore_64 -> [], V_lit ((VL_int n), ctyp_of_typ ctx typ), [] | AV_lit (L_aux (L_num n, _), typ) when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> @@ -237,7 +238,7 @@ let rec compile_aval l ctx = function | AV_lit (L_aux (L_false, _), _) -> [], V_lit (VL_bool false, CT_bool), [] | AV_lit (L_aux (L_real str, _), _) -> - if ctx.use_real then + if C.use_real then [], V_lit (VL_real str, CT_real), [] else let gs = ngensym () in @@ -247,6 +248,10 @@ let rec compile_aval l ctx = function | AV_lit (L_aux (L_unit, _), _) -> [], V_lit (VL_unit, CT_unit), [] + | AV_lit (L_aux (L_undef, _), typ) -> + let ctyp = ctyp_of_typ ctx typ in + [], V_lit (VL_undefined, ctyp), [] + | AV_lit (L_aux (_, l) as lit, _) -> raise (Reporting.err_general l ("Encountered unexpected literal " ^ string_of_lit lit ^ " when converting ANF represention into IR")) @@ -264,7 +269,7 @@ let rec compile_aval l ctx = function [iclear tup_ctyp gs] @ cleanup - | AV_record (fields, typ) when ctx.struct_value -> + | AV_record (fields, typ) when C.struct_value -> let ctyp = ctyp_of_typ ctx typ in let gs = ngensym () in let compile_fields (id, aval) = @@ -309,7 +314,7 @@ let rec compile_aval l ctx = function end (* Convert a small bitvector to a uint64_t literal. *) - | AV_vector (avals, typ) when is_bitvector avals && (List.length avals <= 64 || ctx.ignore_64) -> + | AV_vector (avals, typ) when is_bitvector avals && (List.length avals <= 64 || C.ignore_64) -> begin let bitstring = List.map value_of_aval_bit avals in let len = List.length avals in @@ -358,11 +363,14 @@ let rec compile_aval l ctx = function | V_lit (VL_bit Sail2_values.B1, _) -> [icopy l (CL_id (gs, ctyp)) (V_call (Bvor, [V_id (gs, ctyp); V_lit (mask i, ctyp)]))] | _ -> - (* FIXME: Make this work in C *) - setup @ [iif (V_call (Bit_to_bool, [cval])) [icopy l (CL_id (gs, ctyp)) (V_call (Bvor, [V_id (gs, ctyp); V_lit (mask i, ctyp)]))] [] CT_unit] @ cleanup + setup + @ [iextern (CL_id (gs, ctyp)) + (mk_id "update_fbits", []) + [V_id (gs, ctyp); V_lit (VL_int (Big_int.of_int i), CT_fint 64); cval]] + @ cleanup in [idecl ctyp gs; - icopy l (CL_id (gs, ctyp)) (V_lit (VL_bits (Util.list_init 64 (fun _ -> Sail2_values.B0), direction), ctyp))] + icopy l (CL_id (gs, ctyp)) (V_lit (VL_bits (Util.list_init len (fun _ -> Sail2_values.B0), direction), ctyp))] @ List.concat (List.mapi aval_mask (List.rev avals)), V_id (gs, ctyp), [] @@ -403,7 +411,7 @@ let rec compile_aval l ctx = function let gs = ngensym () in let mk_cons aval = let setup, cval, cleanup = compile_aval l ctx aval in - setup @ [ifuncall (CL_id (gs, CT_list ctyp)) (mk_id ("cons#" ^ string_of_ctyp ctyp), []) [cval; V_id (gs, CT_list ctyp)]] @ cleanup + setup @ [iextern (CL_id (gs, CT_list ctyp)) (mk_id "cons", [ctyp]) [cval; V_id (gs, CT_list ctyp)]] @ cleanup in [idecl (CT_list ctyp) gs] @ List.concat (List.map mk_cons (List.rev avals)), @@ -420,7 +428,7 @@ let optimize_call l ctx clexp id args arg_ctyps ret_ctyp = let have_ctyp = cval_ctyp cval in if is_polymorphic ctyp then V_poly (cval, have_ctyp) - else if ctx.specialize_calls || ctyp_equal ctyp have_ctyp then + else if C.specialize_calls || ctyp_equal ctyp have_ctyp then cval else let gs = ngensym () in @@ -429,7 +437,7 @@ let optimize_call l ctx clexp id args arg_ctyps ret_ctyp = V_id (gs, ctyp)) arg_ctyps args in - if ctx.specialize_calls || ctyp_equal (clexp_ctyp clexp) ret_ctyp then + if C.specialize_calls || ctyp_equal (clexp_ctyp clexp) ret_ctyp then !setup @ [ifuncall clexp id cast_args] @ !cleanup else let gs = ngensym () in @@ -440,7 +448,7 @@ let optimize_call l ctx clexp id args arg_ctyps ret_ctyp = iclear ret_ctyp gs] @ !cleanup in - if not ctx.specialize_calls && Env.is_extern (fst id) ctx.tc_env "c" then + if not C.specialize_calls && Env.is_extern (fst id) ctx.tc_env "c" then let extern = Env.get_extern (fst id) ctx.tc_env "c" in begin match extern, List.map cval_ctyp args, clexp_ctyp clexp with | "slice", [CT_fbits _; CT_lint; _], CT_fbits (n, _) -> @@ -506,7 +514,7 @@ let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label = let ctyp = cval_ctyp cval in match apat_aux with | AP_id (pid, _) when Env.is_union_constructor pid ctx.tc_env -> - [ijump (V_ctor_kind (cval, pid, [], cval_ctyp cval)) case_label], + [ijump l (V_ctor_kind (cval, pid, [], cval_ctyp cval)) case_label], [], ctx @@ -517,7 +525,7 @@ let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label = | AP_id (pid, _) when is_ct_enum ctyp -> begin match Env.lookup_id pid ctx.tc_env with | Unbound -> [idecl ctyp (name pid); icopy l (CL_id (name pid, ctyp)) cval], [], ctx - | _ -> [ijump (V_call (Neq, [V_id (name pid, ctyp); cval])) case_label], [], ctx + | _ -> [ijump l (V_call (Neq, [V_id (name pid, ctyp); cval])) case_label], [], ctx end | AP_id (pid, typ) -> @@ -562,7 +570,7 @@ let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label = [], ctor_ctyp in let instrs, cleanup, ctx = compile_match ctx apat (V_ctor_unwrap (ctor, cval, unifiers, ctor_ctyp)) case_label in - [ijump (V_ctor_kind (cval, ctor, unifiers, pat_ctyp)) case_label] + [ijump l (V_ctor_kind (cval, ctor, unifiers, pat_ctyp)) case_label] @ instrs, cleanup, ctx @@ -581,12 +589,12 @@ let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label = | CT_list ctyp -> let hd_setup, hd_cleanup, ctx = compile_match ctx hd_apat (V_call (List_hd, [cval])) case_label in let tl_setup, tl_cleanup, ctx = compile_match ctx tl_apat (V_call (List_tl, [cval])) case_label in - [ijump (V_call (Eq, [cval; V_lit (VL_null, CT_list ctyp)])) case_label] @ hd_setup @ tl_setup, tl_cleanup @ hd_cleanup, ctx + [ijump l (V_call (Eq, [cval; V_lit (VL_empty_list, CT_list ctyp)])) case_label] @ hd_setup @ tl_setup, tl_cleanup @ hd_cleanup, ctx | _ -> raise (Reporting.err_general l "Tried to pattern match cons on non list type") end - | AP_nil _ -> [ijump (V_call (Neq, [cval; V_lit (VL_null, ctyp)])) case_label], [], ctx + | AP_nil _ -> [ijump l (V_call (Neq, [cval; V_lit (VL_empty_list, ctyp)])) case_label], [], ctx let unit_cval = V_lit (VL_unit, CT_unit) @@ -633,7 +641,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = destructure @ (if not trivial_guard then guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup - @ [iif (V_call (Bnot, [V_id (gs, CT_bool)])) (destructure_cleanup @ [igoto case_label]) [] CT_unit] + @ [iif l (V_call (Bnot, [V_id (gs, CT_bool)])) (destructure_cleanup @ [igoto case_label]) [] CT_unit] else []) @ body_setup @ [body_call (CL_id (case_return_id, ctyp))] @ body_cleanup @ destructure_cleanup @ [igoto finish_match_label] @@ -674,7 +682,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = destructure @ [icomment "end destructuring"] @ (if not trivial_guard then guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup - @ [ijump (V_call (Bnot, [V_id (gs, CT_bool)])) try_label] + @ [ijump l (V_call (Bnot, [V_id (gs, CT_bool)])) try_label] @ [icomment "end guard"] else []) @ body_setup @ [body_call (CL_id (try_return_id, ctyp))] @ body_cleanup @ destructure_cleanup @@ -685,7 +693,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = assert (ctyp_equal ctyp (ctyp_of_typ ctx typ)); [idecl ctyp try_return_id; itry_block (aexp_setup @ [aexp_call (CL_id (try_return_id, ctyp))] @ aexp_cleanup); - ijump (V_call (Bnot, [V_id (have_exception, CT_bool)])) handled_exception_label] + ijump l (V_call (Bnot, [V_id (have_exception, CT_bool)])) handled_exception_label] @ List.concat (List.map compile_case cases) @ [igoto fallthrough_label; ilabel handled_exception_label; @@ -707,7 +715,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = in let setup, cval, cleanup = compile_aval l ctx aval in setup, - (fun clexp -> iif cval + (fun clexp -> iif l cval (compile_branch then_aexp clexp) (compile_branch else_aexp clexp) if_ctyp), @@ -742,7 +750,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = let gs = ngensym () in left_setup @ [ idecl CT_bool gs; - iif cval + iif l cval (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) [icopy l (CL_id (gs, CT_bool)) (V_lit (VL_bool false, CT_bool))] CT_bool ] @@ -755,7 +763,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = let gs = ngensym () in left_setup @ [ idecl CT_bool gs; - iif cval + iif l cval [icopy l (CL_id (gs, CT_bool)) (V_lit (VL_bool true, CT_bool))] (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) CT_bool ] @@ -813,7 +821,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = @ [iblock (cond_setup @ [cond_call (CL_id (gs, CT_bool))] @ cond_cleanup - @ [ijump loop_test loop_end_label] + @ [ijump l loop_test loop_end_label] @ body_setup @ [body_call (CL_id (unit_gs, CT_unit))] @ body_cleanup @@ -838,7 +846,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = @ cond_setup @ [cond_call (CL_id (gs, CT_bool))] @ cond_cleanup - @ [ijump loop_test loop_end_label] + @ [ijump l loop_test loop_end_label] @ [igoto loop_start_label])] @ [ilabel loop_end_label], (fun clexp -> icopy l clexp unit_cval), @@ -869,7 +877,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = | AE_throw (aval, typ) -> (* Cleanup info will be handled by fix_exceptions *) let throw_setup, cval, _ = compile_aval l ctx aval in - throw_setup @ [ithrow cval], + throw_setup @ [ithrow l cval], (fun clexp -> icomment "unreachable after throw"), [] @@ -927,21 +935,29 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = let loop_var = name loop_var in + let loop_body prefix continue = + prefix + @ [iblock ([ijump l (V_call ((if is_inc then Igt else Ilt), [V_id (loop_var, CT_fint 64); V_id (to_gs, CT_fint 64)])) loop_end_label] + @ body_setup + @ [body_call (CL_id (body_gs, CT_unit))] + @ body_cleanup + @ [icopy l (CL_id (loop_var, (CT_fint 64))) + (V_call ((if is_inc then Iadd else Isub), [V_id (loop_var, CT_fint 64); V_id (step_gs, CT_fint 64)]))] + @ continue ())] + in + (* We can either generate an actual loop body for C, or unroll the body for SMT *) + let actual = loop_body [ilabel loop_start_label] (fun () -> [igoto loop_start_label]) in + let rec unroll max n = loop_body [] (fun () -> if n < max then unroll max (n + 1) else [imatch_failure ()]) in + let body = match C.unroll_loops () with Some times -> unroll times 0 | None -> actual in + variable_init from_gs from_setup from_call from_cleanup @ variable_init to_gs to_setup to_call to_cleanup @ variable_init step_gs step_setup step_call step_cleanup @ [iblock ([idecl (CT_fint 64) loop_var; icopy l (CL_id (loop_var, (CT_fint 64))) (V_id (from_gs, CT_fint 64)); - idecl CT_unit body_gs; - iblock ([ilabel loop_start_label] - @ [ijump (V_call ((if is_inc then Igt else Ilt), [V_id (loop_var, CT_fint 64); V_id (to_gs, CT_fint 64)])) loop_end_label] - @ body_setup - @ [body_call (CL_id (body_gs, CT_unit))] - @ body_cleanup - @ [icopy l (CL_id (loop_var, (CT_fint 64))) - (V_call ((if is_inc then Iadd else Isub), [V_id (loop_var, CT_fint 64); V_id (step_gs, CT_fint 64)]))] - @ [igoto loop_start_label]); - ilabel loop_end_label])], + idecl CT_unit body_gs] + @ body + @ [ilabel loop_end_label])], (fun clexp -> icopy l clexp unit_cval), [] @@ -1032,19 +1048,23 @@ let fix_exception_block ?return:(return=None) ctx instrs = before @ [iblock (rewrite_exception (historic @ before) instrs)] @ rewrite_exception (historic @ before) after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (_, l)) :: after -> let historic = historic @ before in before - @ [iif cval (rewrite_exception historic then_instrs) (rewrite_exception historic else_instrs) ctyp] + @ [iif l cval (rewrite_exception historic then_instrs) (rewrite_exception historic else_instrs) ctyp] @ rewrite_exception historic after | before, I_aux (I_throw cval, (_, l)) :: after -> before @ [icopy l (CL_id (current_exception, cval_ctyp cval)) cval; icopy l (CL_id (have_exception, CT_bool)) (V_lit (VL_bool true, CT_bool))] + @ (if !opt_track_throw then + let loc_string = Reporting.short_loc_to_string l in + [icopy l (CL_id (throw_location, CT_string)) (V_lit (VL_string loc_string, CT_string))] + else []) @ generate_cleanup (historic @ before) @ [igoto end_block_label] @ rewrite_exception (historic @ before) after - | before, (I_aux (I_funcall (x, _, f, args), _) as funcall) :: after -> + | before, (I_aux (I_funcall (x, _, f, args), (_, l)) as funcall) :: after -> let effects = match Env.get_val_spec (fst f) ctx.tc_env with | _, Typ_aux (Typ_fn (_, _, effects), _) -> effects | exception (Type_error _) -> no_effect (* nullary union constructor, so no val spec *) @@ -1053,7 +1073,7 @@ let fix_exception_block ?return:(return=None) ctx instrs = if has_effect effects BE_escape then before @ [funcall; - iif (V_id (have_exception, CT_bool)) (generate_cleanup (historic @ before) @ [igoto end_block_label]) [] CT_unit] + iif l (V_id (have_exception, CT_bool)) (generate_cleanup (historic @ before) @ [igoto end_block_label]) [] CT_unit] @ rewrite_exception (historic @ before) after else before @ funcall :: rewrite_exception (historic @ before) after @@ -1147,10 +1167,10 @@ let fix_early_return ret instrs = before @ [iblock (rewrite_return (historic @ before) instrs)] @ rewrite_return (historic @ before) after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (_, l)) :: after -> let historic = historic @ before in before - @ [iif cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp] + @ [iif l cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp] @ rewrite_return historic after | before, I_aux (I_return cval, (_, l)) :: after -> let cleanup_label = label "cleanup_" in @@ -1211,7 +1231,7 @@ let compile_funcl ctx id pat guard exp = let guard_instrs = match guard with | Some guard -> - let guard_aexp = ctx.optimize_anf ctx (no_shadow (pat_ids pat) (anf guard)) in + let guard_aexp = C.optimize_anf ctx (no_shadow (pat_ids pat) (anf guard)) in let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard_aexp in let guard_label = label "guard_" in let gs = ngensym () in @@ -1220,7 +1240,7 @@ let compile_funcl ctx id pat guard exp = @ guard_setup @ [guard_call (CL_id (gs, CT_bool))] @ guard_cleanup - @ [ijump (V_id (gs, CT_bool)) guard_label; + @ [ijump (id_loc id) (V_id (gs, CT_bool)) guard_label; imatch_failure (); ilabel guard_label] )] @@ -1228,7 +1248,7 @@ let compile_funcl ctx id pat guard exp = in (* Optimize and compile the expression to ANF. *) - let aexp = ctx.optimize_anf ctx (no_shadow (pat_ids pat) (anf exp)) in + let aexp = C.optimize_anf ctx (no_shadow (pat_ids pat) (anf exp)) in let setup, call, cleanup = compile_aexp ctx aexp in let destructure, destructure_cleanup = @@ -1280,7 +1300,7 @@ and compile_def' n total ctx = function | DEF_reg_dec (DEC_aux (DEC_reg (_, _, typ, id), _)) -> [CDEF_reg_dec (id, ctyp_of_typ ctx typ, [])], ctx | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), _)) -> - let aexp = ctx.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in + let aexp = C.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in let setup, call, cleanup = compile_aexp ctx aexp in let instrs = setup @ [call (CL_id (name id, ctyp_of_typ ctx typ))] @ cleanup in [CDEF_reg_dec (id, ctyp_of_typ ctx typ, instrs)], ctx @@ -1290,13 +1310,19 @@ and compile_def' n total ctx = function | DEF_spec (VS_aux (VS_val_spec (_, id, _, _), _)) -> let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in + let extern = + if Env.is_extern id ctx.tc_env "c" then + Some (Env.get_extern id ctx.tc_env "c") + else + None + in let arg_typs, ret_typ = match fn_typ with | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ | _ -> assert false in let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } in let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in - [CDEF_spec (id, arg_ctyps, ret_ctyp)], + [CDEF_spec (id, extern, arg_ctyps, ret_ctyp)], { ctx with valspecs = Bindings.add id (arg_ctyps, ret_ctyp) ctx.valspecs } | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, Pat_aux (Pat_exp (pat, exp), _)), _)]), _)) -> @@ -1323,7 +1349,7 @@ and compile_def' n total ctx = function | DEF_val (LB_aux (LB_val (pat, exp), _)) -> let ctyp = ctyp_of_typ ctx (typ_of_pat pat) in - let aexp = ctx.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in + let aexp = C.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in let setup, call, cleanup = compile_aexp ctx aexp in let apat = anf_pat ~global:true pat in let gs = ngensym () in @@ -1544,12 +1570,6 @@ let sort_ctype_defs cdefs = ctype_defs @ cdefs let compile_ast ctx (Defs defs) = - let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit" in - let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit" in - let cons_vs = Initial_check.extern_of_string (mk_id "sail_cons") "forall ('a : Type). ('a, list('a)) -> list('a)" in - - let ctx = { ctx with tc_env = snd (Type_error.check ctx.tc_env (Defs [assert_vs; exit_vs; cons_vs])) } in - if !opt_memo_cache then (try if Sys.is_directory "_sbuild" then @@ -1568,3 +1588,12 @@ let compile_ast ctx (Defs defs) = let cdefs, ctx = specialize_variants ctx [] cdefs in let cdefs = sort_ctype_defs cdefs in cdefs, ctx + +end + +let add_special_functions env = + let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit" in + let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit" in + let cons_vs = Initial_check.extern_of_string (mk_id "sail_cons") "forall ('a : Type). ('a, list('a)) -> list('a)" in + + snd (Type_error.check env (Defs [assert_vs; exit_vs; cons_vs])) diff --git a/src/jib/jib_compile.mli b/src/jib/jib_compile.mli index 273e9e03..9014d8f7 100644 --- a/src/jib/jib_compile.mli +++ b/src/jib/jib_compile.mli @@ -58,53 +58,69 @@ open Type_check (** This forces all integer struct fields to be represented as int64_t. Specifically intended for the various TLB structs in the - ARM v8.5 spec. *) + ARM v8.5 spec. It is unsound in general. *) val optimize_aarch64_fast_struct : bool ref +(** If true (default) track the location of the last exception thrown, + useful for debugging C but we want to turn it off for SMT generation + where we can't use strings *) +val opt_track_throw : bool ref + (** {2 Jib context} *) -(** Context for compiling Sail to Jib. We need to pass a (global) - typechecking environment given by checking the full AST. We have to - provide a conversion function from Sail types into Jib types, as - well as a function that optimizes ANF expressions (which can just - be the identity function) *) +(** Dynamic context for compiling Sail to Jib. We need to pass a + (global) typechecking environment given by checking the full + AST. *) type ctx = { records : (ctyp Jib_util.UBindings.t) Bindings.t; enums : IdSet.t Bindings.t; variants : (ctyp Jib_util.UBindings.t) Bindings.t; valspecs : (ctyp list * ctyp) Bindings.t; - tc_env : Env.t; local_env : Env.t; + tc_env : Env.t; locals : (mut * ctyp) Bindings.t; letbinds : int list; no_raw : bool; - convert_typ : ctx -> typ -> ctyp; - optimize_anf : ctx -> typ aexp -> typ aexp; - (** If false (default), function arguments must match the function - type exactly. If true, they can be more specific. *) - specialize_calls : bool; - (** If false (default), will ensure that fixed size bitvectors are - specifically less that 64-bits. If true this restriction will - be ignored. *) - ignore_64 : bool; - (** If false (default) we won't generate any V_struct values *) - struct_value : bool; - (** Allow real literals *) - use_real : bool; } -val initial_ctx : - convert_typ:(ctx -> typ -> ctyp) -> - optimize_anf:(ctx -> typ aexp -> typ aexp) -> - Env.t -> - ctx +val initial_ctx : Env.t -> ctx (** {2 Compilation functions} *) -(** Compile a Sail definition into a Jib definition. The first two - arguments are is the current definition number and the total number - of definitions, and can be used to drive a progress bar (see - Util.progress). *) -val compile_def : int -> int -> ctx -> tannot def -> cdef list * ctx +(** The Config module specifies static configuration for compiling + Sail into Jib. We have to provide a conversion function from Sail + types into Jib types, as well as a function that optimizes ANF + expressions (which can just be the identity function) *) +module type Config = sig + val convert_typ : ctx -> typ -> ctyp + val optimize_anf : ctx -> typ aexp -> typ aexp + (** Unroll all for loops a bounded number of times. Used for SMT + generation. *) + val unroll_loops : unit -> int option + (** If false, function arguments must match the function + type exactly. If true, they can be more specific. *) + val specialize_calls : bool + (** If false, will ensure that fixed size bitvectors are + specifically less that 64-bits. If true this restriction will + be ignored. *) + val ignore_64 : bool + (** If false we won't generate any V_struct values *) + val struct_value : bool + (** Allow real literals *) + val use_real : bool +end + +module Make(C: Config) : sig + (** Compile a Sail definition into a Jib definition. The first two + arguments are is the current definition number and the total + number of definitions, and can be used to drive a progress bar + (see Util.progress). *) + val compile_def : int -> int -> ctx -> tannot def -> cdef list * ctx + + val compile_ast : ctx -> tannot defs -> cdef list * ctx +end -val compile_ast : ctx -> tannot defs -> cdef list * ctx +(** Adds some special functions to the environment that are used to + convert several Sail language features, these are sail_assert, + sail_exit, and sail_cons. *) +val add_special_functions : Env.t -> Env.t diff --git a/src/jib/jib_ir.ml b/src/jib/jib_ir.ml index c5f2b20a..4bf726aa 100644 --- a/src/jib/jib_ir.ml +++ b/src/jib/jib_ir.ml @@ -69,7 +69,9 @@ let string_of_name = "return" ^ ssa_num n | Current_exception n -> "current_exception" ^ ssa_num n - + | Throw_location n -> + "throw_location" ^ ssa_num n + let rec string_of_clexp = function | CL_id (id, ctyp) -> string_of_name id | CL_field (clexp, field) -> string_of_clexp clexp ^ "." ^ string_of_uid field @@ -107,7 +109,9 @@ module Ir_formatter = struct | I_label label -> C.output_label_instr buf label_map label | I_jump (cval, label) -> - add_instr n buf indent (C.keyword "jump" ^ " " ^ C.value cval ^ " " ^ C.string_of_label (StringMap.find label label_map)) + add_instr n buf indent (C.keyword "jump" ^ " " ^ C.value cval ^ " " + ^ C.keyword "goto" ^ " " ^ C.string_of_label (StringMap.find label label_map) + ^ " ` \"" ^ Reporting.short_loc_to_string l ^ "\"") | I_goto label -> add_instr n buf indent (C.keyword "goto" ^ " " ^ C.string_of_label (StringMap.find label label_map)) | I_match_failure -> @@ -151,8 +155,10 @@ module Ir_formatter = struct let output_def buf = function | CDEF_reg_dec (id, ctyp, _) -> Buffer.add_string buf (sprintf "%s %s : %s" (C.keyword "register") (zencode_id id) (C.typ ctyp)) - | CDEF_spec (id, ctyps, ctyp) -> + | CDEF_spec (id, None, ctyps, ctyp) -> Buffer.add_string buf (sprintf "%s %s : (%s) -> %s" (C.keyword "val") (zencode_id id) (Util.string_of_list ", " C.typ ctyps) (C.typ ctyp)); + | CDEF_spec (id, Some extern, ctyps, ctyp) -> + Buffer.add_string buf (sprintf "%s %s = \"%s\" : (%s) -> %s" (C.keyword "val") (zencode_id id) extern (Util.string_of_list ", " C.typ ctyps) (C.typ ctyp)); | CDEF_fundef (id, ret, args, instrs) -> let instrs = C.modify_instrs instrs in let label_map = C.make_label_map instrs in @@ -244,10 +250,10 @@ let () = let open Interactive in let open Jib_interactive in - (fun arg -> + ArgString ("(val|register)? identifier", fun arg -> Action (fun () -> let is_def id = function | CDEF_fundef (id', _, _, _) -> Id.compare id id' = 0 - | CDEF_spec (id', _, _) -> Id.compare id (prepend_id "val " id') = 0 + | CDEF_spec (id', _, _, _) -> Id.compare id (prepend_id "val " id') = 0 | CDEF_reg_dec (id', _, _) -> Id.compare id (prepend_id "register " id') = 0 | _ -> false in @@ -258,12 +264,12 @@ let () = let buf = Buffer.create 256 in with_colors (fun () -> Flat_ir_formatter.output_def buf cdef); print_endline (Buffer.contents buf) - ) |> Interactive.(register_command ~name:"ir" ~help:(sprintf ":ir %s - Print the ir representation of a toplevel definition" (arg "(val|register)? identifier"))); + )) |> Interactive.register_command ~name:"ir" ~help:"Print the ir representation of a toplevel definition"; - (fun file -> + ArgString ("file", fun file -> Action (fun () -> let buf = Buffer.create 256 in let out_chan = open_out file in Flat_ir_formatter.output_defs buf !ir; output_string out_chan (Buffer.contents buf); close_out out_chan - ) |> Interactive.(register_command ~name:"dump_ir" ~help:(sprintf ":dump_ir %s - Dump the ir to a file" (arg "file"))) + )) |> Interactive.register_command ~name:"dump_ir" ~help:"Dump the ir to a file" diff --git a/src/jib/jib_optimize.ml b/src/jib/jib_optimize.ml index 323f3cd0..e0f3bf0d 100644 --- a/src/jib/jib_optimize.ml +++ b/src/jib/jib_optimize.ml @@ -102,10 +102,10 @@ let rec flatten_instrs = function | I_aux ((I_block block | I_try_block block), _) :: instrs -> flatten_instrs block @ flatten_instrs instrs - | I_aux (I_if (cval, then_instrs, else_instrs, _), _) :: instrs -> + | I_aux (I_if (cval, then_instrs, else_instrs, _), (_, l)) :: instrs -> let then_label = label "then_" in let endif_label = label "endif_" in - [ijump cval then_label] + [ijump l cval then_label] @ flatten_instrs else_instrs @ [igoto endif_label] @ [ilabel then_label] @@ -153,7 +153,7 @@ let unique_per_function_ids cdefs = | CDEF_reg_dec (id, ctyp, instrs) -> CDEF_reg_dec (id, ctyp, unique_instrs i instrs) | CDEF_type ctd -> CDEF_type ctd | CDEF_let (n, bindings, instrs) -> CDEF_let (n, bindings, unique_instrs i instrs) - | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, ctyps, ctyp) + | CDEF_spec (id, extern, ctyps, ctyp) -> CDEF_spec (id, extern, ctyps, ctyp) | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, unique_instrs i instrs) | CDEF_startup (id, instrs) -> CDEF_startup (id, unique_instrs i instrs) | CDEF_finish (id, instrs) -> CDEF_finish (id, unique_instrs i instrs) @@ -162,7 +162,6 @@ let unique_per_function_ids cdefs = let rec cval_subst id subst = function | V_id (id', ctyp) -> if Name.compare id id' = 0 then subst else V_id (id', ctyp) - | V_ref (reg_id, ctyp) -> V_ref (reg_id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) | V_call (op, cvals) -> V_call (op, List.map (cval_subst id subst) cvals) | V_field (cval, field) -> V_field (cval_subst id subst cval, field) @@ -174,7 +173,6 @@ let rec cval_subst id subst = function let rec cval_map_id f = function | V_id (id, ctyp) -> V_id (f id, ctyp) - | V_ref (id, ctyp) -> V_ref (f id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) | V_call (call, cvals) -> V_call (call, List.map (cval_map_id f) cvals) | V_field (cval, field) -> V_field (cval_map_id f cval, field) @@ -249,6 +247,7 @@ let ssa_name i = function | Name (id, _) -> Name (id, i) | Have_exception _ -> Have_exception i | Current_exception _ -> Current_exception i + | Throw_location _ -> Throw_location i | Return _ -> Return i let inline cdefs should_inline instrs = @@ -347,6 +346,15 @@ let rec remove_pointless_goto = function instr :: remove_pointless_goto instrs | [] -> [] +let rec remove_pointless_exit = function + | I_aux (I_end id, aux) :: I_aux (I_end _, _) :: instrs -> + I_aux (I_end id, aux) :: remove_pointless_exit instrs + | I_aux (I_end id, aux) :: I_aux (I_undefined _, _) :: instrs -> + I_aux (I_end id, aux) :: remove_pointless_exit instrs + | instr :: instrs -> + instr :: remove_pointless_exit instrs + | [] -> [] + module StringSet = Set.Make(String) let rec get_used_labels set = function @@ -364,7 +372,6 @@ let remove_unused_labels instrs = in go [] instrs - let remove_dead_after_goto instrs = let rec go acc = function | (I_aux (I_goto _, _) as instr) :: instrs -> go_dead (instr :: acc) instrs @@ -379,7 +386,7 @@ let remove_dead_after_goto instrs = let rec remove_dead_code instrs = let instrs' = - instrs |> remove_unused_labels |> remove_pointless_goto |> remove_dead_after_goto + instrs |> remove_unused_labels |> remove_pointless_goto |> remove_dead_after_goto |> remove_pointless_exit in if List.length instrs' < List.length instrs then remove_dead_code instrs' @@ -398,7 +405,7 @@ let remove_tuples cdefs ctx = CTSet.add ctyp (List.fold_left CTSet.union CTSet.empty (List.map all_tuples ctyps)) | CT_struct (_, id_ctyps) | CT_variant (_, id_ctyps) -> List.fold_left (fun cts (_, ctyp) -> CTSet.union (all_tuples ctyp) cts) CTSet.empty id_ctyps - | CT_list ctyp | CT_vector (_, ctyp) | CT_ref ctyp -> + | CT_list ctyp | CT_vector (_, ctyp) | CT_fvector (_, _, ctyp) | CT_ref ctyp -> all_tuples ctyp | CT_lint | CT_fint _ | CT_lbits _ | CT_sbits _ | CT_fbits _ | CT_constant _ | CT_unit | CT_bool | CT_real | CT_bit | CT_poly | CT_string | CT_enum _ -> @@ -409,7 +416,7 @@ let remove_tuples cdefs ctx = 1 + List.fold_left (fun d ctyp -> max d (tuple_depth ctyp)) 0 ctyps | CT_struct (_, id_ctyps) | CT_variant (_, id_ctyps) -> List.fold_left (fun d (_, ctyp) -> max (tuple_depth ctyp) d) 0 id_ctyps - | CT_list ctyp | CT_vector (_, ctyp) | CT_ref ctyp -> + | CT_list ctyp | CT_vector (_, ctyp) | CT_fvector (_, _, ctyp) | CT_ref ctyp -> tuple_depth ctyp | CT_lint | CT_fint _ | CT_lbits _ | CT_sbits _ | CT_fbits _ | CT_constant _ | CT_unit | CT_bool | CT_real | CT_bit | CT_poly | CT_string | CT_enum _ -> @@ -426,6 +433,7 @@ let remove_tuples cdefs ctx = CT_variant (id, List.map (fun (id, ctyp) -> id, fix_tuples ctyp) id_ctyps) | CT_list ctyp -> CT_list (fix_tuples ctyp) | CT_vector (d, ctyp) -> CT_vector (d, fix_tuples ctyp) + | CT_fvector (n, d, ctyp) -> CT_fvector (n, d, fix_tuples ctyp) | CT_ref ctyp -> CT_ref (fix_tuples ctyp) | (CT_lint | CT_fint _ | CT_lbits _ | CT_sbits _ | CT_fbits _ | CT_constant _ | CT_unit | CT_bool | CT_real | CT_bit | CT_poly | CT_string | CT_enum _) as ctyp -> @@ -433,7 +441,6 @@ let remove_tuples cdefs ctx = in let rec fix_cval = function | V_id (id, ctyp) -> V_id (id, ctyp) - | V_ref (id, ctyp) -> V_ref (id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) | V_ctor_kind (cval, id, unifiers, ctyp) -> V_ctor_kind (fix_cval cval, id, unifiers, ctyp) diff --git a/src/jib/jib_smt.ml b/src/jib/jib_smt.ml index fbaf8d3f..81b876a4 100644 --- a/src/jib/jib_smt.ml +++ b/src/jib/jib_smt.ml @@ -73,6 +73,8 @@ let opt_debug_graphs = ref false let opt_propagate_vars = ref false +let opt_unroll_limit = ref 10 + module EventMap = Map.Make(Event) (* Note that we have to use x : ty ref rather than mutable x : ty, to @@ -89,6 +91,8 @@ type ctx = { pragma_l : Ast.l; arg_stack : (int * string) Stack.t; ast : Type_check.tannot defs; + shared : ctyp Bindings.t; + preserved : IdSet.t; events : smt_exp Stack.t EventMap.t ref; node : int; pathcond : smt_exp Lazy.t; @@ -114,6 +118,8 @@ let initial_ctx () = { pragma_l = Parse_ast.Unknown; arg_stack = Stack.create (); ast = Defs []; + shared = Bindings.empty; + preserved = IdSet.empty; events = ref EventMap.empty; node = -1; pathcond = lazy (Bool_lit true); @@ -129,6 +135,19 @@ let event_stack ctx ev = ctx.events := EventMap.add ev stack !(ctx.events); stack +let add_event ctx ev smt = + let stack = event_stack ctx ev in + Stack.push (Fn ("and", [Lazy.force ctx.pathcond; smt])) stack + +let add_pathcond_event ctx ev = + Stack.push (Lazy.force ctx.pathcond) (event_stack ctx ev) + +let overflow_check ctx smt = + if not !opt_ignore_overflow then ( + Reporting.warn "Overflow check in generated SMT for" ctx.pragma_l ""; + add_event ctx Overflow smt + ) + let lbits_size ctx = Util.power 2 ctx.lbits_index let vector_index = ref 5 @@ -179,6 +198,8 @@ let rec smt_ctyp ctx = function | _ -> failwith ("No registers with ctyp: " ^ string_of_ctyp ctyp) end | CT_list _ -> raise (Reporting.err_todo ctx.pragma_l "Lists not yet supported in SMT generation") + | CT_fvector _ -> + Reporting.unreachable ctx.pragma_l __POS__ "Found CT_fvector in SMT property" | CT_poly -> Reporting.unreachable ctx.pragma_l __POS__ "Found polymorphic type in SMT property" @@ -188,21 +209,17 @@ let rec smt_ctyp ctx = function don't have a very good way to get the binary representation of either an ocaml integer or a big integer. *) let bvpint sz x = + let open Sail2_values in if Big_int.less_equal Big_int.zero x && Big_int.less_equal x (Big_int.of_int max_int) then ( - let open Sail_lib in let x = Big_int.to_int x in - if sz mod 4 = 0 then - let hex = Printf.sprintf "%X" x in - let padding = String.make (sz / 4 - String.length hex) '0' in - Hex (padding ^ hex) - else - let bin = Printf.sprintf "%X" x |> list_of_string |> List.map hex_char |> List.concat in - let _, bin = Util.take_drop (function B0 -> true | B1 -> false) bin in - let bin = String.concat "" (List.map string_of_bit bin) in - let padding = String.make (sz - String.length bin) '0' in - Bin (padding ^ bin) + match Printf.sprintf "%X" x |> Util.string_to_list |> List.map nibble_of_char |> Util.option_all with + | Some nibbles -> + let bin = List.map (fun (a, b, c, d) -> [a; b; c; d]) nibbles |> List.concat in + let _, bin = Util.take_drop (function B0 -> true | _ -> false) bin in + let padding = List.init (sz - List.length bin) (fun _ -> B0) in + Bitvec_lit (padding @ bin) + | None -> assert false ) else if Big_int.greater x (Big_int.of_int max_int) then ( - let open Sail_lib in let y = ref x in let bin = ref [] in while (not (Big_int.equal !y Big_int.zero)) do @@ -210,14 +227,13 @@ let bvpint sz x = bin := (if Big_int.equal m Big_int.zero then B0 else B1) :: !bin; y := q done; - let bin = String.concat "" (List.map string_of_bit !bin) in - let padding_size = sz - String.length bin in + let padding_size = sz - List.length !bin in if padding_size < 0 then raise (Reporting.err_general Parse_ast.Unknown (Printf.sprintf "Could not create a %d-bit integer with value %s.\nTry increasing the maximum integer size" sz (Big_int.to_string x))); - let padding = String.make (sz - String.length bin) '0' in - Bin (padding ^ bin) + let padding = List.init padding_size (fun _ -> B0) in + Bitvec_lit (padding @ !bin) ) else failwith "Invalid bvpint" let bvint sz x = @@ -226,22 +242,68 @@ let bvint sz x = else bvpint sz x +(** [force_size ctx n m exp] takes a smt expression assumed to be a + integer (signed bitvector) of length m and forces it to be length n + by either sign extending it or truncating it as required *) +let force_size ?checked:(checked=true) ctx n m smt = + if n = m then + smt + else if n > m then + SignExtend (n - m, smt) + else + let check = + (* If the top bit of the truncated number is one *) + Ite (Fn ("=", [Extract (n - 1, n - 1, smt); Bitvec_lit [Sail2_values.B1]]), + (* Then we have an overflow, unless all bits we truncated were also one *) + Fn ("not", [Fn ("=", [Extract (m - 1, n, smt); bvones (m - n)])]), + (* Otherwise, all the top bits must be zero *) + Fn ("not", [Fn ("=", [Extract (m - 1, n, smt); bvzero (m - n)])])) + in + if checked then overflow_check ctx check else (); + Extract (n - 1, 0, smt) + +(** [unsigned_size ctx n m exp] is much like force_size, but it + assumes that the bitvector is unsigned *) +let unsigned_size ?checked:(checked=true) ctx n m smt = + if n = m then + smt + else if n > m then + Fn ("concat", [bvzero (n - m); smt]) + else + Extract (n - 1, 0, smt) + +let smt_conversion ctx from_ctyp to_ctyp x = + match from_ctyp, to_ctyp with + | _, _ when ctyp_equal from_ctyp to_ctyp -> x + | CT_constant c, CT_fint sz -> + bvint sz c + | CT_constant c, CT_lint -> + bvint ctx.lint_size c + | CT_fint sz, CT_lint -> + force_size ctx ctx.lint_size sz x + | CT_lint, CT_fint sz -> + force_size ctx sz ctx.lint_size x + | CT_lbits _, CT_fbits (n, _) -> + unsigned_size ctx n (lbits_size ctx) (Fn ("contents", [x])) + | CT_fbits (n, _), CT_lbits _ -> + Fn ("Bits", [bvint ctx.lbits_index (Big_int.of_int n); unsigned_size ctx (lbits_size ctx) n x]) + + | _, _ -> failwith (Printf.sprintf "Cannot perform conversion from %s to %s" (string_of_ctyp from_ctyp) (string_of_ctyp to_ctyp)) + (* Translate Jib literals into SMT *) -let smt_value ctx vl ctyp = +let rec smt_value ctx vl ctyp = let open Value2 in match vl, ctyp with - | VL_bits (bs, true), CT_fbits (n, _) -> - (* FIXME: Output the correct number of bits in Jib_compile *) - begin match Sail2_values.hexstring_of_bits (List.rev (Util.take n (List.rev bs))) with - | Some s -> Hex (Xstring.implode s) - | None -> Bin (Xstring.implode (List.map Sail2_values.bitU_char (List.rev (Util.take n (List.rev bs))))) - end + | VL_bits (bv, true), CT_fbits (n, _) -> + unsigned_size ctx n (List.length bv) (Bitvec_lit bv) + | VL_bits (bv, true), CT_lbits _ -> + let sz = List.length bv in + Fn ("Bits", [bvint ctx.lbits_index (Big_int.of_int sz); unsigned_size ctx (lbits_size ctx) sz (Bitvec_lit bv)]) | VL_bool b, _ -> Bool_lit b | VL_int n, CT_constant m -> bvint (required_width n) n | VL_int n, CT_fint sz -> bvint sz n | VL_int n, CT_lint -> bvint ctx.lint_size n - | VL_bit Sail2_values.B0, CT_bit -> Bin "0" - | VL_bit Sail2_values.B1, CT_bit -> Bin "1" + | VL_bit b, CT_bit -> Bitvec_lit [b] | VL_unit, _ -> Enum "unit" | VL_string str, _ -> ctx.use_string := true; @@ -252,7 +314,21 @@ let smt_value ctx vl ctyp = Fn ("-", [Real_lit (String.sub str 1 (String.length str - 1))]) else Real_lit str - | vl, _ -> failwith ("Cannot translate literal to SMT: " ^ string_of_value vl) + | VL_enum str, _ -> Enum (Util.zencode_string str) + | VL_ref reg_name, _ -> + let id = mk_id reg_name in + let rmap = CTMap.filter (fun ctyp regs -> List.exists (fun reg -> Id.compare reg id = 0) regs) ctx.register_map in + assert (CTMap.cardinal rmap = 1); + begin match CTMap.min_binding_opt rmap with + | Some (ctyp, regs) -> + begin match Util.list_index (fun reg -> Id.compare reg id = 0) regs with + | Some i -> + bvint (required_width (Big_int.of_int (List.length regs))) (Big_int.of_int i) + | None -> assert false + end + | _ -> assert false + end + | _ -> failwith ("Cannot translate literal to SMT: " ^ string_of_value vl ^ " : " ^ string_of_ctyp ctyp) let rec smt_cval ctx cval = match cval_ctyp cval with @@ -264,6 +340,7 @@ let rec smt_cval ctx cval = | V_id (Name (id, _) as ssa_id, _) -> begin match Type_check.Env.lookup_id id ctx.tc_env with | Enum _ -> Enum (zencode_id id) + | _ when Bindings.mem id ctx.shared -> Shared (zencode_id id) | _ -> Var (zencode_name ssa_id) end | V_id (ssa_id, _) -> Var (zencode_name ssa_id) @@ -271,8 +348,6 @@ let rec smt_cval ctx cval = Fn ("not", [Fn ("=", [smt_cval ctx cval1; smt_cval ctx cval2])]) | V_call (Bvor, [cval1; cval2]) -> Fn ("bvor", [smt_cval ctx cval1; smt_cval ctx cval2]) - | V_call (Bit_to_bool, [cval]) -> - Fn ("=", [smt_cval ctx cval; Bin "1"]) | V_call (Eq, [cval1; cval2]) -> Fn ("=", [smt_cval ctx cval1; smt_cval ctx cval2]) | V_call (Bnot, [cval]) -> @@ -281,14 +356,18 @@ let rec smt_cval ctx cval = smt_conj (List.map (smt_cval ctx) cvals) | V_call (Bor, cvals) -> smt_disj (List.map (smt_cval ctx) cvals) + | V_call (Igt, [cval1; cval2]) -> + Fn ("bvsgt", [smt_cval ctx cval1; smt_cval ctx cval2]) + | V_call (Iadd, [cval1; cval2]) -> + Fn ("bvadd", [smt_cval ctx cval1; smt_cval ctx cval2]) | V_ctor_kind (union, ctor_id, unifiers, _) -> Fn ("not", [Tester (zencode_uid (ctor_id, unifiers), smt_cval ctx union)]) | V_ctor_unwrap (ctor_id, union, unifiers, _) -> Fn ("un" ^ zencode_uid (ctor_id, unifiers), [smt_cval ctx union]) - | V_field (union, field) -> - begin match cval_ctyp union with + | V_field (record, field) -> + begin match cval_ctyp record with | CT_struct (struct_id, _) -> - Fn (zencode_upper_id struct_id ^ "_" ^ zencode_uid field, [smt_cval ctx union]) + Field (zencode_upper_id struct_id ^ "_" ^ zencode_uid field, smt_cval ctx record) | _ -> failwith "Field for non-struct type" end | V_struct (fields, ctyp) -> @@ -297,43 +376,18 @@ let rec smt_cval ctx cval = let set_field (field, cval) = match Util.assoc_compare_opt UId.compare field field_ctyps with | None -> failwith "Field type not found" - | Some ctyp when ctyp_equal (cval_ctyp cval) ctyp -> - smt_cval ctx cval - | _ -> failwith "Type mismatch when generating struct for SMT" + | Some ctyp -> + zencode_upper_id struct_id ^ "_" ^ zencode_uid field, + smt_conversion ctx (cval_ctyp cval) ctyp (smt_cval ctx cval) in - Fn (zencode_upper_id struct_id, List.map set_field fields) + Struct (zencode_upper_id struct_id, List.map set_field fields) | _ -> failwith "Struct does not have struct type" end | V_tuple_member (frag, len, n) -> ctx.tuple_sizes := IntSet.add len !(ctx.tuple_sizes); Fn (Printf.sprintf "tup_%d_%d" len n, [smt_cval ctx frag]) - | V_ref (Name (id, _), _) -> - let rmap = CTMap.filter (fun ctyp regs -> List.exists (fun reg -> Id.compare reg id = 0) regs) ctx.register_map in - assert (CTMap.cardinal rmap = 1); - begin match CTMap.min_binding_opt rmap with - | Some (ctyp, regs) -> - begin match Util.list_index (fun reg -> Id.compare reg id = 0) regs with - | Some i -> - bvint (required_width (Big_int.of_int (List.length regs))) (Big_int.of_int i) - | None -> assert false - end - | _ -> assert false - end | cval -> failwith ("Unrecognised cval " ^ string_of_cval cval) -let add_event ctx ev smt = - let stack = event_stack ctx ev in - Stack.push (Fn ("=>", [Lazy.force ctx.pathcond; smt])) stack - -let add_pathcond_event ctx ev = - Stack.push (Lazy.force ctx.pathcond) (event_stack ctx ev) - -let overflow_check ctx smt = - if not !opt_ignore_overflow then ( - Reporting.warn "Overflow check in generated SMT for" ctx.pragma_l ""; - add_event ctx Overflow smt - ) - (**************************************************************************) (* 1. Generating SMT for Sail builtins *) (**************************************************************************) @@ -342,8 +396,8 @@ let builtin_type_error ctx fn cvals = let args = Util.string_of_list ", " (fun cval -> string_of_ctyp (cval_ctyp cval)) cvals in function | Some ret_ctyp -> - raise (Reporting.err_todo ctx.pragma_l - (Printf.sprintf "%s : (%s) -> %s" fn args (string_of_ctyp ret_ctyp))) + let message = Printf.sprintf "%s : (%s) -> %s" fn args (string_of_ctyp ret_ctyp) in + raise (Reporting.err_todo ctx.pragma_l message) | None -> raise (Reporting.err_todo ctx.pragma_l (Printf.sprintf "%s : (%s)" fn args)) @@ -385,36 +439,6 @@ let builtin_gteq = builtin_int_comparison "bvsge" Big_int.greater_equal (* ***** Arithmetic operations: lib/arith.sail ***** *) -(** [force_size ctx n m exp] takes a smt expression assumed to be a - integer (signed bitvector) of length m and forces it to be length n - by either sign extending it or truncating it as required *) -let force_size ?checked:(checked=true) ctx n m smt = - if n = m then - smt - else if n > m then - SignExtend (n - m, smt) - else - let check = - (* If the top bit of the truncated number is one *) - Ite (Fn ("=", [Extract (n - 1, n - 1, smt); Bin "1"]), - (* Then we have an overflow, unless all bits we truncated were also one *) - Fn ("not", [Fn ("=", [Extract (m - 1, n, smt); bvones (m - n)])]), - (* Otherwise, all the top bits must be zero *) - Fn ("not", [Fn ("=", [Extract (m - 1, n, smt); bvzero (m - n)])])) - in - if checked then overflow_check ctx check else (); - Extract (n - 1, 0, smt) - -(** [unsigned_size ctx n m exp] is much like force_size, but it - assumes that the bitvector is unsigned *) -let unsigned_size ?checked:(checked=true) ctx n m smt = - if n = m then - smt - else if n > m then - Fn ("concat", [bvzero (n - m); smt]) - else - Extract (n - 1, 0, smt) - let int_size ctx = function | CT_constant n -> required_width n | CT_fint sz -> sz @@ -457,8 +481,9 @@ let builtin_negate_int ctx v ret_ctyp = | CT_constant c, _ -> bvint (int_size ctx ret_ctyp) (Big_int.negate c) | ctyp, _ -> + let open Sail2_values in let smt = force_size ctx (int_size ctx ret_ctyp) (int_size ctx ctyp) (smt_cval ctx v) in - overflow_check ctx (Fn ("=", [smt; Bin ("1" ^ String.make (int_size ctx ret_ctyp - 1) '0')])); + overflow_check ctx (Fn ("=", [smt; Bitvec_lit (B1 :: List.init (int_size ctx ret_ctyp - 1) (fun _ -> B0))])); Fn ("bvneg", [smt]) let builtin_shift_int fn big_int_fn ctx v1 v2 ret_ctyp = @@ -494,7 +519,7 @@ let builtin_abs_int ctx v ret_ctyp = | ctyp, _ -> let sz = int_size ctx ctyp in let smt = smt_cval ctx v in - Ite (Fn ("=", [Extract (sz - 1, sz -1, smt); Bin "1"]), + Ite (Fn ("=", [Extract (sz - 1, sz -1, smt); Bitvec_lit [Sail2_values.B1]]), force_size ctx (int_size ctx ret_ctyp) sz (Fn ("bvneg", [smt])), force_size ctx (int_size ctx ret_ctyp) sz smt) @@ -531,6 +556,25 @@ let builtin_min_int ctx v1 v2 ret_ctyp = smt1, smt2) +let builtin_min_int ctx v1 v2 ret_ctyp = + match cval_ctyp v1, cval_ctyp v2 with + | CT_constant n, CT_constant m -> + bvint (int_size ctx ret_ctyp) (min n m) + + | ctyp1, ctyp2 -> + let ret_sz = int_size ctx ret_ctyp in + let smt1 = force_size ctx ret_sz (int_size ctx ctyp1) (smt_cval ctx v1) in + let smt2 = force_size ctx ret_sz (int_size ctx ctyp2) (smt_cval ctx v2) in + Ite (Fn ("bvslt", [smt1; smt2]), + smt1, + smt2) + +let builtin_tdiv_int = + builtin_arith "bvudiv" (Sail2_values.tdiv_int) (fun x -> x) + +let builtin_tmod_int = + builtin_arith "bvurem" (Sail2_values.tmod_int) (fun x -> x) + let bvmask ctx len = let all_ones = bvones (lbits_size ctx) in let shift = Fn ("concat", [bvzero (lbits_size ctx - ctx.lbits_index); len]) in @@ -623,7 +667,7 @@ let builtin_sign_extend ctx vbits vlen ret_ctyp = smt_cval ctx vbits | CT_fbits (n, _), CT_fbits (m, _) -> let bv = smt_cval ctx vbits in - let top_bit_one = Fn ("=", [Extract (n - 1, n - 1, bv); Bin "1"]) in + let top_bit_one = Fn ("=", [Extract (n - 1, n - 1, bv); Bitvec_lit [Sail2_values.B1]]) in Ite (top_bit_one, Fn ("concat", [bvones (m - n); bv]), Fn ("concat", [bvzero (m - n); bv])) | _ -> builtin_type_error ctx "sign_extend" [vbits; vlen] (Some ret_ctyp) @@ -658,14 +702,14 @@ let builtin_not_bits ctx v ret_ctyp = | _, _ -> builtin_type_error ctx "not_bits" [v] (Some ret_ctyp) let builtin_bitwise fn ctx v1 v2 ret_ctyp = - match cval_ctyp v1, cval_ctyp v2 with - | CT_fbits (n, _), CT_fbits (m, _) -> - assert (n = m); + match cval_ctyp v1, cval_ctyp v2, ret_ctyp with + | CT_fbits (n, _), CT_fbits (m, _), CT_fbits (o, _) -> + assert (n = m && m = o); let smt1 = smt_cval ctx v1 in let smt2 = smt_cval ctx v2 in Fn (fn, [smt1; smt2]) - | CT_lbits _, CT_lbits _ -> + | CT_lbits _, CT_lbits _, CT_lbits _ -> let smt1 = smt_cval ctx v1 in let smt2 = smt_cval ctx v2 in Fn ("Bits", [Fn ("len", [smt1]); Fn (fn, [Fn ("contents", [smt1]); Fn ("contents", [smt2])])]) @@ -674,6 +718,7 @@ let builtin_bitwise fn ctx v1 v2 ret_ctyp = let builtin_and_bits = builtin_bitwise "bvand" let builtin_or_bits = builtin_bitwise "bvor" +let builtin_xor_bits = builtin_bitwise "bvxor" let builtin_append ctx v1 v2 ret_ctyp = match cval_ctyp v1, cval_ctyp v2, ret_ctyp with @@ -743,19 +788,29 @@ let builtin_length ctx v ret_ctyp = | _, _ -> builtin_type_error ctx "length" [v] (Some ret_ctyp) let builtin_vector_subrange ctx vec i j ret_ctyp = - match cval_ctyp vec, cval_ctyp i, cval_ctyp j with - | CT_fbits (n, _), CT_constant i, CT_constant j -> + match cval_ctyp vec, cval_ctyp i, cval_ctyp j, ret_ctyp with + | CT_fbits (n, _), CT_constant i, CT_constant j, CT_fbits _ -> Extract (Big_int.to_int i, Big_int.to_int j, smt_cval ctx vec) - | CT_lbits _, CT_constant i, CT_constant j -> + | CT_lbits _, CT_constant i, CT_constant j, CT_fbits _ -> Extract (Big_int.to_int i, Big_int.to_int j, Fn ("contents", [smt_cval ctx vec])) + | CT_fbits (n, _), i_ctyp, CT_constant j, CT_lbits _ when Big_int.equal j Big_int.zero -> + let len = force_size ~checked:false ctx ctx.lbits_index (int_size ctx i_ctyp) (smt_cval ctx i) in + Fn ("Bits", [len; Fn ("bvand", [bvmask ctx len; unsigned_size ctx (lbits_size ctx) n (smt_cval ctx vec)])]) + | _ -> builtin_type_error ctx "vector_subrange" [vec; i; j] (Some ret_ctyp) let builtin_vector_access ctx vec i ret_ctyp = match cval_ctyp vec, cval_ctyp i, ret_ctyp with | CT_fbits (n, _), CT_constant i, CT_bit -> Extract (Big_int.to_int i, Big_int.to_int i, smt_cval ctx vec) + | CT_lbits _, CT_constant i, CT_bit -> + Extract (Big_int.to_int i, Big_int.to_int i, Fn ("contents", [smt_cval ctx vec])) + + | CT_lbits _, i_ctyp, CT_bit -> + let shift = force_size ~checked:false ctx (lbits_size ctx) (int_size ctx i_ctyp) (smt_cval ctx i) in + Extract (0, 0, Fn ("bvlshr", [Fn ("contents", [smt_cval ctx vec]); shift])) | CT_vector _, CT_constant i, _ -> Fn ("select", [smt_cval ctx vec; bvint !vector_index i]) @@ -787,6 +842,21 @@ let builtin_vector_update ctx vec i x ret_ctyp = | _ -> builtin_type_error ctx "vector_update" [vec; i; x] (Some ret_ctyp) +let builtin_vector_update_subrange ctx vec i j x ret_ctyp = + match cval_ctyp vec, cval_ctyp i, cval_ctyp j, cval_ctyp x, ret_ctyp with + | CT_fbits (n, _), CT_constant i, CT_constant j, CT_fbits (sz, _), CT_fbits (m, _) when n - 1 > Big_int.to_int i && Big_int.to_int j >= 0 -> + assert (n = m); + let top = Extract (n - 1, Big_int.to_int i + 1, smt_cval ctx vec) in + let bot = Extract (Big_int.to_int j - 1, 0, smt_cval ctx vec) in + Fn ("concat", [top; Fn ("concat", [smt_cval ctx x; bot])]) + + | CT_fbits (n, _), CT_constant i, CT_constant j, CT_fbits (sz, _), CT_fbits (m, _) when n - 1 = Big_int.to_int i && Big_int.to_int j >= 0 -> + assert (n = m); + let bot = Extract (Big_int.to_int j - 1, 0, smt_cval ctx vec) in + Fn ("concat", [smt_cval ctx x; bot]) + + | _ -> builtin_type_error ctx "vector_update_subrange" [vec; i; j; x] (Some ret_ctyp) + let builtin_unsigned ctx v ret_ctyp = match cval_ctyp v, ret_ctyp with | CT_fbits (n, _), CT_fint m when m > n -> @@ -800,6 +870,9 @@ let builtin_unsigned ctx v ret_ctyp = let smt = smt_cval ctx v in Fn ("concat", [bvzero (ctx.lint_size - n); smt]) + | CT_lbits _, CT_lint -> + Extract (ctx.lint_size - 1, 0, Fn ("contents", [smt_cval ctx v])) + | ctyp, _ -> builtin_type_error ctx "unsigned" [v] (Some ret_ctyp) let builtin_signed ctx v ret_ctyp = @@ -810,6 +883,9 @@ let builtin_signed ctx v ret_ctyp = | CT_fbits (n, _), CT_lint -> SignExtend(ctx.lint_size - n, smt_cval ctx v) + | CT_lbits _, CT_lint -> + Extract (ctx.lint_size - 1, 0, Fn ("contents", [smt_cval ctx v])) + | ctyp, _ -> builtin_type_error ctx "signed" [v] (Some ret_ctyp) let builtin_add_bits ctx v1 v2 ret_ctyp = @@ -818,6 +894,11 @@ let builtin_add_bits ctx v1 v2 ret_ctyp = assert (n = m && m = o); Fn ("bvadd", [smt_cval ctx v1; smt_cval ctx v2]) + | CT_lbits _, CT_lbits _, CT_lbits _ -> + let smt1 = smt_cval ctx v1 in + let smt2 = smt_cval ctx v2 in + Fn ("Bits", [Fn ("len", [smt1]); Fn ("bvadd", [Fn ("contents", [smt1]); Fn ("contents", [smt2])])]) + | _ -> builtin_type_error ctx "add_bits" [v1; v2] (Some ret_ctyp) let builtin_sub_bits ctx v1 v2 ret_ctyp = @@ -866,6 +947,13 @@ let builtin_replicate_bits ctx v1 v2 ret_ctyp = let c = m / n in Fn ("concat", List.init c (fun _ -> smt)) + | CT_fbits (n, _), v2_ctyp, CT_lbits _ -> + let times = (lbits_size ctx / n) + 1 in + let len = force_size ~checked:false ctx ctx.lbits_index (int_size ctx v2_ctyp) (smt_cval ctx v2) in + let smt1 = smt_cval ctx v1 in + let contents = Extract (lbits_size ctx - 1, 0, Fn ("concat", List.init times (fun _ -> smt1))) in + Fn ("Bits", [len; Fn ("bvand", [bvmask ctx len; contents])]) + | _ -> builtin_type_error ctx "replicate_bits" [v1; v2] (Some ret_ctyp) let builtin_sail_truncate ctx v1 v2 ret_ctyp = @@ -928,13 +1016,18 @@ let builtin_get_slice_int ctx v1 v2 v3 ret_ctyp = in Extract ((start + len) - 1, start, smt) + | CT_lint, CT_lint, CT_constant start, CT_lbits _ when Big_int.equal start Big_int.zero -> + let len = Extract (ctx.lbits_index - 1, 0, smt_cval ctx v1) in + let contents = unsigned_size ~checked:false ctx (lbits_size ctx) ctx.lint_size (smt_cval ctx v2) in + Fn ("Bits", [len; Fn ("bvand", [bvmask ctx len; contents])]) + | _ -> builtin_type_error ctx "get_slice_int" [v1; v2; v3] (Some ret_ctyp) let builtin_count_leading_zeros ctx v ret_ctyp = let ret_sz = int_size ctx ret_ctyp in let rec lzcnt sz smt = if sz == 1 then - Ite (Fn ("=", [Extract (0, 0, smt); Bin "0"]), + Ite (Fn ("=", [Extract (0, 0, smt); Bitvec_lit [Sail2_values.B0]]), bvint ret_sz (Big_int.of_int 1), bvint ret_sz (Big_int.zero)) else ( @@ -1050,6 +1143,8 @@ let smt_builtin ctx name args ret_ctyp = | "max_int", [v1; v2], _ -> builtin_max_int ctx v1 v2 ret_ctyp | "min_int", [v1; v2], _ -> builtin_min_int ctx v1 v2 ret_ctyp + | "ediv_int", [v1; v2], _ -> builtin_tdiv_int ctx v1 v2 ret_ctyp + (* All signed and unsigned bitvector comparisons *) | "slt_bits", [v1; v2], CT_bool -> builtin_compare_bits "bvslt" ctx v1 v2 ret_ctyp | "ult_bits", [v1; v2], CT_bool -> builtin_compare_bits "bvult" ctx v1 v2 ret_ctyp @@ -1072,8 +1167,9 @@ let smt_builtin ctx name args ret_ctyp = | "sail_truncateLSB", [v1; v2], _ -> builtin_sail_truncateLSB ctx v1 v2 ret_ctyp | "shiftl", [v1; v2], _ -> builtin_shift "bvshl" ctx v1 v2 ret_ctyp | "shiftr", [v1; v2], _ -> builtin_shift "bvlshr" ctx v1 v2 ret_ctyp - | "or_bits", [v1; v2], _ -> builtin_or_bits ctx v1 v2 ret_ctyp | "and_bits", [v1; v2], _ -> builtin_and_bits ctx v1 v2 ret_ctyp + | "or_bits", [v1; v2], _ -> builtin_or_bits ctx v1 v2 ret_ctyp + | "xor_bits", [v1; v2], _ -> builtin_xor_bits ctx v1 v2 ret_ctyp | "not_bits", [v], _ -> builtin_not_bits ctx v ret_ctyp | "add_bits", [v1; v2], _ -> builtin_add_bits ctx v1 v2 ret_ctyp | "add_bits_int", [v1; v2], _ -> builtin_add_bits_int ctx v1 v2 ret_ctyp @@ -1084,6 +1180,7 @@ let smt_builtin ctx name args ret_ctyp = | "vector_access", [v1; v2], ret_ctyp -> builtin_vector_access ctx v1 v2 ret_ctyp | "vector_subrange", [v1; v2; v3], ret_ctyp -> builtin_vector_subrange ctx v1 v2 v3 ret_ctyp | "vector_update", [v1; v2; v3], ret_ctyp -> builtin_vector_update ctx v1 v2 v3 ret_ctyp + | "vector_update_subrange", [v1; v2; v3; v4], ret_ctyp -> builtin_vector_update_subrange ctx v1 v2 v3 v4 ret_ctyp | "sail_unsigned", [v], ret_ctyp -> builtin_unsigned ctx v ret_ctyp | "sail_signed", [v], ret_ctyp -> builtin_signed ctx v ret_ctyp | "replicate_bits", [v1; v2], ret_ctyp -> builtin_replicate_bits ctx v1 v2 ret_ctyp @@ -1110,16 +1207,30 @@ let smt_builtin ctx name args ret_ctyp = | "lteq_real", [v1; v2], CT_bool -> ctx.use_real := true; Fn ("<=", [smt_cval ctx v1; smt_cval ctx v2]) | "gteq_real", [v1; v2], CT_bool -> ctx.use_real := true; Fn (">=", [smt_cval ctx v1; smt_cval ctx v2]) - | _ -> failwith ("Unknown builtin " ^ name ^ " " ^ Util.string_of_list ", " string_of_ctyp (List.map cval_ctyp args) ^ " -> " ^ string_of_ctyp ret_ctyp) + | _ -> + Reporting.unreachable ctx.pragma_l __POS__ ("Unknown builtin " ^ name ^ " " ^ Util.string_of_list ", " string_of_ctyp (List.map cval_ctyp args) ^ " -> " ^ string_of_ctyp ret_ctyp) + +let loc_doc = function + | Parse_ast.Documented (str, l) -> str + | _ -> "UNKNOWN" (* Memory reads and writes as defined in lib/regfp.sail *) let writes = ref (-1) -let builtin_write_mem ctx wk addr_size addr data_size data = +let builtin_write_mem l ctx wk addr_size addr data_size data = incr writes; let name = "W" ^ string_of_int !writes in - [Write_mem (name, ctx.node, Lazy.force ctx.pathcond, smt_cval ctx wk, - smt_cval ctx addr, smt_ctyp ctx (cval_ctyp addr), smt_cval ctx data, smt_ctyp ctx (cval_ctyp data))], + [Write_mem { + name = name; + node = ctx.node; + active = Lazy.force ctx.pathcond; + kind = smt_cval ctx wk; + addr = smt_cval ctx addr; + addr_type = smt_ctyp ctx (cval_ctyp addr); + data = smt_cval ctx data; + data_type = smt_ctyp ctx (cval_ctyp data); + doc = loc_doc l + }], Var (name ^ "_ret") let ea_writes = ref (-1) @@ -1133,11 +1244,19 @@ let builtin_write_mem_ea ctx wk addr_size addr data_size = let reads = ref (-1) -let builtin_read_mem ctx rk addr_size addr data_size ret_ctyp = +let builtin_read_mem l ctx rk addr_size addr data_size ret_ctyp = incr reads; let name = "R" ^ string_of_int !reads in - [Read_mem (name, ctx.node, Lazy.force ctx.pathcond, smt_ctyp ctx ret_ctyp, smt_cval ctx rk, - smt_cval ctx addr, smt_ctyp ctx (cval_ctyp addr))], + [Read_mem { + name = name; + node = ctx.node; + active = Lazy.force ctx.pathcond; + ret_type = smt_ctyp ctx ret_ctyp; + kind = smt_cval ctx rk; + addr = smt_cval ctx addr; + addr_type = smt_ctyp ctx (cval_ctyp addr); + doc = loc_doc l + }], Read_res name let excl_results = ref (-1) @@ -1150,26 +1269,51 @@ let builtin_excl_res ctx = let barriers = ref (-1) -let builtin_barrier ctx bk = +let builtin_barrier l ctx bk = incr barriers; let name = "B" ^ string_of_int !barriers in - [Barrier (name, ctx.node, Lazy.force ctx.pathcond, smt_cval ctx bk)], + [Barrier { + name = name; + node = ctx.node; + active = Lazy.force ctx.pathcond; + kind = smt_cval ctx bk; + doc = loc_doc l + }], Enum "unit" -let rec smt_conversion ctx from_ctyp to_ctyp x = - match from_ctyp, to_ctyp with - | _, _ when ctyp_equal from_ctyp to_ctyp -> x - | CT_constant c, CT_fint sz -> - bvint sz c - | CT_constant c, CT_lint -> - bvint ctx.lint_size c - | CT_fint sz, CT_lint -> - force_size ctx ctx.lint_size sz x - | CT_lbits _, CT_fbits (n, _) -> - unsigned_size ctx n (lbits_size ctx) (Fn ("contents", [x])) - | _, _ -> failwith (Printf.sprintf "Cannot perform conversion from %s to %s" (string_of_ctyp from_ctyp) (string_of_ctyp to_ctyp)) +let cache_maintenances = ref (-1) + +let builtin_cache_maintenance l ctx cmk addr_size addr = + incr cache_maintenances; + let name = "M" ^ string_of_int !cache_maintenances in + [Cache_maintenance { + name = name; + node = ctx.node; + active = Lazy.force ctx.pathcond; + kind = smt_cval ctx cmk; + addr = smt_cval ctx addr; + addr_type = smt_ctyp ctx (cval_ctyp addr); + doc = loc_doc l + }], + Enum "unit" + +let branch_announces = ref (-1) + +let builtin_branch_announce l ctx addr_size addr = + incr branch_announces; + let name = "C" ^ string_of_int !branch_announces in + [Branch_announce { + name = name; + node = ctx.node; + active = Lazy.force ctx.pathcond; + addr = smt_cval ctx addr; + addr_type = smt_ctyp ctx (cval_ctyp addr); + doc = loc_doc l + }], + Enum "unit" let define_const ctx id ctyp exp = Define_const (zencode_name id, smt_ctyp ctx ctyp, exp) +let preserve_const ctx id ctyp exp = Preserve_const (string_of_id id, smt_ctyp ctx ctyp, exp) let declare_const ctx id ctyp = Declare_const (zencode_name id, smt_ctyp ctx ctyp) let smt_ctype_def ctx = function @@ -1205,143 +1349,144 @@ let rec generate_reg_decs ctx inits = function let max_int n = Big_int.pred (Big_int.pow_int_positive 2 (n - 1)) let min_int n = Big_int.negate (Big_int.pow_int_positive 2 (n - 1)) -(** Convert a sail type into a C-type. This function can be quite - slow, because it uses ctx.local_env and SMT to analyse the Sail - types and attempts to fit them into the smallest possible C - types, provided ctx.optimize_smt is true (default) **) -let rec ctyp_of_typ ctx typ = - let open Ast in - let open Type_check in - let open Jib_compile in - let Typ_aux (typ_aux, l) as typ = Env.expand_synonyms ctx.tc_env typ in - match typ_aux with - | Typ_id id when string_of_id id = "bit" -> CT_bit - | Typ_id id when string_of_id id = "bool" -> CT_bool - | Typ_id id when string_of_id id = "int" -> CT_lint - | Typ_id id when string_of_id id = "nat" -> CT_lint - | Typ_id id when string_of_id id = "unit" -> CT_unit - | Typ_id id when string_of_id id = "string" -> CT_string - | Typ_id id when string_of_id id = "real" -> CT_real - - | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool - - | Typ_app (id, args) when string_of_id id = "itself" -> - ctyp_of_typ ctx (Typ_aux (Typ_app (mk_id "atom", args), l)) - | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" || string_of_id id = "implicit" -> - begin match destruct_range Env.empty typ with - | None -> assert false (* Checked if range type in guard *) - | Some (kids, constr, n, m) -> - let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env } in - match nexp_simp n, nexp_simp m with - | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) - when n = m -> - CT_constant n - | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) - when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> - CT_fint 64 - | n, m -> - if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then +module SMT_config : Jib_compile.Config = struct + open Jib_compile + + (** Convert a sail type into a C-type. This function can be quite + slow, because it uses ctx.local_env and SMT to analyse the Sail + types and attempts to fit them into the smallest possible C + types, provided ctx.optimize_smt is true (default) **) + let rec convert_typ ctx typ = + let open Ast in + let open Type_check in + let Typ_aux (typ_aux, l) as typ = Env.expand_synonyms ctx.tc_env typ in + match typ_aux with + | Typ_id id when string_of_id id = "bit" -> CT_bit + | Typ_id id when string_of_id id = "bool" -> CT_bool + | Typ_id id when string_of_id id = "int" -> CT_lint + | Typ_id id when string_of_id id = "nat" -> CT_lint + | Typ_id id when string_of_id id = "unit" -> CT_unit + | Typ_id id when string_of_id id = "string" -> CT_string + | Typ_id id when string_of_id id = "real" -> CT_real + + | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool + + | Typ_app (id, args) when string_of_id id = "itself" -> + convert_typ ctx (Typ_aux (Typ_app (mk_id "atom", args), l)) + | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" || string_of_id id = "implicit" -> + begin match destruct_range Env.empty typ with + | None -> assert false (* Checked if range type in guard *) + | Some (kids, constr, n, m) -> + let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env } in + match nexp_simp n, nexp_simp m with + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + when n = m -> + CT_constant n + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> CT_fint 64 - else - CT_lint - end - - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> - CT_list (ctyp_of_typ ctx typ) - - (* Note that we have to use lbits for zero-length bitvectors because they are not allowed by SMTLIB *) - | Typ_app (id, [A_aux (A_nexp n, _); A_aux (A_order ord, _)]) - when string_of_id id = "bitvector" -> - let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in - begin match nexp_simp n with - | Nexp_aux (Nexp_constant n, _) when Big_int.equal n Big_int.zero -> CT_lbits direction - | Nexp_aux (Nexp_constant n, _) -> CT_fbits (Big_int.to_int n, direction) - | _ -> CT_lbits direction - end - - | Typ_app (id, [A_aux (A_nexp n, _); - A_aux (A_order ord, _); - A_aux (A_typ typ, _)]) - when string_of_id id = "vector" -> - let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in - CT_vector (direction, ctyp_of_typ ctx typ) - - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "register" -> - CT_ref (ctyp_of_typ ctx typ) - - | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> UBindings.bindings) - | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.variants -> CT_variant (id, Bindings.find id ctx.variants |> UBindings.bindings) - | Typ_id id when Bindings.mem id ctx.enums -> CT_enum (id, Bindings.find id ctx.enums |> IdSet.elements) - - | Typ_tup typs -> CT_tup (List.map (ctyp_of_typ ctx) typs) - - | Typ_exist _ -> - (* Use Type_check.destruct_exist when optimising with SMT, to - ensure that we don't cause any type variable clashes in - local_env, and that we can optimize the existential based upon - it's constraints. *) - begin match destruct_exist (Env.expand_synonyms ctx.local_env typ) with - | Some (kids, nc, typ) -> - let env = add_existential l kids nc ctx.local_env in - ctyp_of_typ { ctx with local_env = env } typ - | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!") - end - - | Typ_var kid -> CT_poly - - | _ -> raise (Reporting.err_unreachable l __POS__ ("No SMT type for type " ^ string_of_typ typ)) + | n, m -> + if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then + CT_fint 64 + else + CT_lint + end -(**************************************************************************) -(* 3. Optimization of primitives and literals *) -(**************************************************************************) + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> + CT_list (convert_typ ctx typ) + + (* Note that we have to use lbits for zero-length bitvectors because they are not allowed by SMTLIB *) + | Typ_app (id, [A_aux (A_nexp n, _); A_aux (A_order ord, _)]) + when string_of_id id = "bitvector" -> + let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in + begin match nexp_simp n with + | Nexp_aux (Nexp_constant n, _) when Big_int.equal n Big_int.zero -> CT_lbits direction + | Nexp_aux (Nexp_constant n, _) -> CT_fbits (Big_int.to_int n, direction) + | _ -> CT_lbits direction + end -let hex_char = - let open Sail2_values in - function - | '0' -> [B0; B0; B0; B0] - | '1' -> [B0; B0; B0; B1] - | '2' -> [B0; B0; B1; B0] - | '3' -> [B0; B0; B1; B1] - | '4' -> [B0; B1; B0; B0] - | '5' -> [B0; B1; B0; B1] - | '6' -> [B0; B1; B1; B0] - | '7' -> [B0; B1; B1; B1] - | '8' -> [B1; B0; B0; B0] - | '9' -> [B1; B0; B0; B1] - | 'A' | 'a' -> [B1; B0; B1; B0] - | 'B' | 'b' -> [B1; B0; B1; B1] - | 'C' | 'c' -> [B1; B1; B0; B0] - | 'D' | 'd' -> [B1; B1; B0; B1] - | 'E' | 'e' -> [B1; B1; B1; B0] - | 'F' | 'f' -> [B1; B1; B1; B1] - | _ -> failwith "Invalid hex character" - -let literal_to_cval (L_aux (l_aux, _) as lit) = - match l_aux with - | L_num n -> Some (V_lit (VL_int n, CT_constant n)) - | L_hex str when String.length str <= 16 -> - let content = Util.string_to_list str |> List.map hex_char |> List.concat in - Some (V_lit (VL_bits (content, true), CT_fbits (String.length str * 4, true))) - | L_unit -> Some (V_lit (VL_unit, CT_unit)) - | L_true -> Some (V_lit (VL_bool true, CT_bool)) - | L_false -> Some (V_lit (VL_bool false, CT_bool)) - | _ -> None - -let c_literals ctx = - let rec c_literal env l = function - | AV_lit (lit, typ) as v -> - begin match literal_to_cval lit with - | Some cval -> AV_cval (cval, typ) - | None -> v + | Typ_app (id, [A_aux (A_nexp n, _); + A_aux (A_order ord, _); + A_aux (A_typ typ, _)]) + when string_of_id id = "vector" -> + let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in + CT_vector (direction, convert_typ ctx typ) + + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "register" -> + CT_ref (convert_typ ctx typ) + + | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> UBindings.bindings) + | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.variants -> CT_variant (id, Bindings.find id ctx.variants |> UBindings.bindings) + | Typ_id id when Bindings.mem id ctx.enums -> CT_enum (id, Bindings.find id ctx.enums |> IdSet.elements) + + | Typ_tup typs -> CT_tup (List.map (convert_typ ctx) typs) + + | Typ_exist _ -> + (* Use Type_check.destruct_exist when optimising with SMT, to + ensure that we don't cause any type variable clashes in + local_env, and that we can optimize the existential based + upon it's constraints. *) + begin match destruct_exist (Env.expand_synonyms ctx.local_env typ) with + | Some (kids, nc, typ) -> + let env = add_existential l kids nc ctx.local_env in + convert_typ { ctx with local_env = env } typ + | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!") end - | AV_tuple avals -> AV_tuple (List.map (c_literal env l) avals) - | v -> v - in - map_aval c_literal -let unroll_foreach ctx = function + | Typ_var kid -> CT_poly + + | _ -> raise (Reporting.err_unreachable l __POS__ ("No SMT type for type " ^ string_of_typ typ)) + + let hex_char = + let open Sail2_values in + function + | '0' -> [B0; B0; B0; B0] + | '1' -> [B0; B0; B0; B1] + | '2' -> [B0; B0; B1; B0] + | '3' -> [B0; B0; B1; B1] + | '4' -> [B0; B1; B0; B0] + | '5' -> [B0; B1; B0; B1] + | '6' -> [B0; B1; B1; B0] + | '7' -> [B0; B1; B1; B1] + | '8' -> [B1; B0; B0; B0] + | '9' -> [B1; B0; B0; B1] + | 'A' | 'a' -> [B1; B0; B1; B0] + | 'B' | 'b' -> [B1; B0; B1; B1] + | 'C' | 'c' -> [B1; B1; B0; B0] + | 'D' | 'd' -> [B1; B1; B0; B1] + | 'E' | 'e' -> [B1; B1; B1; B0] + | 'F' | 'f' -> [B1; B1; B1; B1] + | _ -> failwith "Invalid hex character" + + let literal_to_cval (L_aux (l_aux, _) as lit) = + match l_aux with + | L_num n -> Some (V_lit (VL_int n, CT_constant n)) + | L_hex str when String.length str <= 16 -> + let content = Util.string_to_list str |> List.map hex_char |> List.concat in + Some (V_lit (VL_bits (content, true), CT_fbits (String.length str * 4, true))) + | L_unit -> Some (V_lit (VL_unit, CT_unit)) + | L_true -> Some (V_lit (VL_bool true, CT_bool)) + | L_false -> Some (V_lit (VL_bool false, CT_bool)) + | _ -> None + + let c_literals ctx = + let rec c_literal env l = function + | AV_lit (lit, typ) as v -> + begin match literal_to_cval lit with + | Some cval -> AV_cval (cval, typ) + | None -> v + end + | AV_tuple avals -> AV_tuple (List.map (c_literal env l) avals) + | v -> v + in + map_aval c_literal + +(* If we know the loop variables exactly (especially after + specialization), we can unroll the exact number of times required, + and omit any comparisons. *) +let unroll_static_foreach ctx = function | AE_aux (AE_for (id, from_aexp, to_aexp, by_aexp, order, body), env, l) as aexp -> - begin match ctyp_of_typ ctx (aexp_typ from_aexp), ctyp_of_typ ctx (aexp_typ to_aexp), ctyp_of_typ ctx (aexp_typ by_aexp), order with + begin match convert_typ ctx (aexp_typ from_aexp), convert_typ ctx (aexp_typ to_aexp), convert_typ ctx (aexp_typ by_aexp), order with | CT_constant f, CT_constant t, CT_constant b, Ord_aux (Ord_inc, _) -> let i = ref f in let unrolled = ref [] in @@ -1360,6 +1505,19 @@ let unroll_foreach ctx = function end | aexp -> aexp + let optimize_anf ctx aexp = + aexp + |> c_literals ctx + |> fold_aexp (unroll_static_foreach ctx) + + let specialize_calls = true + let ignore_64 = true + let unroll_loops () = Some !opt_unroll_limit + let struct_value = true + let use_real = true +end + + (**************************************************************************) (* 3. Generating SMT *) (**************************************************************************) @@ -1414,7 +1572,7 @@ let smt_ssanode ctx cfg preds = pis ids None in match mux with - | None -> [] + | None -> assert false | Some mux -> [Define_const (zencode_name id, smt_ctyp ctx ctyp, mux)] @@ -1492,7 +1650,7 @@ let rec rmw_write = function | CL_id _ -> assert false | CL_tuple (clexp, _) -> rmw_write clexp | CL_field (clexp, _) -> rmw_write clexp - | clexp -> assert false + | clexp -> failwith "Could not understand l-expression" let rmw_read = function | CL_rmw (read, _, _) -> zencode_name read @@ -1522,7 +1680,7 @@ let rmw_modify smt = function if UId.compare field field' = 0 then smt else - Fn (zencode_upper_id struct_id ^ "_" ^ zencode_uid field', [Var (rmw_read clexp)]) + Field (zencode_upper_id struct_id ^ "_" ^ zencode_uid field', Var (rmw_read clexp)) in Fn (zencode_upper_id struct_id, List.map set_field fields) | _ -> @@ -1564,7 +1722,7 @@ let smt_instr ctx = else if name = "platform_write_mem" then begin match args with | [wk; addr_size; addr; data_size; data] -> - let mem_event, var = builtin_write_mem ctx wk addr_size addr data_size data in + let mem_event, var = builtin_write_mem l ctx wk addr_size addr data_size data in mem_event @ [define_const ctx id ret_ctyp var] | _ -> Reporting.unreachable l __POS__ "Bad arguments for __write_mem" @@ -1580,7 +1738,7 @@ let smt_instr ctx = else if name = "platform_read_mem" then begin match args with | [rk; addr_size; addr; data_size] -> - let mem_event, var = builtin_read_mem ctx rk addr_size addr data_size ret_ctyp in + let mem_event, var = builtin_read_mem l ctx rk addr_size addr data_size ret_ctyp in mem_event @ [define_const ctx id ret_ctyp var] | _ -> Reporting.unreachable l __POS__ "Bad arguments for __read_mem" @@ -1588,7 +1746,23 @@ let smt_instr ctx = else if name = "platform_barrier" then begin match args with | [bk] -> - let mem_event, var = builtin_barrier ctx bk in + let mem_event, var = builtin_barrier l ctx bk in + mem_event @ [define_const ctx id ret_ctyp var] + | _ -> + Reporting.unreachable l __POS__ "Bad arguments for __barrier" + end + else if name = "platform_cache_maintenance" then + begin match args with + | [cmk; addr_size; addr] -> + let mem_event, var = builtin_cache_maintenance l ctx cmk addr_size addr in + mem_event @ [define_const ctx id ret_ctyp var] + | _ -> + Reporting.unreachable l __POS__ "Bad arguments for __barrier" + end + else if name = "platform_branch_announce" then + begin match args with + | [addr_size; addr] -> + let mem_event, var = builtin_branch_announce l ctx addr_size addr in mem_event @ [define_const ctx id ret_ctyp var] | _ -> Reporting.unreachable l __POS__ "Bad arguments for __barrier" @@ -1601,9 +1775,20 @@ let smt_instr ctx = | _ -> Reporting.unreachable l __POS__ "Bad arguments for __excl_res" end + else if name = "sail_exit" then + (add_event ctx Assertion (Bool_lit false); []) + else if name = "sail_assert" then + begin match args with + | [assertion; _] -> + let smt = smt_cval ctx assertion in + add_event ctx Assertion (Fn ("not", [smt])); + [] + | _ -> + Reporting.unreachable l __POS__ "Bad arguments for assertion" + end else let value = smt_builtin ctx name args ret_ctyp in - [define_const ctx id ret_ctyp value] + [define_const ctx id ret_ctyp (Syntactic (value, List.map (smt_cval ctx) args))] else if extern && string_of_id (fst function_id) = "internal_vector_init" then [declare_const ctx id ret_ctyp] else if extern && string_of_id (fst function_id) = "internal_vector_update" then @@ -1615,15 +1800,6 @@ let smt_instr ctx = | _ -> Reporting.unreachable l __POS__ "Bad arguments for internal_vector_update" end - else if string_of_id (fst function_id) = "sail_assert" then - begin match args with - | [assertion; _] -> - let smt = smt_cval ctx assertion in - add_event ctx Assertion smt; - [] - | _ -> - Reporting.unreachable l __POS__ "Bad arguments for assertion" - end else if string_of_id (fst function_id) = "sail_assume" then begin match args with | [assumption] -> @@ -1643,8 +1819,14 @@ let smt_instr ctx = Reporting.unreachable l __POS__ "Register reference write should be re-written by now" | I_aux (I_init (ctyp, id, cval), _) | I_aux (I_copy (CL_id (id, ctyp), cval), _) -> - [define_const ctx id ctyp - (smt_conversion ctx (cval_ctyp cval) ctyp (smt_cval ctx cval))] + begin match id with + | Name (id, _) when IdSet.mem id ctx.preserved -> + [preserve_const ctx id ctyp + (smt_conversion ctx (cval_ctyp cval) ctyp (smt_cval ctx cval))] + | _ -> + [define_const ctx id ctyp + (smt_conversion ctx (cval_ctyp cval) ctyp (smt_cval ctx cval))] + end | I_aux (I_copy (clexp, cval), _) -> let smt = smt_cval ctx cval in @@ -1721,13 +1903,19 @@ module Make_optimizer(S : Sequence) = struct | Some n -> Hashtbl.replace uses var (n + 1) | None -> Hashtbl.add uses var 1 end - | Enum _ | Read_res _ | Hex _ | Bin _ | Bool_lit _ | String_lit _ | Real_lit _ -> () + | Syntactic (exp, _) -> uses_in_exp exp + | Shared _ | Enum _ | Read_res _ | Bitvec_lit _ | Bool_lit _ | String_lit _ | Real_lit _ -> () | Fn (_, exps) | Ctor (_, exps) -> List.iter uses_in_exp exps + | Field (_, exp) -> + uses_in_exp exp + | Struct (_, fields) -> + List.iter (fun (_, exp) -> uses_in_exp exp) fields | Ite (cond, t, e) -> uses_in_exp cond; uses_in_exp t; uses_in_exp e | Extract (_, _, exp) | Tester (_, exp) | SignExtend (_, exp) -> uses_in_exp exp + | Forall _ -> assert false in let remove_unused () = function @@ -1737,6 +1925,11 @@ module Make_optimizer(S : Sequence) = struct | Some _ -> Stack.push def stack' end + | Declare_fun _ as def -> + Stack.push def stack' + | Preserve_const (_, _, exp) as def -> + uses_in_exp exp; + Stack.push def stack' | Define_const (var, _, exp) as def -> begin match Hashtbl.find_opt uses var with | None -> () @@ -1746,17 +1939,23 @@ module Make_optimizer(S : Sequence) = struct end | (Declare_datatypes _ | Declare_tuple _) as def -> Stack.push def stack' - | Write_mem (_, _, active, wk, addr, _, data, _) as def -> - uses_in_exp active; uses_in_exp wk; uses_in_exp addr; uses_in_exp data; + | Write_mem w as def -> + uses_in_exp w.active; uses_in_exp w.kind; uses_in_exp w.addr; uses_in_exp w.data; Stack.push def stack' | Write_mem_ea (_, _, active, wk, addr, _, data_size, _) as def -> uses_in_exp active; uses_in_exp wk; uses_in_exp addr; uses_in_exp data_size; Stack.push def stack' - | Read_mem (_, _, active, _, rk, addr, _) as def -> - uses_in_exp active; uses_in_exp rk; uses_in_exp addr; + | Read_mem r as def -> + uses_in_exp r.active; uses_in_exp r.kind; uses_in_exp r.addr; + Stack.push def stack' + | Barrier b as def -> + uses_in_exp b.active; uses_in_exp b.kind; Stack.push def stack' - | Barrier (_, _, active, bk) as def -> - uses_in_exp active; uses_in_exp bk; + | Cache_maintenance m as def -> + uses_in_exp m.active; uses_in_exp m.kind; uses_in_exp m.addr; + Stack.push def stack' + | Branch_announce c as def -> + uses_in_exp c.active; uses_in_exp c.addr; Stack.push def stack' | Excl_res (_, _, active) as def -> uses_in_exp active; @@ -1775,10 +1974,14 @@ module Make_optimizer(S : Sequence) = struct let constant_propagate = function | Declare_const _ as def -> S.add def seq + | Declare_fun _ as def -> + S.add def seq + | Preserve_const (var, typ, exp) -> + S.add (Preserve_const (var, typ, simp_smt_exp vars kinds exp)) seq | Define_const (var, typ, exp) -> let exp = simp_smt_exp vars kinds exp in begin match Hashtbl.find_opt uses var, simp_smt_exp vars kinds exp with - | _, (Bin _ | Bool_lit _) -> + | _, (Bitvec_lit _ | Bool_lit _) -> Hashtbl.add vars var exp | _, Var _ when !opt_propagate_vars -> Hashtbl.add vars var exp @@ -1791,20 +1994,30 @@ module Make_optimizer(S : Sequence) = struct S.add (Define_const (var, typ, exp)) seq | None, _ -> assert false end - | Write_mem (name, node, active, wk, addr, addr_ty, data, data_ty) -> - S.add (Write_mem (name, node, simp_smt_exp vars kinds active, simp_smt_exp vars kinds wk, - simp_smt_exp vars kinds addr, addr_ty, simp_smt_exp vars kinds data, data_ty)) + | Write_mem w -> + S.add (Write_mem { w with active = simp_smt_exp vars kinds w.active; + kind = simp_smt_exp vars kinds w.kind; + addr = simp_smt_exp vars kinds w.addr; + data = simp_smt_exp vars kinds w.data }) seq | Write_mem_ea (name, node, active, wk, addr, addr_ty, data_size, data_size_ty) -> S.add (Write_mem_ea (name, node, simp_smt_exp vars kinds active, simp_smt_exp vars kinds wk, simp_smt_exp vars kinds addr, addr_ty, simp_smt_exp vars kinds data_size, data_size_ty)) seq - | Read_mem (name, node, active, typ, rk, addr, addr_typ) -> - S.add (Read_mem (name, node, simp_smt_exp vars kinds active, typ, simp_smt_exp vars kinds rk, - simp_smt_exp vars kinds addr, addr_typ)) + | Read_mem r -> + S.add (Read_mem { r with active = simp_smt_exp vars kinds r.active; + kind = simp_smt_exp vars kinds r.kind; + addr = simp_smt_exp vars kinds r.addr }) seq - | Barrier (name, node, active, bk) -> - S.add (Barrier (name, node, simp_smt_exp vars kinds active, simp_smt_exp vars kinds bk)) seq + | Barrier b -> + S.add (Barrier { b with active = simp_smt_exp vars kinds b.active; kind = simp_smt_exp vars kinds b.kind }) seq + | Cache_maintenance m -> + S.add (Cache_maintenance { m with active = simp_smt_exp vars kinds m.active; + kind = simp_smt_exp vars kinds m.kind; + addr = simp_smt_exp vars kinds m.addr }) + seq + | Branch_announce c -> + S.add (Branch_announce { c with active = simp_smt_exp vars kinds c.active; addr = simp_smt_exp vars kinds c.addr }) seq | Excl_res (name, node, active) -> S.add (Excl_res (name, node, simp_smt_exp vars kinds active)) seq | Assert exp -> @@ -1843,6 +2056,26 @@ let smt_header ctx cdefs = register if it is. We also do a similar thing for *r = x *) let expand_reg_deref env register_map = function + | I_aux (I_funcall (CL_addr (CL_id (id, ctyp)), false, function_id, args), (_, l)) -> + begin match ctyp with + | CT_ref reg_ctyp -> + begin match CTMap.find_opt reg_ctyp register_map with + | Some regs -> + let end_label = label "end_reg_write_" in + let try_reg r = + let next_label = label "next_reg_write_" in + [ijump l (V_call (Neq, [V_lit (VL_ref (string_of_id r), reg_ctyp); V_id (id, ctyp)])) next_label; + ifuncall (CL_id (name r, reg_ctyp)) function_id args; + igoto end_label; + ilabel next_label] + in + iblock (List.concat (List.map try_reg regs) @ [ilabel end_label]) + | None -> + raise (Reporting.err_general l ("Could not find any registers with type " ^ string_of_ctyp reg_ctyp)) + end + | _ -> + raise (Reporting.err_general l "Register reference assignment must take a register reference as an argument") + end | I_aux (I_funcall (clexp, false, function_id, [reg_ref]), (_, l)) as instr -> let open Type_check in begin match (if Env.is_extern (fst function_id) env "smt" then Some (Env.get_extern (fst function_id) env "smt") else None) with @@ -1855,7 +2088,7 @@ let expand_reg_deref env register_map = function let end_label = label "end_reg_deref_" in let try_reg r = let next_label = label "next_reg_deref_" in - [ijump (V_call (Neq, [V_ref (name r, reg_ctyp); reg_ref])) next_label; + [ijump l (V_call (Neq, [V_lit (VL_ref (string_of_id r), reg_ctyp); reg_ref])) next_label; icopy l clexp (V_id (name r, reg_ctyp)); igoto end_label; ilabel next_label] @@ -1877,7 +2110,7 @@ let expand_reg_deref env register_map = function let end_label = label "end_reg_write_" in let try_reg r = let next_label = label "next_reg_write_" in - [ijump (V_call (Neq, [V_ref (name r, reg_ctyp); V_id (id, ctyp)])) next_label; + [ijump l (V_call (Neq, [V_lit (VL_ref (string_of_id r), reg_ctyp); V_id (id, ctyp)])) next_label; icopy l (CL_id (name r, reg_ctyp)) cval; igoto end_label; ilabel next_label] @@ -1927,7 +2160,7 @@ let smt_instr_list name ctx all_cdefs instrs = dump_graph name cfg; List.iter (fun n -> - begin match get_vertex cfg n with + match get_vertex cfg n with | None -> () | Some ((ssa_elems, cfnode), preds, succs) -> let muxers = @@ -1937,13 +2170,12 @@ let smt_instr_list name ctx all_cdefs instrs = let basic_block = smt_cfnode all_cdefs ctx ssa_elems cfnode in push_smt_defs stack muxers; push_smt_defs stack basic_block - end ) visit_order; - stack, cfg + stack, start, cfg let smt_cdef props lets name_file ctx all_cdefs = function - | CDEF_spec (function_id, arg_ctyps, ret_ctyp) when Bindings.mem function_id props -> + | CDEF_spec (function_id, _, arg_ctyps, ret_ctyp) when Bindings.mem function_id props -> begin match find_function [] function_id all_cdefs with | intervening_lets, Some (None, args, instrs) -> let prop_type, prop_args, pragma_l, vs = Bindings.find function_id props in @@ -1967,7 +2199,7 @@ let smt_cdef props lets name_file ctx all_cdefs = function |> remove_pointless_goto in - let stack, _ = smt_instr_list (string_of_id function_id) ctx all_cdefs instrs in + let stack, _, _ = smt_instr_list (string_of_id function_id) ctx all_cdefs instrs in let query = smt_query ctx pragma.query in push_smt_defs stack [Assert (Fn ("not", [query]))]; @@ -2038,25 +2270,20 @@ let rec build_register_map rmap = function | [] -> rmap let compile env ast = - let cdefs = - let open Jib_compile in - let ctx = - initial_ctx - ~convert_typ:ctyp_of_typ - ~optimize_anf:(fun ctx aexp -> fold_aexp (unroll_foreach ctx) (c_literals ctx aexp)) - env - in + let cdefs, jib_ctx = + let module Jibc = Jib_compile.Make(SMT_config) in + let ctx = Jib_compile.(initial_ctx (add_special_functions env)) in let t = Profile.start () in - let cdefs, ctx = compile_ast { ctx with specialize_calls = true; ignore_64 = true; struct_value = true; use_real = true } ast in + let cdefs, ctx = Jibc.compile_ast ctx ast in Profile.finish "Compiling to Jib IR" t; - cdefs + cdefs, ctx in let cdefs = Jib_optimize.unique_per_function_ids cdefs in let rmap = build_register_map CTMap.empty cdefs in - cdefs, { (initial_ctx ()) with tc_env = env; register_map = rmap; ast = ast } + cdefs, jib_ctx, { (initial_ctx ()) with tc_env = jib_ctx.tc_env; register_map = rmap; ast = ast } let serialize_smt_model file env ast = - let cdefs, ctx = compile env ast in + let cdefs, _, ctx = compile env ast in let out_chan = open_out file in Marshal.to_channel out_chan cdefs []; Marshal.to_channel out_chan (Type_check.Env.set_prover None ctx.tc_env) []; @@ -2073,7 +2300,7 @@ let deserialize_smt_model file = let generate_smt props name_file env ast = try - let cdefs, ctx = compile env ast in + let cdefs, _, ctx = compile env ast in smt_cdefs props [] name_file ctx cdefs cdefs with | Type_check.Type_error (_, l, err) -> diff --git a/src/jib/jib_smt.mli b/src/jib/jib_smt.mli index cdaf7e39..616877e4 100644 --- a/src/jib/jib_smt.mli +++ b/src/jib/jib_smt.mli @@ -73,44 +73,57 @@ val opt_default_lbits_index : int ref val opt_default_vector_index : int ref type ctx = { - (** Arbitrary-precision bitvectors are represented as a (BitVec lbits_index, BitVec (2 ^ lbits_index)) pair. *) lbits_index : int; - (** The size we use for integers where we don't know how large they are statically. *) + (** Arbitrary-precision bitvectors are represented as a (BitVec lbits_index, BitVec (2 ^ lbits_index)) pair. *) lint_size : int; + (** The size we use for integers where we don't know how large they are statically. *) + vector_index : int; (** A generic vector, vector('a) becomes Array (BitVec vector_index) 'a. We need to take care that vector_index is large enough for all generic vectors. *) - vector_index : int; - (** A map from each ctyp to a list of registers of that ctyp *) register_map : id list CTMap.t; - (** A set to keep track of all the tuple sizes we need to generate types for *) + (** A map from each ctyp to a list of registers of that ctyp *) tuple_sizes : IntSet.t ref; - (** tc_env is the global type-checking environment *) + (** A set to keep track of all the tuple sizes we need to generate types for *) tc_env : Type_check.Env.t; + (** tc_env is the global type-checking environment *) + pragma_l : Ast.l; (** A location, usually the $counterexample or $property we are generating the SMT for. Used for error messages. *) - pragma_l : Ast.l; - (** Used internally to keep track of function argument names *) arg_stack : (int * string) Stack.t; - (** The fully type-checked ast *) + (** Used internally to keep track of function argument names *) ast : Type_check.tannot defs; + (** The fully type-checked ast *) + shared : ctyp Bindings.t; + (** Shared variables. These variables do not get renamed by + Smtlib.suffix_variables_def, and their SSA number is + omitted. They should therefore only ever be read and never + written. Used by sail-axiomatic for symbolic values in the + initial litmus state. *) + preserved : IdSet.t; + (** icopy instructions to an id in preserved will generated a + define-const (by using Smtlib.Preserved_const) that will not be + simplified away or renamed. It will also not get a SSA + number. Such variables can therefore only ever be written to + once, and never read. They are used by sail-axiomatic to + extract information from the generated SMT. *) + events : smt_exp Stack.t EventMap.t ref; (** For every event type we have a stack of boolean SMT expressions for each occurance of that event. See src/property.ml for the event types *) - events : smt_exp Stack.t EventMap.t ref; + node : int; + pathcond : smt_exp Lazy.t; (** When generating SMT for an instruction pathcond will contain the global path conditional of the containing block/node in the control flow graph *) - node : int; - pathcond : smt_exp Lazy.t; + use_string : bool ref; + use_real : bool ref (** Set if we need to use strings or real numbers in the generated SMT, which then requires set-logic ALL or similar depending on the solver *) - use_string : bool ref; - use_real : bool ref } (** Compile an AST into Jib suitable for SMT generation, and initialise a context. *) -val compile : Type_check.Env.t -> Type_check.tannot defs -> cdef list * ctx +val compile : Type_check.Env.t -> Type_check.tannot defs -> cdef list * Jib_compile.ctx * ctx (* TODO: Currently we internally use mutable stacks and queues to avoid any issues with stack overflows caused by some non @@ -122,7 +135,7 @@ val smt_header : ctx -> cdef list -> smt_def list val smt_query : ctx -> Property.query -> smt_exp -val smt_instr_list : string -> ctx -> cdef list -> instr list -> smt_def Stack.t * (ssa_elem list * cf_node) Jib_ssa.array_graph +val smt_instr_list : string -> ctx -> cdef list -> instr list -> smt_def Stack.t * int * (ssa_elem list * cf_node) Jib_ssa.array_graph module type Sequence = sig type 'a t diff --git a/src/jib/jib_smt_fuzz.ml b/src/jib/jib_smt_fuzz.ml index 846d0178..58665bde 100644 --- a/src/jib/jib_smt_fuzz.ml +++ b/src/jib/jib_smt_fuzz.ml @@ -152,13 +152,13 @@ let rec run frame = exception Skip_iteration of string;; let fuzz_cdef ctx all_cdefs = function - | CDEF_spec (id, arg_ctyps, ret_ctyp) when not (string_of_id id = "and_bool" || string_of_id id = "or_bool") -> + | CDEF_spec (id, _, arg_ctyps, ret_ctyp) when not (string_of_id id = "and_bool" || string_of_id id = "or_bool") -> let open Type_check in let open Interpreter in if Env.is_extern id ctx.tc_env "smt" then ( let extern = Env.get_extern id ctx.tc_env "smt" in let typq, (Typ_aux (aux, _) as typ) = Env.get_val_spec id ctx.tc_env in - let istate = initial_state ctx.ast ctx.tc_env Value.primops in + let istate = initial_state ctx.ast ctx.tc_env !Value.primops in let header = smt_header ctx all_cdefs in prerr_endline (Util.("Fuzz: " |> cyan |> clear) ^ string_of_id id ^ " = \"" ^ extern ^ "\" : " ^ string_of_typ typ); @@ -192,7 +192,7 @@ let fuzz_cdef ctx all_cdefs = function @ [iend ()] in let smt_defs = - try fst (smt_instr_list extern ctx all_cdefs jib) with + try (fun (x, _, _) -> x) (smt_instr_list extern ctx all_cdefs jib) with | _ -> raise (Skip_iteration ("SMT error for: " ^ Util.string_of_list ", " string_of_exp (List.map fst values))) in @@ -253,6 +253,6 @@ let fuzz_cdef ctx all_cdefs = function let fuzz seed env ast = Random.init seed; - let cdefs, ctx = compile env ast in + let cdefs, _, ctx = compile env ast in List.iter (fuzz_cdef ctx cdefs) cdefs diff --git a/src/jib/jib_ssa.ml b/src/jib/jib_ssa.ml index 9c405a48..fe3238a4 100644 --- a/src/jib/jib_ssa.ml +++ b/src/jib/jib_ssa.ml @@ -504,6 +504,7 @@ let rename_variables graph root children = | Name (id, _) -> Name (id, i) | Have_exception _ -> Have_exception i | Current_exception _ -> Current_exception i + | Throw_location _ -> Throw_location i | Return _ -> Return i in @@ -524,9 +525,6 @@ let rename_variables graph root children = | V_id (id, ctyp) -> let i = top_stack id in V_id (ssa_name i id, ctyp) - | V_ref (id, ctyp) -> - let i = top_stack id in - V_ref (ssa_name i id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) | V_call (id, fs) -> V_call (id, List.map fold_cval fs) | V_field (f, field) -> V_field (fold_cval f, field) diff --git a/src/jib/jib_util.ml b/src/jib/jib_util.ml index 13438208..9b06c7be 100644 --- a/src/jib/jib_util.ml +++ b/src/jib/jib_util.ml @@ -83,7 +83,7 @@ let ireset ?loc:(l=Parse_ast.Unknown) ctyp id = let iinit ?loc:(l=Parse_ast.Unknown) ctyp id cval = I_aux (I_init (ctyp, id, cval), (instr_number (), l)) -let iif ?loc:(l=Parse_ast.Unknown) cval then_instrs else_instrs ctyp = +let iif l cval then_instrs else_instrs ctyp = I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (instr_number (), l)) let ifuncall ?loc:(l=Parse_ast.Unknown) clexp id cvals = @@ -113,7 +113,7 @@ let iblock ?loc:(l=Parse_ast.Unknown) instrs = let itry_block ?loc:(l=Parse_ast.Unknown) instrs = I_aux (I_try_block instrs, (instr_number (), l)) -let ithrow ?loc:(l=Parse_ast.Unknown) cval = +let ithrow l cval = I_aux (I_throw cval, (instr_number (), l)) let icomment ?loc:(l=Parse_ast.Unknown) str = @@ -134,7 +134,7 @@ let imatch_failure ?loc:(l=Parse_ast.Unknown) () = let iraw ?loc:(l=Parse_ast.Unknown) str = I_aux (I_raw str, (instr_number (), l)) -let ijump ?loc:(l=Parse_ast.Unknown) cval label = +let ijump l cval label = I_aux (I_jump (cval, label), (instr_number (), l)) module Name = struct @@ -153,6 +153,8 @@ module Name = struct | _, Have_exception _ -> -1 | Current_exception _, _ -> 1 | _, Current_exception _ -> -1 + | Throw_location _, _ -> 1 + | _, Throw_location _ -> -1 end module NameSet = Set.Make(Name) @@ -160,6 +162,7 @@ module NameMap = Map.Make(Name) let current_exception = Current_exception (-1) let have_exception = Have_exception (-1) +let throw_location = Throw_location (-1) let return = Return (-1) let name id = Name (id, -1) @@ -167,8 +170,6 @@ let name id = Name (id, -1) let rec cval_rename from_id to_id = function | V_id (id, ctyp) when Name.compare id from_id = 0 -> V_id (to_id, ctyp) | V_id (id, ctyp) -> V_id (id, ctyp) - | V_ref (id, ctyp) when Name.compare id from_id = 0 -> V_ref (to_id, ctyp) - | V_ref (id, ctyp) -> V_ref (id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) | V_call (call, cvals) -> V_call (call, List.map (cval_rename from_id to_id) cvals) | V_field (f, field) -> V_field (cval_rename from_id to_id f, field) @@ -257,8 +258,7 @@ let rec instr_rename from_id to_id (I_aux (instr, aux)) = (* 1. Instruction pretty printer *) (**************************************************************************) - -let string_of_name ?deref_current_exception:(dce=true) ?zencode:(zencode=true) = +let string_of_name ?deref_current_exception:(dce=false) ?zencode:(zencode=true) = let ssa_num n = if n = -1 then "" else ("/" ^ string_of_int n) in function | Name (id, n) -> @@ -271,6 +271,8 @@ let string_of_name ?deref_current_exception:(dce=true) ?zencode:(zencode=true) = "(*current_exception)" ^ ssa_num n | Current_exception n -> "current_exception" ^ ssa_num n + | Throw_location n -> + "throw_location" ^ ssa_num n let string_of_op = function | Bnot -> "@not" @@ -278,7 +280,6 @@ let string_of_op = function | Bor -> "@or" | List_hd -> "@hd" | List_tl -> "@tl" - | Bit_to_bool -> "@bit_to_bool" | Eq -> "@eq" | Neq -> "@neq" | Bvnot -> "@bvnot" @@ -309,9 +310,9 @@ let string_of_op = function let rec string_of_ctyp = function | CT_lint -> "%i" | CT_fint n -> "%i" ^ string_of_int n - | CT_lbits _ -> "%lb" - | CT_sbits (n, _) -> "%sb" ^ string_of_int n - | CT_fbits (n, _) -> "%fb" ^ string_of_int n + | CT_lbits _ -> "%bv" + | CT_sbits (n, _) -> "%sbv" ^ string_of_int n + | CT_fbits (n, _) -> "%bv" ^ string_of_int n | CT_constant n -> Big_int.to_string n | CT_bit -> "%bit" | CT_unit -> "%unit" @@ -323,6 +324,7 @@ let rec string_of_ctyp = function | CT_enum (id, _) -> "%enum " ^ Util.zencode_string (string_of_id id) | CT_variant (id, _) -> "%union " ^ Util.zencode_string (string_of_id id) | CT_vector (_, ctyp) -> "%vec(" ^ string_of_ctyp ctyp ^ ")" + | CT_fvector (n, _, ctyp) -> "%fvec(" ^ string_of_int n ^ ", " ^ string_of_ctyp ctyp ^ ")" | CT_list ctyp -> "%list(" ^ string_of_ctyp ctyp ^ ")" | CT_ref ctyp -> "&(" ^ string_of_ctyp ctyp ^ ")" | CT_poly -> "*" @@ -352,24 +354,27 @@ and full_string_of_ctyp = function | CT_ref ctyp -> "ref(" ^ full_string_of_ctyp ctyp ^ ")" | ctyp -> string_of_ctyp ctyp -let string_of_value = function - | VL_bits ([], _) -> "empty" +let rec string_of_value = function + | VL_bits ([], _) -> "UINT64_C(0)" | VL_bits (bs, true) -> Sail2_values.show_bitlist bs | VL_bits (bs, false) -> Sail2_values.show_bitlist (List.rev bs) | VL_int i -> Big_int.to_string i | VL_bool true -> "true" | VL_bool false -> "false" - | VL_null -> "NULL" | VL_unit -> "()" | VL_bit Sail2_values.B0 -> "bitzero" | VL_bit Sail2_values.B1 -> "bitone" - | VL_bit Sail2_values.BU -> "bitundef" + | VL_bit Sail2_values.BU -> failwith "Undefined bit found in value" | VL_real str -> str | VL_string str -> "\"" ^ str ^ "\"" + | VL_empty_list -> "NULL" + | VL_enum element -> Util.zencode_string element + | VL_ref r -> "&" ^ Util.zencode_string r + | VL_undefined -> "undefined" let rec string_of_cval = function | V_id (id, ctyp) -> string_of_name id - | V_ref (id, _) -> "&" ^ string_of_name id + | V_lit (VL_undefined, ctyp) -> string_of_value VL_undefined ^ " : " ^ string_of_ctyp ctyp | V_lit (vl, ctyp) -> string_of_value vl | V_call (op, cvals) -> Printf.sprintf "%s(%s)" (string_of_op op) (Util.string_of_list ", " string_of_cval cvals) @@ -377,16 +382,10 @@ let rec string_of_cval = function Printf.sprintf "%s.%s" (string_of_cval f) (string_of_uid field) | V_tuple_member (f, _, n) -> Printf.sprintf "%s.ztup%d" (string_of_cval f) n - | V_ctor_kind (f, ctor, [], _) -> - string_of_cval f ^ " is " ^ Util.zencode_string (string_of_id ctor) | V_ctor_kind (f, ctor, unifiers, _) -> - string_of_cval f ^ " is " ^ Util.zencode_string (string_of_id ctor ^ "_" ^ Util.string_of_list "_" string_of_ctyp unifiers) - | V_ctor_unwrap (ctor, f, [], _) -> - Printf.sprintf "%s as %s" (string_of_cval f) (string_of_id ctor) + string_of_cval f ^ " is " ^ string_of_uid (ctor, unifiers) | V_ctor_unwrap (ctor, f, unifiers, _) -> - Printf.sprintf "%s as %s" - (string_of_cval f) - (Util.zencode_string (string_of_id ctor ^ "_" ^ Util.string_of_list "_" string_of_ctyp unifiers)) + string_of_cval f ^ " as " ^ string_of_uid (ctor, unifiers) | V_struct (fields, _) -> Printf.sprintf "{%s}" (Util.string_of_list ", " (fun (field, cval) -> string_of_uid field ^ " = " ^ string_of_cval cval) fields) @@ -398,6 +397,7 @@ let rec map_ctyp f = function | CT_tup ctyps -> f (CT_tup (List.map (map_ctyp f) ctyps)) | CT_ref ctyp -> f (CT_ref (map_ctyp f ctyp)) | CT_vector (direction, ctyp) -> f (CT_vector (direction, map_ctyp f ctyp)) + | CT_fvector (n, direction, ctyp) -> f (CT_fvector (n, direction, map_ctyp f ctyp)) | CT_list ctyp -> f (CT_list (map_ctyp f ctyp)) | CT_struct (id, ctors) -> f (CT_struct (id, List.map (fun ((id, ctyps), ctyp) -> (id, List.map (map_ctyp f) ctyps), map_ctyp f ctyp) ctors)) @@ -423,6 +423,7 @@ let rec ctyp_equal ctyp1 ctyp2 = | CT_string, CT_string -> true | CT_real, CT_real -> true | CT_vector (d1, ctyp1), CT_vector (d2, ctyp2) -> d1 = d2 && ctyp_equal ctyp1 ctyp2 + | CT_fvector (n1, d1, ctyp1), CT_fvector (n2, d2, ctyp2) -> n1 = n2 && d1 = d2 && ctyp_equal ctyp1 ctyp2 | CT_list ctyp1, CT_list ctyp2 -> ctyp_equal ctyp1 ctyp2 | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_equal ctyp1 ctyp2 | CT_poly, CT_poly -> true @@ -492,6 +493,11 @@ let rec ctyp_compare ctyp1 ctyp2 = | CT_vector _, _ -> 1 | _, CT_vector _ -> -1 + | CT_fvector (n1, d1, ctyp1), CT_fvector (n2, d2, ctyp2) -> + lex_ord (compare n1 n2) (lex_ord (ctyp_compare ctyp1 ctyp2) (compare d1 d2)) + | CT_fvector _, _ -> 1 + | _, CT_fvector _ -> -1 + | ctyp1, ctyp2 -> String.compare (full_string_of_ctyp ctyp1) (full_string_of_ctyp ctyp2) module CT = struct @@ -564,6 +570,7 @@ let rec ctyp_suprema = function | CT_struct (id, ctors) -> CT_struct (id, ctors) | CT_variant (id, ctors) -> CT_variant (id, ctors) | CT_vector (d, ctyp) -> CT_vector (d, ctyp_suprema ctyp) + | CT_fvector (n, d, ctyp) -> CT_fvector (n, d, ctyp_suprema ctyp) | CT_list ctyp -> CT_list (ctyp_suprema ctyp) | CT_ref ctyp -> CT_ref (ctyp_suprema ctyp) | CT_poly -> CT_poly @@ -573,7 +580,7 @@ let rec ctyp_ids = function | CT_struct (id, ctors) | CT_variant (id, ctors) -> IdSet.add id (List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors) | CT_tup ctyps -> List.fold_left (fun ids ctyp -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctyps - | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> ctyp_ids ctyp + | CT_vector (_, ctyp) | CT_fvector (_, _, ctyp) | CT_list ctyp | CT_ref ctyp -> ctyp_ids ctyp | CT_lint | CT_fint _ | CT_constant _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_unit | CT_bool | CT_real | CT_bit | CT_string | CT_poly -> IdSet.empty @@ -588,11 +595,11 @@ let rec is_polymorphic = function | CT_tup ctyps -> List.exists is_polymorphic ctyps | CT_enum _ -> false | CT_struct (_, ctors) | CT_variant (_, ctors) -> List.exists (fun (_, ctyp) -> is_polymorphic ctyp) ctors - | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> is_polymorphic ctyp + | CT_fvector (_, _, ctyp) | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> is_polymorphic ctyp | CT_poly -> true let rec cval_deps = function - | V_id (id, _) | V_ref (id, _) -> NameSet.singleton id + | V_id (id, _) -> NameSet.singleton id | V_lit _ -> NameSet.empty | V_field (cval, _) | V_poly (cval, _) | V_tuple_member (cval, _, _) -> cval_deps cval | V_call (_, cvals) -> List.fold_left NameSet.union NameSet.empty (List.map cval_deps cvals) @@ -666,7 +673,6 @@ let rec map_clexp_ctyp f = function let rec map_cval_ctyp f = function | V_id (id, ctyp) -> V_id (id, f ctyp) - | V_ref (id, ctyp) -> V_ref (id, f ctyp) | V_lit (vl, ctyp) -> V_lit (vl, f ctyp) | V_ctor_kind (cval, id, unifiers, ctyp) -> V_ctor_kind (map_cval_ctyp f cval, id, List.map f unifiers, f ctyp) @@ -734,7 +740,7 @@ let rec concatmap_instr f (I_aux (instr, aux)) = I_try_block (List.concat (List.map (concatmap_instr f) instrs)) in f (I_aux (instr, aux)) - + (** Iterate over each instruction within an instruction, bottom-up *) let rec iter_instr f (I_aux (instr, aux)) = match instr with @@ -754,7 +760,7 @@ let cdef_map_instr f = function | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, List.map (map_instr f) instrs) | CDEF_startup (id, instrs) -> CDEF_startup (id, List.map (map_instr f) instrs) | CDEF_finish (id, instrs) -> CDEF_finish (id, List.map (map_instr f) instrs) - | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, ctyps, ctyp) + | CDEF_spec (id, extern, ctyps, ctyp) -> CDEF_spec (id, extern, ctyps, ctyp) | CDEF_type tdef -> CDEF_type tdef (** Map over each instruction in a cdef using concatmap_instr *) @@ -769,7 +775,7 @@ let cdef_concatmap_instr f = function CDEF_startup (id, List.concat (List.map (concatmap_instr f) instrs)) | CDEF_finish (id, instrs) -> CDEF_finish (id, List.concat (List.map (concatmap_instr f) instrs)) - | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, ctyps, ctyp) + | CDEF_spec (id, extern, ctyps, ctyp) -> CDEF_spec (id, extern, ctyps, ctyp) | CDEF_type tdef -> CDEF_type tdef let ctype_def_map_ctyp f = function @@ -784,7 +790,7 @@ let cdef_map_ctyp f = function | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, List.map (map_instr_ctyp f) instrs) | CDEF_startup (id, instrs) -> CDEF_startup (id, List.map (map_instr_ctyp f) instrs) | CDEF_finish (id, instrs) -> CDEF_finish (id, List.map (map_instr_ctyp f) instrs) - | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, List.map f ctyps, f ctyp) + | CDEF_spec (id, extern, ctyps, ctyp) -> CDEF_spec (id, extern, List.map f ctyps, f ctyp) | CDEF_type tdef -> CDEF_type (ctype_def_map_ctyp f tdef) (* Map over all sequences of instructions contained within an instruction *) @@ -838,7 +844,6 @@ let label str = let rec infer_call op vs = match op, vs with - | Bit_to_bool, _ -> CT_bool | Bnot, _ -> CT_bool | Band, _ -> CT_bool | Bor, _ -> CT_bool @@ -900,7 +905,6 @@ let rec infer_call op vs = and cval_ctyp = function | V_id (_, ctyp) -> ctyp - | V_ref (_, ctyp) -> CT_ref ctyp | V_lit (vl, ctyp) -> ctyp | V_ctor_kind _ -> CT_bool | V_ctor_unwrap (ctor, cval, unifiers, ctyp) -> ctyp @@ -984,7 +988,7 @@ let ctype_def_ctyps = function let cdef_ctyps = function | CDEF_reg_dec (_, ctyp, instrs) -> CTSet.add ctyp (instrs_ctyps instrs) - | CDEF_spec (_, ctyps, ctyp) -> + | CDEF_spec (_, _, ctyps, ctyp) -> CTSet.add ctyp (List.fold_left (fun m ctyp -> CTSet.add ctyp m) CTSet.empty ctyps) | CDEF_fundef (_, _, _, instrs) | CDEF_startup (_, instrs) | CDEF_finish (_, instrs) -> instrs_ctyps instrs diff --git a/src/libsail.mllib b/src/libsail.mllib index 2d1f568f..f05809bb 100644 --- a/src/libsail.mllib +++ b/src/libsail.mllib @@ -14,13 +14,14 @@ Graph Initial_check Interactive Interpreter -Isail Jib Jib_compile Jib_optimize Jib_ssa Jib_smt Jib_util +Jib_interactive +Jib_ir Latex Lexer Manifest @@ -32,11 +33,6 @@ Parse_ast Parser Parser_combinators Pattern_completeness -PPrint -PPrintCombinators -PPrintEngine -PPrintRenderer -PPrintOCaml Pretty_print Pretty_print_common Pretty_print_coq @@ -48,7 +44,6 @@ Property Reporting Rewriter Rewrites -Sail Sail2_values Sail_lib Scattered diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 5168d16a..e328cce1 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -219,7 +219,7 @@ let rec contains_exist (Typ_aux (ty,l)) = | Typ_var _ -> false | Typ_fn (t1,t2,_) -> List.exists contains_exist t1 || contains_exist t2 - | Typ_bidir (t1, t2) -> contains_exist t1 || contains_exist t2 + | Typ_bidir (t1, t2, _) -> contains_exist t1 || contains_exist t2 | Typ_tup ts -> List.exists contains_exist ts | Typ_app (_,args) -> List.exists contains_exist_arg args | Typ_exist _ -> true @@ -252,12 +252,11 @@ let rec size_nvars_nexp (Nexp_aux (ne,_)) = let split_src_type all_errors env id ty (TypQ_aux (q,ql)) = let cannot l msg default = let open Reporting in - let error = Err_general (l, msg) in match all_errors with - | None -> raise (Fatal_error error) + | None -> raise (err_general l msg) | Some flag -> begin flag := false; - print_error error; + print_err l "Error" msg; default end in @@ -659,14 +658,12 @@ let split_defs target all_errors splits env defs = let renew_id (Id_aux (id,l)) = Id_aux (id,new_l) in let cannot msg = let open Reporting in - let error = - Err_general (pat_l, - ("Cannot split type " ^ string_of_typ typ ^ " for variable " ^ v ^ ": " ^ msg)) - in if all_errors + let error_msg = "Cannot split type " ^ string_of_typ typ ^ " for variable " ^ v ^ ": " ^ msg in + if all_errors then (no_errors_happened := false; - print_error error; + print_err pat_l "" error_msg; [P_aux (P_id var,(pat_l,annot)),[],[],KBindings.empty]) - else raise (Fatal_error error) + else raise (err_general pat_l error_msg) in match ty with | Typ_id (Id_aux (Id "bool",_)) | Typ_app (Id_aux (Id "atom_bool", _), [_]) -> @@ -951,13 +948,11 @@ let split_defs target all_errors splits env defs = let size = List.length lst in if size > size_set_limit then let open Reporting in - let error = - Err_general (l, "Case split is too large (" ^ string_of_int size ^ - " > limit " ^ string_of_int size_set_limit ^ ")") - in if all_errors - then (no_errors_happened := false; - print_error error; false) - else raise (Fatal_error error) + let error_msg = "Case split is too large (" ^ string_of_int size ^ " > limit " ^ string_of_int size_set_limit ^ ")" in + if all_errors + then (no_errors_happened := false; + print_err l "" error_msg; false) + else raise (err_general l error_msg) else true in @@ -1927,9 +1922,7 @@ let refine_dependency env (E_aux (e,(l,annot)) as exp) pexps = with | Some pats -> if l = Parse_ast.Unknown then - (Reporting.print_error - (Reporting.Err_general - (l, "No location for pattern match: " ^ string_of_exp exp)); + (Reporting.print_err l "" ("No location for pattern match: " ^ string_of_exp exp); None) else Some (Have (ArgSplits.singleton (id,loc) (Partial (pats,l)), @@ -3270,15 +3263,15 @@ let ids_in_exp exp = lEXP_cast = (fun (_,id) -> IdSet.singleton id) } exp -let make_bitvector_env_casts env quant_kids (kid,i) exp = - let mk_cast var typ exp = (make_bitvector_cast_let "bitvector_cast_in" env env quant_kids typ (subst_kids_typ (KBindings.singleton kid (nconstant i)) typ)) var exp in +let make_bitvector_env_casts top_env env quant_kids insts exp = + let mk_cast var typ exp = (make_bitvector_cast_let "bitvector_cast_in" env top_env quant_kids typ (subst_kids_typ insts typ)) var exp in let mk_assign_in var typ = - make_bitvector_cast_assign "bitvector_cast_in" env env quant_kids typ - (subst_kids_typ (KBindings.singleton kid (nconstant i)) typ) var + make_bitvector_cast_assign "bitvector_cast_in" env top_env quant_kids typ + (subst_kids_typ insts typ) var in let mk_assign_out var typ = - make_bitvector_cast_assign "bitvector_cast_out" env env quant_kids - (subst_kids_typ (KBindings.singleton kid (nconstant i)) typ) typ var + make_bitvector_cast_assign "bitvector_cast_out" top_env env quant_kids + (subst_kids_typ insts typ) typ var in let locals = Env.get_locals env in let used_ids = ids_in_exp exp in @@ -3412,13 +3405,13 @@ let add_bitvector_casts (Defs defs) = (* We used to just substitute kid, but fill_in_type also catches other kids defined by it *) let src_typ = fill_in_type (Env.add_constraint (nc_eq (nvar kid) (nconstant i)) env) result_typ in make_bitvector_cast_exp "bitvector_cast_out" env quant_kids src_typ result_typ - (make_bitvector_env_casts env quant_kids (kid,i) body) + (make_bitvector_env_casts env (env_of body) quant_kids (KBindings.singleton kid (nconstant i)) body) | P_aux (P_id var,_), Some guard -> (match extract_value_from_guard var guard with | Some i -> let src_typ = fill_in_type (Env.add_constraint (nc_eq (nvar kid) (nconstant i)) env) result_typ in make_bitvector_cast_exp "bitvector_cast_out" env quant_kids src_typ result_typ - (make_bitvector_env_casts env quant_kids (kid,i) body) + (make_bitvector_env_casts env (env_of body) quant_kids (KBindings.singleton kid (nconstant i)) body) | None -> body) | _ -> body @@ -3432,10 +3425,9 @@ let add_bitvector_casts (Defs defs) = let env = env_of_annot ann in let result_typ = Env.base_typ_of env (typ_of_annot ann) in let insts = extract e1 in - let e2' = List.fold_left (fun body inst -> - make_bitvector_env_casts env quant_kids inst body) e2 insts in let insts = List.fold_left (fun insts (kid,i) -> KBindings.add kid (nconstant i) insts) KBindings.empty insts in + let e2' = make_bitvector_env_casts env (env_of e2) quant_kids insts e2 in let src_typ = subst_kids_typ insts result_typ in let e2' = make_bitvector_cast_exp "bitvector_cast_out" env quant_kids src_typ result_typ e2' in (* Ask the type checker if only one value remains for any of kids in @@ -3444,13 +3436,10 @@ let add_bitvector_casts (Defs defs) = let insts3 = KBindings.fold (fun kid _ i3 -> match Type_check.solve_unique env3 (nvar kid) with | None -> i3 - | Some c -> (kid, c)::i3) - insts [] + | Some c -> KBindings.add kid (nconstant c) i3) + insts KBindings.empty in - let e3' = List.fold_left (fun body inst -> - make_bitvector_env_casts env quant_kids inst body) e3 insts3 in - let insts3 = List.fold_left (fun insts (kid,i) -> - KBindings.add kid (nconstant i) insts) KBindings.empty insts3 in + let e3' = make_bitvector_env_casts env (env_of e3) quant_kids insts3 e3 in let src_typ3 = subst_kids_typ insts3 result_typ in let e3' = make_bitvector_cast_exp "bitvector_cast_out" env quant_kids src_typ3 result_typ e3' in E_aux (E_if (e1,e2',e3'), ann) @@ -3469,10 +3458,9 @@ let add_bitvector_casts (Defs defs) = let t' = aux t in let et = E_aux (E_block t',ann) in let env = env_of h in - let et = List.fold_left (fun body inst -> - make_bitvector_env_casts env quant_kids inst body) et insts in let insts = List.fold_left (fun insts (kid,i) -> KBindings.add kid (nconstant i) insts) KBindings.empty insts in + let et = make_bitvector_env_casts env (env_of et) quant_kids insts et in let src_typ = subst_kids_typ insts result_typ in let et = make_bitvector_cast_exp "bitvector_cast_out" env quant_kids src_typ result_typ et in @@ -3542,10 +3530,10 @@ let replace_nexp_in_typ env typ orig new_nexp = let f1 = List.exists fst arg' in let f2, res = aux res in f1 || f2, Typ_aux (Typ_fn (List.map snd arg', res, eff),l) - | Typ_bidir (t1, t2) -> + | Typ_bidir (t1, t2, eff) -> let f1, t1 = aux t1 in let f2, t2 = aux t2 in - f1 || f2, Typ_aux (Typ_bidir (t1, t2), l) + f1 || f2, Typ_aux (Typ_bidir (t1, t2, eff), l) | Typ_tup typs -> let fs, typs = List.split (List.map aux typs) in List.exists (fun x -> x) fs, Typ_aux (Typ_tup typs,l) diff --git a/src/myocamlbuild.ml b/src/myocamlbuild.ml index ae45857d..1949d66a 100644 --- a/src/myocamlbuild.ml +++ b/src/myocamlbuild.ml @@ -82,7 +82,6 @@ dispatch begin function (* Bisect_ppx_plugin.handle_coverage (); *) (* ocaml_lib "lem_interp/interp"; *) - ocaml_lib ~extern:false ~dir:"pprint/src" ~tag_name:"use_pprint" "pprint/src/PPrintLib"; rule "lem -> ml" ~prod: "%.ml" diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index 8899695f..98a43ebc 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -118,7 +118,7 @@ let rec ocaml_string_typ (Typ_aux (typ_aux, l)) arg = parens (separate space [string "fun"; parens (separate (comma ^^ space) args); string "->"; body]) ^^ space ^^ arg | Typ_fn (typ1, typ2, _) -> string "\"FN\"" - | Typ_bidir (t1, t2) -> string "\"BIDIR\"" + | Typ_bidir (t1, t2, _) -> string "\"BIDIR\"" | Typ_var kid -> string "\"VAR\"" | Typ_exist _ -> assert false | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") @@ -144,7 +144,7 @@ let rec ocaml_typ ctx (Typ_aux (typ_aux, l)) = | Typ_app (id, typs) -> parens (separate_map (string ", ") (ocaml_typ_arg ctx) typs) ^^ space ^^ ocaml_typ_id ctx id | Typ_tup typs -> parens (separate_map (string " * ") (ocaml_typ ctx) typs) | Typ_fn (typs, typ, _) -> separate space [ocaml_typ ctx (Typ_aux (Typ_tup typs, l)); string "->"; ocaml_typ ctx typ] - | Typ_bidir (t1, t2) -> raise (Reporting.err_general l "Ocaml doesn't support bidir types") + | Typ_bidir _ -> raise (Reporting.err_general l "Ocaml doesn't support bidir types") | Typ_var kid -> zencode_kid kid | Typ_exist _ -> assert false | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 3147b7f4..6cb3f84d 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -154,12 +154,12 @@ atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders | ATyp_minus of atyp * atyp (* subtraction *) | ATyp_exp of atyp (* exponential *) | ATyp_neg of atyp (* Internal (but not M as I want a datatype constructor) negative nexp *) - | ATyp_inc (* increasing (little-endian) *) - | ATyp_dec (* decreasing (big-endian) *) + | ATyp_inc (* increasing *) + | ATyp_dec (* decreasing *) | ATyp_default_ord (* default order for increasing or decreasing signficant bits *) | ATyp_set of (base_effect) list (* effect set *) - | ATyp_fn of atyp * atyp * atyp (* Function type (first-order only in user code), last atyp is an effect *) - | ATyp_bidir of atyp * atyp (* Function type (first-order only in user code), last atyp is an effect *) + | ATyp_fn of atyp * atyp * atyp (* Function type, last atyp is an effect *) + | ATyp_bidir of atyp * atyp * atyp (* Mapping type, last atyp is an effect *) | ATyp_wild | ATyp_tup of (atyp) list (* Tuple type *) | ATyp_app of id * (atyp) list (* type constructor application *) diff --git a/src/parser.mly b/src/parser.mly index 0b09468c..6a579b7a 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -657,9 +657,13 @@ typschm: | Forall typquant Dot typ MinusGt typ Effect effect_set { (fun s e -> mk_typschm $2 (mk_typ (ATyp_fn ($4, $6, $8)) s e) s e) $startpos $endpos } | typ Bidir typ - { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_bidir ($1, $3)) s e) s e) $startpos $endpos } + { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_bidir ($1, $3, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } | Forall typquant Dot typ Bidir typ - { (fun s e -> mk_typschm $2 (mk_typ (ATyp_bidir ($4, $6)) s e) s e) $startpos $endpos } + { (fun s e -> mk_typschm $2 (mk_typ (ATyp_bidir ($4, $6, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } + | typ Bidir typ Effect effect_set + { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_bidir ($1, $3, $5)) s e) s e) $startpos $endpos } + | Forall typquant Dot typ Bidir typ Effect effect_set + { (fun s e -> mk_typschm $2 (mk_typ (ATyp_bidir ($4, $6, $8)) s e) s e) $startpos $endpos } typschm_eof: | typschm Eof diff --git a/src/pprint/AUTHORS b/src/pprint/AUTHORS deleted file mode 100644 index 6060ac93..00000000 --- a/src/pprint/AUTHORS +++ /dev/null @@ -1,3 +0,0 @@ -PPrint was written by François Pottier and Nicolas Pouillard, with -contributions by Yann Régis-Gianas, Gabriel Scherer, and Jonathan -Protzenko. diff --git a/src/pprint/CHANGES b/src/pprint/CHANGES deleted file mode 100644 index 69747a41..00000000 --- a/src/pprint/CHANGES +++ /dev/null @@ -1,27 +0,0 @@ -2014/04/11 -Changed the behavior of [align], which was not consistent with its documentation. -[align] now sets the indentation level to the current column. In particular, this -means that [align (align d)] is equivalent to [align d], which was not the case -previously. Thanks to Dmitry Grebeniuk for reporting this issue. - -2014/04/03 -The library is now extensible (in principle). A [custom] document constructor -allows the user to define her own documents, as long as they fit the manner -in which the current rendering engine works. - -The [compact] rendering engine is now tail-recursive too. - -2014/03/21 -Minor optimisation in the smart constructor [group]. - -2014/03/13 -New (simpler) pretty-printing engine. The representation of documents in -memory is slightly larger; document construction is perhaps slightly slower, -while rendering is significantly faster. (Construction dominates rendering.) -The rendering speed is now guaranteed to be independent of the width -parameter. The price to pay for this simplification is that the primitive -document constructors [column] and [nesting] are no longer supported. The -API is otherwise unchanged. - -2013/01/31 -First official release of PPrint. diff --git a/src/pprint/LICENSE b/src/pprint/LICENSE deleted file mode 100644 index d6eb151e..00000000 --- a/src/pprint/LICENSE +++ /dev/null @@ -1,517 +0,0 @@ - -CeCILL-C FREE SOFTWARE LICENSE AGREEMENT - - - Notice - -This Agreement is a Free Software license agreement that is the result -of discussions between its authors in order to ensure compliance with -the two main principles guiding its drafting: - - * firstly, compliance with the principles governing the distribution - of Free Software: access to source code, broad rights granted to - users, - * secondly, the election of a governing law, French law, with which - it is conformant, both as regards the law of torts and - intellectual property law, and the protection that it offers to - both authors and holders of the economic rights over software. - -The authors of the CeCILL-C (for Ce[a] C[nrs] I[nria] L[ogiciel] L[ibre]) -license are: - -Commissariat à l'Energie Atomique - CEA, a public scientific, technical -and industrial research establishment, having its principal place of -business at 25 rue Leblanc, immeuble Le Ponant D, 75015 Paris, France. - -Centre National de la Recherche Scientifique - CNRS, a public scientific -and technological establishment, having its principal place of business -at 3 rue Michel-Ange, 75794 Paris cedex 16, France. - -Institut National de Recherche en Informatique et en Automatique - -INRIA, a public scientific and technological establishment, having its -principal place of business at Domaine de Voluceau, Rocquencourt, BP -105, 78153 Le Chesnay cedex, France. - - - Preamble - -The purpose of this Free Software license agreement is to grant users -the right to modify and re-use the software governed by this license. - -The exercising of this right is conditional upon the obligation to make -available to the community the modifications made to the source code of -the software so as to contribute to its evolution. - -In consideration of access to the source code and the rights to copy, -modify and redistribute granted by the license, users are provided only -with a limited warranty and the software's author, the holder of the -economic rights, and the successive licensors only have limited liability. - -In this respect, the risks associated with loading, using, modifying -and/or developing or reproducing the software by the user are brought to -the user's attention, given its Free Software status, which may make it -complicated to use, with the result that its use is reserved for -developers and experienced professionals having in-depth computer -knowledge. Users are therefore encouraged to load and test the -suitability of the software as regards their requirements in conditions -enabling the security of their systems and/or data to be ensured and, -more generally, to use and operate it in the same conditions of -security. This Agreement may be freely reproduced and published, -provided it is not altered, and that no provisions are either added or -removed herefrom. - -This Agreement may apply to any or all software for which the holder of -the economic rights decides to submit the use thereof to its provisions. - - - Article 1 - DEFINITIONS - -For the purpose of this Agreement, when the following expressions -commence with a capital letter, they shall have the following meaning: - -Agreement: means this license agreement, and its possible subsequent -versions and annexes. - -Software: means the software in its Object Code and/or Source Code form -and, where applicable, its documentation, "as is" when the Licensee -accepts the Agreement. - -Initial Software: means the Software in its Source Code and possibly its -Object Code form and, where applicable, its documentation, "as is" when -it is first distributed under the terms and conditions of the Agreement. - -Modified Software: means the Software modified by at least one -Integrated Contribution. - -Source Code: means all the Software's instructions and program lines to -which access is required so as to modify the Software. - -Object Code: means the binary files originating from the compilation of -the Source Code. - -Holder: means the holder(s) of the economic rights over the Initial -Software. - -Licensee: means the Software user(s) having accepted the Agreement. - -Contributor: means a Licensee having made at least one Integrated -Contribution. - -Licensor: means the Holder, or any other individual or legal entity, who -distributes the Software under the Agreement. - -Integrated Contribution: means any or all modifications, corrections, -translations, adaptations and/or new functions integrated into the -Source Code by any or all Contributors. - -Related Module: means a set of sources files including their -documentation that, without modification to the Source Code, enables -supplementary functions or services in addition to those offered by the -Software. - -Derivative Software: means any combination of the Software, modified or -not, and of a Related Module. - -Parties: mean both the Licensee and the Licensor. - -These expressions may be used both in singular and plural form. - - - Article 2 - PURPOSE - -The purpose of the Agreement is the grant by the Licensor to the -Licensee of a non-exclusive, transferable and worldwide license for the -Software as set forth in Article 5 hereinafter for the whole term of the -protection granted by the rights over said Software. - - - Article 3 - ACCEPTANCE - -3.1 The Licensee shall be deemed as having accepted the terms and -conditions of this Agreement upon the occurrence of the first of the -following events: - - * (i) loading the Software by any or all means, notably, by - downloading from a remote server, or by loading from a physical - medium; - * (ii) the first time the Licensee exercises any of the rights - granted hereunder. - -3.2 One copy of the Agreement, containing a notice relating to the -characteristics of the Software, to the limited warranty, and to the -fact that its use is restricted to experienced users has been provided -to the Licensee prior to its acceptance as set forth in Article 3.1 -hereinabove, and the Licensee hereby acknowledges that it has read and -understood it. - - - Article 4 - EFFECTIVE DATE AND TERM - - - 4.1 EFFECTIVE DATE - -The Agreement shall become effective on the date when it is accepted by -the Licensee as set forth in Article 3.1. - - - 4.2 TERM - -The Agreement shall remain in force for the entire legal term of -protection of the economic rights over the Software. - - - Article 5 - SCOPE OF RIGHTS GRANTED - -The Licensor hereby grants to the Licensee, who accepts, the following -rights over the Software for any or all use, and for the term of the -Agreement, on the basis of the terms and conditions set forth hereinafter. - -Besides, if the Licensor owns or comes to own one or more patents -protecting all or part of the functions of the Software or of its -components, the Licensor undertakes not to enforce the rights granted by -these patents against successive Licensees using, exploiting or -modifying the Software. If these patents are transferred, the Licensor -undertakes to have the transferees subscribe to the obligations set -forth in this paragraph. - - - 5.1 RIGHT OF USE - -The Licensee is authorized to use the Software, without any limitation -as to its fields of application, with it being hereinafter specified -that this comprises: - - 1. permanent or temporary reproduction of all or part of the Software - by any or all means and in any or all form. - - 2. loading, displaying, running, or storing the Software on any or - all medium. - - 3. entitlement to observe, study or test its operation so as to - determine the ideas and principles behind any or all constituent - elements of said Software. This shall apply when the Licensee - carries out any or all loading, displaying, running, transmission - or storage operation as regards the Software, that it is entitled - to carry out hereunder. - - - 5.2 RIGHT OF MODIFICATION - -The right of modification includes the right to translate, adapt, -arrange, or make any or all modifications to the Software, and the right -to reproduce the resulting software. It includes, in particular, the -right to create a Derivative Software. - -The Licensee is authorized to make any or all modification to the -Software provided that it includes an explicit notice that it is the -author of said modification and indicates the date of the creation thereof. - - - 5.3 RIGHT OF DISTRIBUTION - -In particular, the right of distribution includes the right to publish, -transmit and communicate the Software to the general public on any or -all medium, and by any or all means, and the right to market, either in -consideration of a fee, or free of charge, one or more copies of the -Software by any means. - -The Licensee is further authorized to distribute copies of the modified -or unmodified Software to third parties according to the terms and -conditions set forth hereinafter. - - - 5.3.1 DISTRIBUTION OF SOFTWARE WITHOUT MODIFICATION - -The Licensee is authorized to distribute true copies of the Software in -Source Code or Object Code form, provided that said distribution -complies with all the provisions of the Agreement and is accompanied by: - - 1. a copy of the Agreement, - - 2. a notice relating to the limitation of both the Licensor's - warranty and liability as set forth in Articles 8 and 9, - -and that, in the event that only the Object Code of the Software is -redistributed, the Licensee allows effective access to the full Source -Code of the Software at a minimum during the entire period of its -distribution of the Software, it being understood that the additional -cost of acquiring the Source Code shall not exceed the cost of -transferring the data. - - - 5.3.2 DISTRIBUTION OF MODIFIED SOFTWARE - -When the Licensee makes an Integrated Contribution to the Software, the -terms and conditions for the distribution of the resulting Modified -Software become subject to all the provisions of this Agreement. - -The Licensee is authorized to distribute the Modified Software, in -source code or object code form, provided that said distribution -complies with all the provisions of the Agreement and is accompanied by: - - 1. a copy of the Agreement, - - 2. a notice relating to the limitation of both the Licensor's - warranty and liability as set forth in Articles 8 and 9, - -and that, in the event that only the object code of the Modified -Software is redistributed, the Licensee allows effective access to the -full source code of the Modified Software at a minimum during the entire -period of its distribution of the Modified Software, it being understood -that the additional cost of acquiring the source code shall not exceed -the cost of transferring the data. - - - 5.3.3 DISTRIBUTION OF DERIVATIVE SOFTWARE - -When the Licensee creates Derivative Software, this Derivative Software -may be distributed under a license agreement other than this Agreement, -subject to compliance with the requirement to include a notice -concerning the rights over the Software as defined in Article 6.4. -In the event the creation of the Derivative Software required modification -of the Source Code, the Licensee undertakes that: - - 1. the resulting Modified Software will be governed by this Agreement, - 2. the Integrated Contributions in the resulting Modified Software - will be clearly identified and documented, - 3. the Licensee will allow effective access to the source code of the - Modified Software, at a minimum during the entire period of - distribution of the Derivative Software, such that such - modifications may be carried over in a subsequent version of the - Software; it being understood that the additional cost of - purchasing the source code of the Modified Software shall not - exceed the cost of transferring the data. - - - 5.3.4 COMPATIBILITY WITH THE CeCILL LICENSE - -When a Modified Software contains an Integrated Contribution subject to -the CeCILL license agreement, or when a Derivative Software contains a -Related Module subject to the CeCILL license agreement, the provisions -set forth in the third item of Article 6.4 are optional. - - - Article 6 - INTELLECTUAL PROPERTY - - - 6.1 OVER THE INITIAL SOFTWARE - -The Holder owns the economic rights over the Initial Software. Any or -all use of the Initial Software is subject to compliance with the terms -and conditions under which the Holder has elected to distribute its work -and no one shall be entitled to modify the terms and conditions for the -distribution of said Initial Software. - -The Holder undertakes that the Initial Software will remain ruled at -least by this Agreement, for the duration set forth in Article 4.2. - - - 6.2 OVER THE INTEGRATED CONTRIBUTIONS - -The Licensee who develops an Integrated Contribution is the owner of the -intellectual property rights over this Contribution as defined by -applicable law. - - - 6.3 OVER THE RELATED MODULES - -The Licensee who develops a Related Module is the owner of the -intellectual property rights over this Related Module as defined by -applicable law and is free to choose the type of agreement that shall -govern its distribution under the conditions defined in Article 5.3.3. - - - 6.4 NOTICE OF RIGHTS - -The Licensee expressly undertakes: - - 1. not to remove, or modify, in any manner, the intellectual property - notices attached to the Software; - - 2. to reproduce said notices, in an identical manner, in the copies - of the Software modified or not; - - 3. to ensure that use of the Software, its intellectual property - notices and the fact that it is governed by the Agreement is - indicated in a text that is easily accessible, specifically from - the interface of any Derivative Software. - -The Licensee undertakes not to directly or indirectly infringe the -intellectual property rights of the Holder and/or Contributors on the -Software and to take, where applicable, vis-à -vis its staff, any and all -measures required to ensure respect of said intellectual property rights -of the Holder and/or Contributors. - - - Article 7 - RELATED SERVICES - -7.1 Under no circumstances shall the Agreement oblige the Licensor to -provide technical assistance or maintenance services for the Software. - -However, the Licensor is entitled to offer this type of services. The -terms and conditions of such technical assistance, and/or such -maintenance, shall be set forth in a separate instrument. Only the -Licensor offering said maintenance and/or technical assistance services -shall incur liability therefor. - -7.2 Similarly, any Licensor is entitled to offer to its licensees, under -its sole responsibility, a warranty, that shall only be binding upon -itself, for the redistribution of the Software and/or the Modified -Software, under terms and conditions that it is free to decide. Said -warranty, and the financial terms and conditions of its application, -shall be subject of a separate instrument executed between the Licensor -and the Licensee. - - - Article 8 - LIABILITY - -8.1 Subject to the provisions of Article 8.2, the Licensee shall be -entitled to claim compensation for any direct loss it may have suffered -from the Software as a result of a fault on the part of the relevant -Licensor, subject to providing evidence thereof. - -8.2 The Licensor's liability is limited to the commitments made under -this Agreement and shall not be incurred as a result of in particular: -(i) loss due the Licensee's total or partial failure to fulfill its -obligations, (ii) direct or consequential loss that is suffered by the -Licensee due to the use or performance of the Software, and (iii) more -generally, any consequential loss. In particular the Parties expressly -agree that any or all pecuniary or business loss (i.e. loss of data, -loss of profits, operating loss, loss of customers or orders, -opportunity cost, any disturbance to business activities) or any or all -legal proceedings instituted against the Licensee by a third party, -shall constitute consequential loss and shall not provide entitlement to -any or all compensation from the Licensor. - - - Article 9 - WARRANTY - -9.1 The Licensee acknowledges that the scientific and technical -state-of-the-art when the Software was distributed did not enable all -possible uses to be tested and verified, nor for the presence of -possible defects to be detected. In this respect, the Licensee's -attention has been drawn to the risks associated with loading, using, -modifying and/or developing and reproducing the Software which are -reserved for experienced users. - -The Licensee shall be responsible for verifying, by any or all means, -the suitability of the product for its requirements, its good working -order, and for ensuring that it shall not cause damage to either persons -or properties. - -9.2 The Licensor hereby represents, in good faith, that it is entitled -to grant all the rights over the Software (including in particular the -rights set forth in Article 5). - -9.3 The Licensee acknowledges that the Software is supplied "as is" by -the Licensor without any other express or tacit warranty, other than -that provided for in Article 9.2 and, in particular, without any warranty -as to its commercial value, its secured, safe, innovative or relevant -nature. - -Specifically, the Licensor does not warrant that the Software is free -from any error, that it will operate without interruption, that it will -be compatible with the Licensee's own equipment and software -configuration, nor that it will meet the Licensee's requirements. - -9.4 The Licensor does not either expressly or tacitly warrant that the -Software does not infringe any third party intellectual property right -relating to a patent, software or any other property right. Therefore, -the Licensor disclaims any and all liability towards the Licensee -arising out of any or all proceedings for infringement that may be -instituted in respect of the use, modification and redistribution of the -Software. Nevertheless, should such proceedings be instituted against -the Licensee, the Licensor shall provide it with technical and legal -assistance for its defense. Such technical and legal assistance shall be -decided on a case-by-case basis between the relevant Licensor and the -Licensee pursuant to a memorandum of understanding. The Licensor -disclaims any and all liability as regards the Licensee's use of the -name of the Software. No warranty is given as regards the existence of -prior rights over the name of the Software or as regards the existence -of a trademark. - - - Article 10 - TERMINATION - -10.1 In the event of a breach by the Licensee of its obligations -hereunder, the Licensor may automatically terminate this Agreement -thirty (30) days after notice has been sent to the Licensee and has -remained ineffective. - -10.2 A Licensee whose Agreement is terminated shall no longer be -authorized to use, modify or distribute the Software. However, any -licenses that it may have granted prior to termination of the Agreement -shall remain valid subject to their having been granted in compliance -with the terms and conditions hereof. - - - Article 11 - MISCELLANEOUS - - - 11.1 EXCUSABLE EVENTS - -Neither Party shall be liable for any or all delay, or failure to -perform the Agreement, that may be attributable to an event of force -majeure, an act of God or an outside cause, such as defective -functioning or interruptions of the electricity or telecommunications -networks, network paralysis following a virus attack, intervention by -government authorities, natural disasters, water damage, earthquakes, -fire, explosions, strikes and labor unrest, war, etc. - -11.2 Any failure by either Party, on one or more occasions, to invoke -one or more of the provisions hereof, shall under no circumstances be -interpreted as being a waiver by the interested Party of its right to -invoke said provision(s) subsequently. - -11.3 The Agreement cancels and replaces any or all previous agreements, -whether written or oral, between the Parties and having the same -purpose, and constitutes the entirety of the agreement between said -Parties concerning said purpose. No supplement or modification to the -terms and conditions hereof shall be effective as between the Parties -unless it is made in writing and signed by their duly authorized -representatives. - -11.4 In the event that one or more of the provisions hereof were to -conflict with a current or future applicable act or legislative text, -said act or legislative text shall prevail, and the Parties shall make -the necessary amendments so as to comply with said act or legislative -text. All other provisions shall remain effective. Similarly, invalidity -of a provision of the Agreement, for any reason whatsoever, shall not -cause the Agreement as a whole to be invalid. - - - 11.5 LANGUAGE - -The Agreement is drafted in both French and English and both versions -are deemed authentic. - - - Article 12 - NEW VERSIONS OF THE AGREEMENT - -12.1 Any person is authorized to duplicate and distribute copies of this -Agreement. - -12.2 So as to ensure coherence, the wording of this Agreement is -protected and may only be modified by the authors of the License, who -reserve the right to periodically publish updates or new versions of the -Agreement, each with a separate number. These subsequent versions may -address new issues encountered by Free Software. - -12.3 Any Software distributed under a given version of the Agreement may -only be subsequently distributed under the same version of the Agreement -or a subsequent version. - - - Article 13 - GOVERNING LAW AND JURISDICTION - -13.1 The Agreement is governed by French law. The Parties agree to -endeavor to seek an amicable solution to any disagreements or disputes -that may arise during the performance of the Agreement. - -13.2 Failing an amicable solution within two (2) months as from their -occurrence, and unless emergency proceedings are necessary, the -disagreements or disputes shall be referred to the Paris Courts having -jurisdiction, by the more diligent Party. - - -Version 1.0 dated 2006-09-05. diff --git a/src/pprint/README b/src/pprint/README deleted file mode 100644 index 7146250a..00000000 --- a/src/pprint/README +++ /dev/null @@ -1,13 +0,0 @@ -This is an adaptation of Daan Leijen's "PPrint" library, which itself is based -on the ideas developed by Philip Wadler in "A Prettier Printer". For more -information about Wadler's and Leijen's work, please consult the following -references: - - http://www.cs.uu.nl/~daan/pprint.html - http://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf - -To install PPrint, type "make -C src install". ocamlfind is required. - -The documentation for PPrint is built by "make doc" and is found in the -file doc/index.html. - diff --git a/src/pprint/src/META b/src/pprint/src/META deleted file mode 100755 index 4a966166..00000000 --- a/src/pprint/src/META +++ /dev/null @@ -1,5 +0,0 @@ -requires = "" -description = "The PPrint pretty-printing library" -archive(byte) = "PPrintLib.cma" -archive(native) = "PPrintLib.cmxa" -version = "20171003" diff --git a/src/pprint/src/Makefile b/src/pprint/src/Makefile deleted file mode 100644 index 3bfa12df..00000000 --- a/src/pprint/src/Makefile +++ /dev/null @@ -1,46 +0,0 @@ -.PHONY: all install uninstall reinstall clean doc test bench - -OCAMLBUILD := ocamlbuild -use-ocamlfind -classic-display -OCAMLFIND := ocamlfind -DOCDIR := doc -MAIN := PPrintTest -TO_BUILD := PPrintLib.cma PPrintLib.cmxa - -all: - $(OCAMLBUILD) $(TO_BUILD) - -install: all - $(OCAMLFIND) install pprint META \ - $(patsubst %,_build/%,$(TO_BUILD)) \ - _build/PPrintLib.a _build/*.cmx _build/*.cmi - -# [make uninstall] attempts to uninstall, but succeeds even if uninstallation -# fails (probably because the package was not installed in the first place). -uninstall: - ocamlfind remove pprint || true - -reinstall: uninstall - @ $(MAKE) install - -clean: - rm -f *~ - rm -rf doc - $(OCAMLBUILD) -clean - -doc: all - @rm -rf $(DOCDIR) - @mkdir $(DOCDIR) - ocamlfind ocamldoc \ - -html \ - -I _build \ - -d $(DOCDIR) \ - -charset utf8 \ - PPrintRenderer.ml PPrintEngine.mli PPrintCombinators.mli PPrintOCaml.mli PPrint.ml - -test: all - $(OCAMLBUILD) $(MAIN).native - ./$(MAIN).native - -bench: all - $(OCAMLBUILD) -tag use_unix PPrintBench.native - time ./PPrintBench.native diff --git a/src/pprint/src/PPrint.ml b/src/pprint/src/PPrint.ml deleted file mode 100644 index 46d732b1..00000000 --- a/src/pprint/src/PPrint.ml +++ /dev/null @@ -1,18 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** A package of all of the above. *) - -include PPrintEngine -include PPrintCombinators -module OCaml = PPrintOCaml diff --git a/src/pprint/src/PPrintCombinators.ml b/src/pprint/src/PPrintCombinators.ml deleted file mode 100644 index 70499878..00000000 --- a/src/pprint/src/PPrintCombinators.ml +++ /dev/null @@ -1,311 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open PPrintEngine - -(* ------------------------------------------------------------------------- *) - -(* Predefined single-character documents. *) - -let lparen = char '(' -let rparen = char ')' -let langle = char '<' -let rangle = char '>' -let lbrace = char '{' -let rbrace = char '}' -let lbracket = char '[' -let rbracket = char ']' -let squote = char '\'' -let dquote = char '"' -let bquote = char '`' -let semi = char ';' -let colon = char ':' -let comma = char ',' -let space = char ' ' -let dot = char '.' -let sharp = char '#' -let slash = char '/' -let backslash = char '\\' -let equals = char '=' -let qmark = char '?' -let tilde = char '~' -let at = char '@' -let percent = char '%' -let dollar = char '$' -let caret = char '^' -let ampersand = char '&' -let star = char '*' -let plus = char '+' -let minus = char '-' -let underscore = char '_' -let bang = char '!' -let bar = char '|' - -(* ------------------------------------------------------------------------- *) - -(* Repetition. *) - -let twice doc = - doc ^^ doc - -let repeat n doc = - let rec loop n doc accu = - if n = 0 then - accu - else - loop (n - 1) doc (doc ^^ accu) - in - loop n doc empty - -(* ------------------------------------------------------------------------- *) - -(* Delimiters. *) - -let precede l x = l ^^ x -let terminate r x = x ^^ r -let enclose l r x = l ^^ x ^^ r - -let squotes = enclose squote squote -let dquotes = enclose dquote dquote -let bquotes = enclose bquote bquote -let braces = enclose lbrace rbrace -let parens = enclose lparen rparen -let angles = enclose langle rangle -let brackets = enclose lbracket rbracket - -(* ------------------------------------------------------------------------- *) - -(* Some functions on lists. *) - -(* A variant of [fold_left] that keeps track of the element index. *) - -let foldli (f : int -> 'b -> 'a -> 'b) (accu : 'b) (xs : 'a list) : 'b = - let r = ref 0 in - List.fold_left (fun accu x -> - let i = !r in - r := i + 1; - f i accu x - ) accu xs - -(* ------------------------------------------------------------------------- *) - -(* Working with lists of documents. *) - -let concat docs = - (* We take advantage of the fact that [^^] operates in constant - time, regardless of the size of its arguments. The document - that is constructed is essentially a reversed list (i.e., a - tree that is biased towards the left). This is not a problem; - when pretty-printing this document, the engine will descend - along the left branch, pushing the nodes onto its stack as - it goes down, effectively reversing the list again. *) - List.fold_left (^^) empty docs - -let separate sep docs = - foldli (fun i accu doc -> - if i = 0 then - doc - else - accu ^^ sep ^^ doc - ) empty docs - -let concat_map f xs = - List.fold_left (fun accu x -> - accu ^^ f x - ) empty xs - -let separate_map sep f xs = - foldli (fun i accu x -> - if i = 0 then - f x - else - accu ^^ sep ^^ f x - ) empty xs - -let separate2 sep last_sep docs = - let n = List.length docs in - foldli (fun i accu doc -> - if i = 0 then - doc - else - accu ^^ (if i < n - 1 then sep else last_sep) ^^ doc - ) empty docs - -let optional f = function - | None -> - empty - | Some x -> - f x - -(* ------------------------------------------------------------------------- *) - -(* Text. *) - -(* This variant of [String.index_from] returns an option. *) - -let index_from s i c = - try - Some (String.index_from s i c) - with Not_found -> - None - -(* [lines s] chops the string [s] into a list of lines, which are turned - into documents. *) - -let lines s = - let rec chop accu i = - match index_from s i '\n' with - | Some j -> - let accu = substring s i (j - i) :: accu in - chop accu (j + 1) - | None -> - substring s i (String.length s - i) :: accu - in - List.rev (chop [] 0) - -let arbitrary_string s = - separate (break 1) (lines s) - -(* [split ok s] splits the string [s] at every occurrence of a character - that satisfies the predicate [ok]. The substrings thus obtained are - turned into documents, and a list of documents is returned. No information - is lost: the concatenation of the documents yields the original string. - This code is not UTF-8 aware. *) - -let split ok s = - let n = String.length s in - let rec index_from i = - if i = n then - None - else if ok s.[i] then - Some i - else - index_from (i + 1) - in - let rec chop accu i = - match index_from i with - | Some j -> - let accu = substring s i (j - i) :: accu in - let accu = char s.[j] :: accu in - chop accu (j + 1) - | None -> - substring s i (String.length s - i) :: accu - in - List.rev (chop [] 0) - -(* [words s] chops the string [s] into a list of words, which are turned - into documents. *) - -let words s = - let n = String.length s in - (* A two-state finite automaton. *) - (* In this state, we have skipped at least one blank character. *) - let rec skipping accu i = - if i = n then - (* There was whitespace at the end. Drop it. *) - accu - else match s.[i] with - | ' ' - | '\t' - | '\n' - | '\r' -> - (* Skip more whitespace. *) - skipping accu (i + 1) - | _ -> - (* Begin a new word. *) - word accu i (i + 1) - (* In this state, we have skipped at least one non-blank character. *) - and word accu i j = - if j = n then - (* Final word. *) - substring s i (j - i) :: accu - else match s.[j] with - | ' ' - | '\t' - | '\n' - | '\r' -> - (* A new word has been identified. *) - let accu = substring s i (j - i) :: accu in - skipping accu (j + 1) - | _ -> - (* Continue inside the current word. *) - word accu i (j + 1) - in - List.rev (skipping [] 0) - -let flow_map sep f docs = - foldli (fun i accu doc -> - if i = 0 then - f doc - else - accu ^^ - (* This idiom allows beginning a new line if [doc] does not - fit on the current line. *) - group (sep ^^ f doc) - ) empty docs - -let flow sep docs = - flow_map sep (fun x -> x) docs - -let url s = - flow (break 0) (split (function '/' | '.' -> true | _ -> false) s) - -(* ------------------------------------------------------------------------- *) - -(* Alignment and indentation. *) - -let hang i d = - align (nest i d) - -let ( !^ ) = string - -let ( ^/^ ) x y = - x ^^ break 1 ^^ y - -let prefix n b x y = - group (x ^^ nest n (break b ^^ y)) - -let (^//^) = - prefix 2 1 - -let jump n b y = - group (nest n (break b ^^ y)) - -(* Deprecated. -let ( ^@^ ) x y = group (x ^/^ y) -let ( ^@@^ ) x y = group (nest 2 (x ^/^ y)) -*) - -let infix n b op x y = - prefix n b (x ^^ blank b ^^ op) y - -let surround n b opening contents closing = - group (opening ^^ nest n ( break b ^^ contents) ^^ break b ^^ closing ) - -let soft_surround n b opening contents closing = - group (opening ^^ nest n (group (break b) ^^ contents) ^^ group (break b ^^ closing)) - -let surround_separate n b void opening sep closing docs = - match docs with - | [] -> - void - | _ :: _ -> - surround n b opening (separate sep docs) closing - -let surround_separate_map n b void opening sep closing f xs = - match xs with - | [] -> - void - | _ :: _ -> - surround n b opening (separate_map sep f xs) closing - diff --git a/src/pprint/src/PPrintCombinators.mli b/src/pprint/src/PPrintCombinators.mli deleted file mode 100644 index c538cb35..00000000 --- a/src/pprint/src/PPrintCombinators.mli +++ /dev/null @@ -1,236 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open PPrintEngine - -(** A set of high-level combinators for building documents. *) - -(** {1 Single characters} *) - -(** The following constant documents consist of a single character. *) - -val lparen: document -val rparen: document -val langle: document -val rangle: document -val lbrace: document -val rbrace: document -val lbracket: document -val rbracket: document -val squote: document -val dquote: document -val bquote: document -val semi: document -val colon: document -val comma: document -val space: document -val dot: document -val sharp: document -val slash: document -val backslash: document -val equals: document -val qmark: document -val tilde: document -val at: document -val percent: document -val dollar: document -val caret: document -val ampersand: document -val star: document -val plus: document -val minus: document -val underscore: document -val bang: document -val bar: document - -(** {1 Delimiters} *) - -(** [precede l x] is [l ^^ x]. *) -val precede: document -> document -> document - -(** [terminate r x] is [x ^^ r]. *) -val terminate: document -> document -> document - -(** [enclose l r x] is [l ^^ x ^^ r]. *) -val enclose: document -> document -> document -> document - -(** The following combinators enclose a document within a pair of delimiters. - They are partial applications of [enclose]. No whitespace or line break is - introduced. *) - -val squotes: document -> document -val dquotes: document -> document -val bquotes: document -> document -val braces: document -> document -val parens: document -> document -val angles: document -> document -val brackets: document -> document - -(** {1 Repetition} *) - -(** [twice doc] is the document obtained by concatenating two copies of - the document [doc]. *) -val twice: document -> document - -(** [repeat n doc] is the document obtained by concatenating [n] copies of - the document [doc]. *) -val repeat: int -> document -> document - -(** {1 Lists and options} *) - -(** [concat docs] is the concatenation of the documents in the list [docs]. *) -val concat: document list -> document - -(** [separate sep docs] is the concatenation of the documents in the list - [docs]. The separator [sep] is inserted between every two adjacent - documents. *) -val separate: document -> document list -> document - -(** [concat_map f xs] is equivalent to [concat (List.map f xs)]. *) -val concat_map: ('a -> document) -> 'a list -> document - -(** [separate_map sep f xs] is equivalent to [separate sep (List.map f xs)]. *) -val separate_map: document -> ('a -> document) -> 'a list -> document - -(** [separate2 sep last_sep docs] is the concatenation of the documents in the - list [docs]. The separator [sep] is inserted between every two adjacent - documents, except between the last two documents, where the separator - [last_sep] is used instead. *) -val separate2: document -> document -> document list -> document - -(** [optional f None] is the empty document. [optional f (Some x)] is - the document [f x]. *) -val optional: ('a -> document) -> 'a option -> document - -(** {1 Text} *) - -(** [lines s] is the list of documents obtained by splitting [s] at newline - characters, and turning each line into a document via [substring]. This - code is not UTF-8 aware. *) -val lines: string -> document list - -(** [arbitrary_string s] is equivalent to [separate (break 1) (lines s)]. - It is analogous to [string s], but is valid even if the string [s] - contains newline characters. *) -val arbitrary_string: string -> document - -(** [words s] is the list of documents obtained by splitting [s] at whitespace - characters, and turning each word into a document via [substring]. All - whitespace is discarded. This code is not UTF-8 aware. *) -val words: string -> document list - -(** [split ok s] splits the string [s] before and after every occurrence of a - character that satisfies the predicate [ok]. The substrings thus obtained - are turned into documents, and a list of documents is returned. No - information is lost: the concatenation of the documents yields the - original string. This code is not UTF-8 aware. *) -val split: (char -> bool) -> string -> document list - -(** [flow sep docs] separates the documents in the list [docs] with the - separator [sep] and arranges for a new line to begin whenever a document - does not fit on the current line. This is useful for typesetting - free-flowing, ragged-right text. A typical choice of [sep] is [break b], - where [b] is the number of spaces that must be inserted between two - consecutive words (when displayed on the same line). *) -val flow: document -> document list -> document - -(** [flow_map sep f docs] is equivalent to [flow sep (List.map f docs)]. *) -val flow_map: document -> ('a -> document) -> 'a list -> document - -(** [url s] is a possible way of displaying the URL [s]. A potential line - break is inserted immediately before and immediately after every slash - and dot character. *) -val url: string -> document - -(** {1 Alignment and indentation} *) - -(* [hang n doc] is analogous to [align], but additionally indents - all lines, except the first one, by [n]. Thus, the text in the - box forms a hanging indent. *) -val hang: int -> document -> document - -(** [prefix n b left right] has the following flat layout: {[ -left right -]} -and the following non-flat layout: -{[ -left - right -]} -The parameter [n] controls the nesting of [right] (when not flat). -The parameter [b] controls the number of spaces between [left] and [right] -(when flat). - *) -val prefix: int -> int -> document -> document -> document - -(** [jump n b right] is equivalent to [prefix n b empty right]. *) -val jump: int -> int -> document -> document - -(** [infix n b middle left right] has the following flat layout: {[ -left middle right -]} -and the following non-flat layout: {[ -left middle - right -]} -The parameter [n] controls the nesting of [right] (when not flat). -The parameter [b] controls the number of spaces between [left] and [middle] -(always) and between [middle] and [right] (when flat). -*) -val infix: int -> int -> document -> document -> document -> document - -(** [surround n b opening contents closing] has the following flat layout: {[ -opening contents closing -]} -and the following non-flat layout: {[ -opening - contents -closing -]} -The parameter [n] controls the nesting of [contents] (when not flat). -The parameter [b] controls the number of spaces between [opening] and [contents] -and between [contents] and [closing] (when flat). -*) -val surround: int -> int -> document -> document -> document -> document - -(** [soft_surround] is analogous to [surround], but involves more than one - group, so it offers possibilities other than the completely flat layout - (where [opening], [contents], and [closing] appear on a single line) and - the completely developed layout (where [opening], [contents], and - [closing] appear on separate lines). It tries to place the beginning of - [contents] on the same line as [opening], and to place [closing] on the - same line as the end of [contents], if possible. -*) -val soft_surround: int -> int -> document -> document -> document -> document - -(** [surround_separate n b void opening sep closing docs] is equivalent to - [surround n b opening (separate sep docs) closing], except when the - list [docs] is empty, in which case it reduces to [void]. *) -val surround_separate: int -> int -> document -> document -> document -> document -> document list -> document - -(** [surround_separate_map n b void opening sep closing f xs] is equivalent to - [surround_separate n b void opening sep closing (List.map f xs)]. *) -val surround_separate_map: int -> int -> document -> document -> document -> document -> ('a -> document) -> 'a list -> document - -(** {1 Short-hands} *) - -(** [!^s] is a short-hand for [string s]. *) -val ( !^ ) : string -> document - -(** [x ^/^ y] separates [x] and [y] with a breakable space. - It is a short-hand for [x ^^ break 1 ^^ y]. *) -val ( ^/^ ) : document -> document -> document - -(** [x ^//^ y] is a short-hand for [prefix 2 1 x y]. *) -val ( ^//^ ) : document -> document -> document - diff --git a/src/pprint/src/PPrintEngine.ml b/src/pprint/src/PPrintEngine.ml deleted file mode 100644 index 2a78363d..00000000 --- a/src/pprint/src/PPrintEngine.ml +++ /dev/null @@ -1,642 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* ------------------------------------------------------------------------- *) - -(* A type of integers with infinity. *) - -type requirement = - int (* with infinity *) - -(* Infinity is encoded as [max_int]. *) - -let infinity : requirement = - max_int - -(* Addition of integers with infinity. *) - -let (++) (x : requirement) (y : requirement) : requirement = - if x = infinity || y = infinity then - infinity - else - x + y - -(* Comparison between an integer with infinity and a normal integer. *) - -let (<==) (x : requirement) (y : int) = - x <= y - -(* ------------------------------------------------------------------------- *) - -(* A uniform interface for output channels. *) - -class type output = object - - (** [char c] sends the character [c] to the output channel. *) - method char: char -> unit - - (** [substring s ofs len] sends the substring of [s] delimited by the - offset [ofs] and the length [len] to the output channel. *) - method substring: string -> int (* offset *) -> int (* length *) -> unit - -end - -(* Three kinds of output channels are wrapped so as to satisfy the above - interface: OCaml output channels, OCaml memory buffers, and OCaml - formatters. *) - -class channel_output channel = object - method char = output_char channel - method substring = output_substring channel - (* We used to use [output], but, as of OCaml 4.02 and with -safe-string - enabled, the type of [output] has changed: this function now expects - an argument of type [bytes]. The new function [output_substring] must - be used instead. Furthermore, as of OCaml 4.06, -safe-string is enabled - by default. In summary, we require OCaml 4.02, use [output_substring], - and enable -safe-string. *) -end - -class buffer_output buffer = object - method char = Buffer.add_char buffer - method substring = Buffer.add_substring buffer -end - -class formatter_output fmt = object - method char = Format.pp_print_char fmt - method substring = fst (Format.pp_get_formatter_output_functions fmt ()) -end - -(* ------------------------------------------------------------------------- *) - -(** The rendering engine maintains the following internal state. Its structure - is subject to change in future versions of the library. Nevertheless, it is - exposed to the user who wishes to define custom documents. *) - -type state = { - - width: int; - (** The line width. This parameter is fixed throughout the execution of - the renderer. *) - - ribbon: int; - (** The ribbon width. This parameter is fixed throughout the execution of - the renderer. *) - - mutable last_indent: int; - (** The number of blanks that were printed at the beginning of the current - line. This field is updated (only) by the function [emit_hardline]. It - is used (only) to determine whether the ribbon width constraint is - respected. *) - - mutable column: int; - (** The current column. This field must be updated whenever something is - sent to the output channel. It is used (only) to determine whether the - width constraint is respected. *) - - } - -(* ------------------------------------------------------------------------- *) - -(* [initial rfrac width] creates a fresh initial state. *) - -let initial rfrac width = { - width = width; - ribbon = max 0 (min width (truncate (float_of_int width *. rfrac))); - last_indent = 0; - column = 0 -} - -(* ------------------------------------------------------------------------- *) - -(** A custom document is defined by implementing the following methods. *) - -class type custom = object - - (** A custom document must publish the width (i.e., the number of columns) - that it would like to occupy if it is printed on a single line (that is, - in flattening mode). The special value [infinity] means that this - document cannot be printed on a single line; this value causes any - groups that contain this document to be dissolved. This method should - in principle work in constant time. *) - method requirement: requirement - - (** The method [pretty] is used by the main rendering algorithm. It has - access to the output channel and to the algorithm's internal state, as - described above. In addition, it receives the current indentation level - and the current flattening mode (on or off). If flattening mode is on, - then the document must be printed on a single line, in a manner that is - consistent with the requirement that was published ahead of time. If - flattening mode is off, then there is no such obligation. The state must - be updated in a manner that is consistent with what is sent to the - output channel. *) - method pretty: output -> state -> int -> bool -> unit - - (** The method [compact] is used by the compact rendering algorithm. It has - access to the output channel only. *) - method compact: output -> unit - -end - -(* ------------------------------------------------------------------------- *) - -(* Here is the algebraic data type of documents. It is analogous to Daan - Leijen's version, but the binary constructor [Union] is replaced with - the unary constructor [Group], and the constant [Line] is replaced with - more general constructions, namely [IfFlat], which provides alternative - forms depending on the current flattening mode, and [HardLine], which - represents a newline character, and causes a failure in flattening mode. *) - -type document = - - (* [Empty] is the empty document. *) - - | Empty - - (* [Char c] is a document that consists of the single character [c]. We - enforce the invariant that [c] is not a newline character. *) - - | Char of char - - (* [String s] is a document that consists of just the string [s]. We - assume, but do not check, that this string does not contain a newline - character. [String] is a special case of [FancyString], which takes up - less space in memory. *) - - | String of string - - (* [FancyString (s, ofs, len, apparent_length)] is a (portion of a) string - that may contain fancy characters: color escape characters, UTF-8 or - multi-byte characters, etc. Thus, the apparent length (which corresponds - to what will be visible on screen) differs from the length (which is a - number of bytes, and is reported by [String.length]). We assume, but do - not check, that fancystrings do not contain a newline character. *) - - | FancyString of string * int * int * int - - (* [Blank n] is a document that consists of [n] blank characters. *) - - | Blank of int - - (* When in flattening mode, [IfFlat (d1, d2)] turns into the document - [d1]. When not in flattening mode, it turns into the document [d2]. *) - - | IfFlat of document * document - - (* When in flattening mode, [HardLine] causes a failure, which requires - backtracking all the way until the stack is empty. When not in flattening - mode, it represents a newline character, followed with an appropriate - number of indentation. A common way of using [HardLine] is to only use it - directly within the right branch of an [IfFlat] construct. *) - - | HardLine - - (* The following constructors store their space requirement. This is the - document's apparent length, if printed in flattening mode. This - information is computed in a bottom-up manner when the document is - constructed. *) - - (* In other words, the space requirement is the number of columns that the - document needs in order to fit on a single line. We express this value in - the set of `integers extended with infinity', and use the value - [infinity] to indicate that the document cannot be printed on a single - line. *) - - (* Storing this information at [Group] nodes is crucial, as it allows us to - avoid backtracking and buffering. *) - - (* Storing this information at other nodes allows the function [requirement] - to operate in constant time. This means that the bottom-up computation of - requirements takes linear time. *) - - (* [Cat (req, doc1, doc2)] is the concatenation of the documents [doc1] and - [doc2]. The space requirement [req] is the sum of the requirements of - [doc1] and [doc2]. *) - - | Cat of requirement * document * document - - (* [Nest (req, j, doc)] is the document [doc], in which the indentation - level has been increased by [j], that is, in which [j] blanks have been - inserted after every newline character. The space requirement [req] is - the same as the requirement of [doc]. *) - - | Nest of requirement * int * document - - (* [Group (req, doc)] represents an alternative: it is either a flattened - form of [doc], in which occurrences of [Group] disappear and occurrences - of [IfFlat] resolve to their left branch, or [doc] itself. The space - requirement [req] is the same as the requirement of [doc]. *) - - | Group of requirement * document - - (* [Align (req, doc)] increases the indentation level to reach the current - column. Thus, the document [doc] is rendered within a box whose upper - left corner is the current position. The space requirement [req] is the - same as the requirement of [doc]. *) - - | Align of requirement * document - - (* [Custom (req, f)] is a document whose appearance is user-defined. *) - - | Custom of custom - -(* ------------------------------------------------------------------------- *) - -(* Retrieving or computing the space requirement of a document. *) - -let rec requirement = function - | Empty -> - 0 - | Char _ -> - 1 - | String s -> - String.length s - | FancyString (_, _, _, len) - | Blank len -> - len - | IfFlat (doc1, _) -> - (* In flattening mode, the requirement of [ifflat x y] is just the - requirement of its flat version, [x]. *) - (* The smart constructor [ifflat] ensures that [IfFlat] is never nested - in the left-hand side of [IfFlat], so this recursive call is not a - problem; the function [requirement] has constant time complexity. *) - requirement doc1 - | HardLine -> - (* A hard line cannot be printed in flattening mode. *) - infinity - | Cat (req, _, _) - | Nest (req, _, _) - | Group (req, _) - | Align (req, _) -> - (* These nodes store their requirement -- which is computed when the - node is constructed -- so as to allow us to answer in constant time - here. *) - req - | Custom c -> - c#requirement - -(* ------------------------------------------------------------------------- *) - -(* The above algebraic data type is not exposed to the user. Instead, we - expose the following functions. These functions construct a raw document - and compute its requirement, so as to obtain a document. *) - -let empty = - Empty - -let char c = - assert (c <> '\n'); - Char c - -let space = - char ' ' - -let string s = - String s - -let fancysubstring s ofs len apparent_length = - if len = 0 then - empty - else - FancyString (s, ofs, len, apparent_length) - -let substring s ofs len = - fancysubstring s ofs len len - -let fancystring s apparent_length = - fancysubstring s 0 (String.length s) apparent_length - -(* The following function was stolen from [Batteries]. *) -let utf8_length s = - let rec length_aux s c i = - if i >= String.length s then c else - let n = Char.code (String.unsafe_get s i) in - let k = - if n < 0x80 then 1 else - if n < 0xe0 then 2 else - if n < 0xf0 then 3 else 4 - in - length_aux s (c + 1) (i + k) - in - length_aux s 0 0 - -let utf8string s = - fancystring s (utf8_length s) - -let hardline = - HardLine - -let blank n = - match n with - | 0 -> - empty - | 1 -> - space - | _ -> - Blank n - -let ifflat doc1 doc2 = - (* Avoid nesting [IfFlat] in the left-hand side of [IfFlat], as this - is redundant. *) - match doc1 with - | IfFlat (doc1, _) - | doc1 -> - IfFlat (doc1, doc2) - -let internal_break i = - ifflat (blank i) hardline - -let break0 = - internal_break 0 - -let break1 = - internal_break 1 - -let break i = - match i with - | 0 -> - break0 - | 1 -> - break1 - | _ -> - internal_break i - -let (^^) x y = - match x, y with - | Empty, _ -> - y - | _, Empty -> - x - | _, _ -> - Cat (requirement x ++ requirement y, x, y) - -let nest i x = - assert (i >= 0); - Nest (requirement x, i, x) - -let group x = - let req = requirement x in - (* Minor optimisation: an infinite requirement dissolves a group. *) - if req = infinity then - x - else - Group (req, x) - -let align x = - Align (requirement x, x) - -let custom c = - (* Sanity check. *) - assert (c#requirement >= 0); - Custom c - -(* ------------------------------------------------------------------------- *) - -(* Printing blank space (indentation characters). *) - -let blank_length = - 80 - -let blank_buffer = - String.make blank_length ' ' - -let rec blanks output n = - if n <= 0 then - () - else if n <= blank_length then - output#substring blank_buffer 0 n - else begin - output#substring blank_buffer 0 blank_length; - blanks output (n - blank_length) - end - -(* ------------------------------------------------------------------------- *) - -(* This function expresses the following invariant: if we are in flattening - mode, then we must be within bounds, i.e. the width and ribbon width - constraints must be respected. *) - -let ok state flatten : bool = - not flatten || - state.column <= state.width && state.column <= state.last_indent + state.ribbon - -(* ------------------------------------------------------------------------- *) - -(* The pretty rendering engine. *) - -(* The renderer is supposed to behave exactly like Daan Leijen's, although its - implementation is quite radically different, and simpler. Our documents are - constructed eagerly, as opposed to lazily. This means that we pay a large - space overhead, but in return, we get the ability of computing information - bottom-up, as described above, which allows to render documents without - backtracking or buffering. *) - -(* The [state] record is never copied; it is just threaded through. In - addition to it, the parameters [indent] and [flatten] influence the - manner in which the document is rendered. *) - -(* The code is written in tail-recursive style, so as to avoid running out of - stack space if the document is very deep. Its explicit continuation can be - viewed as a sequence of pending calls to [pretty]. *) - -type cont = - | KNil - | KCons of int * bool * document * cont - -let rec pretty - (output : output) - (state : state) - (indent : int) - (flatten : bool) - (doc : document) - (cont : cont) -: unit = - match doc with - - | Empty -> - continue output state cont - - | Char c -> - output#char c; - state.column <- state.column + 1; - (* assert (ok state flatten); *) - continue output state cont - - | String s -> - let len = String.length s in - output#substring s 0 len; - state.column <- state.column + len; - (* assert (ok state flatten); *) - continue output state cont - - | FancyString (s, ofs, len, apparent_length) -> - output#substring s ofs len; - state.column <- state.column + apparent_length; - (* assert (ok state flatten); *) - continue output state cont - - | Blank n -> - blanks output n; - state.column <- state.column + n; - (* assert (ok state flatten); *) - continue output state cont - - | HardLine -> - (* We cannot be in flattening mode, because a hard line has an [infinity] - requirement, and we attempt to render a group in flattening mode only - if this group's requirement is met. *) - assert (not flatten); - (* Emit a hardline. *) - output#char '\n'; - blanks output indent; - state.column <- indent; - state.last_indent <- indent; - (* Continue. *) - continue output state cont - - | IfFlat (doc1, doc2) -> - (* Pick an appropriate sub-document, based on the current flattening - mode. *) - pretty output state indent flatten (if flatten then doc1 else doc2) cont - - | Cat (_, doc1, doc2) -> - (* Push the second document onto the continuation. *) - pretty output state indent flatten doc1 (KCons (indent, flatten, doc2, cont)) - - | Nest (_, j, doc) -> - pretty output state (indent + j) flatten doc cont - - | Group (req, doc) -> - (* If we already are in flattening mode, stay in flattening mode; we - are committed to it. If we are not already in flattening mode, we - have a choice of entering flattening mode. We enter this mode only - if we know that this group fits on this line without violating the - width or ribbon width constraints. Thus, we never backtrack. *) - let flatten = - flatten || - let column = state.column ++ req in - column <== state.width && column <== state.last_indent + state.ribbon - in - pretty output state indent flatten doc cont - - | Align (_, doc) -> - (* The effect of this combinator is to set [indent] to [state.column]. - Usually [indent] is equal to [state.last_indent], hence setting it - to [state.column] increases it. However, if [nest] has been used - since the current line began, then this could cause [indent] to - decrease. *) - (* assert (state.column > state.last_indent); *) - pretty output state state.column flatten doc cont - - | Custom c -> - (* Invoke the document's custom rendering function. *) - c#pretty output state indent flatten; - (* Sanity check. *) - assert (ok state flatten); - (* Continue. *) - continue output state cont - -and continue output state = function - | KNil -> - () - | KCons (indent, flatten, doc, cont) -> - pretty output state indent flatten doc cont - -(* Publish a version of [pretty] that does not take an explicit continuation. - This function may be used by authors of custom documents. We do not expose - the internal [pretty] -- the one that takes a continuation -- because we - wish to simplify the user's life. The price to pay is that calls that go - through a custom document cannot be tail calls. *) - -let pretty output state indent flatten doc = - pretty output state indent flatten doc KNil - -(* ------------------------------------------------------------------------- *) - -(* The compact rendering algorithm. *) - -let rec compact output doc cont = - match doc with - | Empty -> - continue output cont - | Char c -> - output#char c; - continue output cont - | String s -> - let len = String.length s in - output#substring s 0 len; - continue output cont - | FancyString (s, ofs, len, apparent_length) -> - output#substring s ofs len; - continue output cont - | Blank n -> - blanks output n; - continue output cont - | HardLine -> - output#char '\n'; - continue output cont - | Cat (_, doc1, doc2) -> - compact output doc1 (doc2 :: cont) - | IfFlat (doc, _) - | Nest (_, _, doc) - | Group (_, doc) - | Align (_, doc) -> - compact output doc cont - | Custom c -> - (* Invoke the document's custom rendering function. *) - c#compact output; - continue output cont - -and continue output cont = - match cont with - | [] -> - () - | doc :: cont -> - compact output doc cont - -let compact output doc = - compact output doc [] - -(* ------------------------------------------------------------------------- *) - -(* We now instantiate the renderers for the three kinds of output channels. *) - -(* This is just boilerplate. *) - -module MakeRenderer (X : sig - type channel - val output: channel -> output -end) = struct - type channel = X.channel - type dummy = document - type document = dummy - let pretty rfrac width channel doc = pretty (X.output channel) (initial rfrac width) 0 false doc - let compact channel doc = compact (X.output channel) doc -end - -module ToChannel = - MakeRenderer(struct - type channel = out_channel - let output = new channel_output - end) - -module ToBuffer = - MakeRenderer(struct - type channel = Buffer.t - let output = new buffer_output - end) - -module ToFormatter = - MakeRenderer(struct - type channel = Format.formatter - let output = new formatter_output - end) diff --git a/src/pprint/src/PPrintEngine.mli b/src/pprint/src/PPrintEngine.mli deleted file mode 100644 index eda61a6c..00000000 --- a/src/pprint/src/PPrintEngine.mli +++ /dev/null @@ -1,226 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** A pretty-printing engine and a set of basic document combinators. *) - -(** {1 Building documents} *) - -(** Documents must be built in memory before they are rendered. This may seem - costly, but it is a simple approach, and works well. *) - -(** The following operations form a set of basic (low-level) combinators for - building documents. On top of these combinators, higher-level combinators - can be defined: see {!PPrintCombinators}. *) - -(** This is the abstract type of documents. *) -type document - -(** The following basic (low-level) combinators allow constructing documents. *) - -(** [empty] is the empty document. *) -val empty: document - -(** [char c] is a document that consists of the single character [c]. This - character must not be a newline. *) -val char: char -> document - -(** [string s] is a document that consists of the string [s]. This string must - not contain a newline. *) -val string: string -> document - -(** [substring s ofs len] is a document that consists of the portion of the - string [s] delimited by the offset [ofs] and the length [len]. This - portion must not contain a newline. *) -val substring: string -> int -> int -> document - -(** [fancystring s apparent_length] is a document that consists of the string - [s]. This string must not contain a newline. The string may contain fancy - characters: color escape characters, UTF-8 or multi-byte characters, - etc. Thus, its apparent length (which measures how many columns the text - will take up on screen) differs from its length in bytes. *) -val fancystring: string -> int -> document - -(** [fancysubstring s ofs len apparent_length] is a document that consists of - the portion of the string [s] delimited by the offset [ofs] and the length - [len]. This portion must contain a newline. The string may contain fancy - characters. *) -val fancysubstring : string -> int -> int -> int -> document - -(** [utf8string s] is a document that consists of the UTF-8-encoded string [s]. - This string must not contain a newline. *) -val utf8string: string -> document - -(** [hardline] is a forced newline document. This document forces all enclosing - groups to be printed in non-flattening mode. In other words, any enclosing - groups are dissolved. *) -val hardline: document - -(** [blank n] is a document that consists of [n] blank characters. *) -val blank: int -> document - -(** [break n] is a document which consists of either [n] blank characters, - when forced to display on a single line, or a single newline character, - otherwise. Note that there is no choice at this point: choices are encoded - by the [group] combinator. *) -val break: int -> document - -(** [doc1 ^^ doc2] is the concatenation of the documents [doc1] and [doc2]. *) -val (^^): document -> document -> document - -(** [nest j doc] is the document [doc], in which the indentation level has - been increased by [j], that is, in which [j] blanks have been inserted - after every newline character. Read this again: indentation is inserted - after every newline character. No indentation is inserted at the beginning - of the document. *) -val nest: int -> document -> document - -(** [group doc] encodes a choice. If possible, then the entire document [group - doc] is rendered on a single line. Otherwise, the group is dissolved, and - [doc] is rendered. There might be further groups within [doc], whose - presence will lead to further choices being explored. *) -val group: document -> document - -(** [ifflat doc1 doc2] is rendered as [doc1] if part of a group that can be - successfully flattened, and is rendered as [doc2] otherwise. Use this - operation with caution. Because the pretty-printer is free to choose - between [doc1] and [doc2], these documents should be semantically - equivalent. *) -val ifflat: document -> document -> document - -(** [align doc] is the document [doc], in which the indentation level has been - set to the current column. Thus, [doc] is rendered within a box whose - upper left corner is the current position. *) -val align: document -> document - -(** {1 Rendering documents} *) - -(** This renderer sends its output into an output channel. *) -module ToChannel : PPrintRenderer.RENDERER - with type channel = out_channel - and type document = document - -(** This renderer sends its output into a memory buffer. *) -module ToBuffer : PPrintRenderer.RENDERER - with type channel = Buffer.t - and type document = document - -(** This renderer sends its output into a formatter channel. *) -module ToFormatter : PPrintRenderer.RENDERER - with type channel = Format.formatter - and type document = document - -(** {1 Defining custom documents} *) - -(** A width requirement is expressed as an integer, where the value [max_int] - is reserved and represents infinity. *) - -type requirement = int -val infinity : requirement - -(** An output channel is represented abstractly as an object equipped with - methods for displaying one character and for displaying a substring. *) - -class type output = object - - (** [char c] sends the character [c] to the output channel. *) - method char: char -> unit - - (** [substring s ofs len] sends the substring of [s] delimited by the - offset [ofs] and the length [len] to the output channel. *) - method substring: string -> int (* offset *) -> int (* length *) -> unit - -end - -(** The rendering engine maintains the following internal state. Its structure - is subject to change in future versions of the library. Nevertheless, it is - exposed to the user who wishes to define custom documents. *) - -type state = { - - width: int; - (** The line width. This parameter is fixed throughout the execution of - the renderer. *) - - ribbon: int; - (** The ribbon width. This parameter is fixed throughout the execution of - the renderer. *) - - mutable last_indent: int; - (** The number of blanks that were printed at the beginning of the current - line. This field is updated (only) by the function [emit_hardline]. It - is used (only) to determine whether the ribbon width constraint is - respected. *) - - mutable column: int; - (** The current column. This field must be updated whenever something is - sent to the output channel. It is used (only) to determine whether the - width constraint is respected. *) - - } - -(** A custom document is defined by implementing the following methods. *) - -class type custom = object - - (** A custom document must publish the width (i.e., the number of columns) - that it would like to occupy if it is printed on a single line (that is, - in flattening mode). The special value [infinity] means that this - document cannot be printed on a single line; this value causes any - groups that contain this document to be dissolved. This method should - in principle work in constant time. *) - method requirement: requirement - - (** The method [pretty] is used by the main rendering algorithm. It has - access to the output channel and to the algorithm's internal state, as - described above. In addition, it receives the current indentation level - and the current flattening mode (on or off). If flattening mode is on, - then the document must be printed on a single line, in a manner that is - consistent with the requirement that was published ahead of time. If - flattening mode is off, then there is no such obligation. The state must - be updated in a manner that is consistent with what is sent to the - output channel. *) - method pretty: output -> state -> int -> bool -> unit - - (** The method [compact] is used by the compact rendering algorithm. It has - access to the output channel only. *) - method compact: output -> unit - -end - -(** The function [custom] constructs a custom document. In other words, it - converts an object of type [custom] to a document. *) -val custom: custom -> document - -(** The key functions of the library are exposed, in the hope that they may be - useful to authors of custom (leaf and non-leaf) documents. In the case of - a leaf document, they can help perform certain basic functions; for - instance, applying the function [pretty] to the document [hardline] is a - simple way of printing a hardline, while respecting the indentation - parameters and updating the state in a correct manner. Similarly, applying - [pretty] to the document [blank n] is a simple way of printing [n] spaces. - In the case of a non-leaf document (i.e., one which contains - sub-documents), these functions are essential: they allow computing the - width requirement of a sub-document and displaying a sub-document. *) - -(** [requirement doc] computes the width requirement of the document [doc]. - It works in constant time. *) -val requirement: document -> requirement - -(** [pretty output state indent flatten doc] prints the document [doc]. See - the documentation of the method [pretty]. *) -val pretty: output -> state -> int -> bool -> document -> unit - -(** [compact output doc] prints the document [doc]. See the documentation of - the method [compact]. *) -val compact: output -> document -> unit - diff --git a/src/pprint/src/PPrintLib.mllib b/src/pprint/src/PPrintLib.mllib deleted file mode 100644 index e5de6978..00000000 --- a/src/pprint/src/PPrintLib.mllib +++ /dev/null @@ -1,5 +0,0 @@ -PPrint -PPrintCombinators -PPrintEngine -PPrintOCaml -PPrintRenderer diff --git a/src/pprint/src/PPrintOCaml.ml b/src/pprint/src/PPrintOCaml.ml deleted file mode 100644 index bee5f2a3..00000000 --- a/src/pprint/src/PPrintOCaml.ml +++ /dev/null @@ -1,158 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Printf -open PPrintEngine -open PPrintCombinators - -type constructor = string -type type_name = string -type record_field = string -type tag = int - -(* ------------------------------------------------------------------------- *) - -(* This internal [sprintf]-like function produces a document. We use [string], - as opposed to [arbitrary_string], because the strings that we produce will - never contain a newline character. *) - -let dsprintf format = - ksprintf string format - -(* ------------------------------------------------------------------------- *) - -(* Nicolas prefers using this code as opposed to just [sprintf "%g"] or - [sprintf "%f"]. The latter print [inf] and [-inf], whereas OCaml - understands [infinity] and [neg_infinity]. [sprintf "%g"] does not add a - trailing dot when the number happens to be an integral number. [sprintf - "%F"] seems to lose precision and ignores the precision modifier. *) - -let valid_float_lexeme (s : string) : string = - let l = String.length s in - let rec loop i = - if i >= l then - (* If we reach the end of the string and have found only characters in - the set '0' .. '9' and '-', then this string will be considered as an - integer literal by OCaml. Adding a trailing dot makes it a float - literal. *) - s ^ "." - else - match s.[i] with - | '0' .. '9' | '-' -> loop (i + 1) - | _ -> s - in loop 0 - -(* This function constructs a string representation of a floating point - number. This representation is supposed to be accepted by OCaml as a - valid floating point literal. *) - -let float_representation (f : float) : string = - match classify_float f with - | FP_nan -> - "nan" - | FP_infinite -> - if f < 0.0 then "neg_infinity" else "infinity" - | _ -> - (* Try increasing precisions and validate. *) - let s = sprintf "%.12g" f in - if f = float_of_string s then valid_float_lexeme s else - let s = sprintf "%.15g" f in - if f = float_of_string s then valid_float_lexeme s else - sprintf "%.18g" f - -(* ------------------------------------------------------------------------- *) - -(* A few constants and combinators, used below. *) - -let some = - string "Some" - -let none = - string "None" - -let lbracketbar = - string "[|" - -let rbracketbar = - string "|]" - -let seq1 opening separator closing = - surround_separate 2 0 (opening ^^ closing) opening (separator ^^ break 1) closing - -let seq2 opening separator closing = - surround_separate_map 2 1 (opening ^^ closing) opening (separator ^^ break 1) closing - -(* ------------------------------------------------------------------------- *) - -(* The following functions are printers for many types of OCaml values. *) - -(* There is no protection against cyclic values. *) - -type representation = - document - -let tuple = - seq1 lparen comma rparen - -let variant _ cons _ args = - match args with - | [] -> - !^cons - | _ :: _ -> - !^cons ^^ tuple args - -let record _ fields = - seq2 lbrace semi rbrace (fun (k, v) -> infix 2 1 equals !^k v) fields - -let option f = function - | None -> - none - | Some x -> - some ^^ tuple [f x] - -let list f xs = - seq2 lbracket semi rbracket f xs - -let array f xs = - seq2 lbracketbar semi rbracketbar f (Array.to_list xs) - -let ref f x = - record "ref" ["contents", f !x] - -let float f = - string (float_representation f) - -let int = - dsprintf "%d" - -let int32 = - dsprintf "%ld" - -let int64 = - dsprintf "%Ld" - -let nativeint = - dsprintf "%nd" - -let char = - dsprintf "%C" - -let bool = - dsprintf "%B" - -let string = - dsprintf "%S" - -let unknown tyname _ = - dsprintf "<abstr:%s>" tyname - diff --git a/src/pprint/src/PPrintOCaml.mli b/src/pprint/src/PPrintOCaml.mli deleted file mode 100644 index 119bca23..00000000 --- a/src/pprint/src/PPrintOCaml.mli +++ /dev/null @@ -1,90 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** A set of functions that construct representations of OCaml values. *) - -(** The string representations produced by these functions are supposed to be - accepted by the OCaml parser as valid values. *) - -(** The signature of this module is compatible with that expected by - the [camlp4] generator [Camlp4RepresentationGenerator]. *) - -(** These functions do {i not} distinguish between mutable and immutable - values. They do {i not} recognize sharing, and do {i not} incorporate a - protection against cyclic values. *) - -type constructor = string -type type_name = string -type record_field = string -type tag = int - -(** A representation of a value is a [PPrint] document. *) -type representation = - PPrintEngine.document - -(** [variant _ dc _ args] is a description of a constructed value whose data - constructor is [dc] and whose arguments are [args]. The other two - parameters are presently unused. *) -val variant : type_name -> constructor -> tag -> representation list -> representation - -(** [record _ fields] is a description of a record value whose fields are - [fields]. The other parameter is presently unused. *) -val record : type_name -> (record_field * representation) list -> representation - -(** [tuple args] is a description of a tuple value whose components are [args]. *) -val tuple : representation list -> representation - -(** [string s] is a representation of the string [s]. *) -val string : string -> representation - -(** [int i] is a representation of the integer [i]. *) -val int : int -> representation - -(** [int32 i] is a representation of the 32-bit integer [i]. *) -val int32 : int32 -> representation - -(** [int64 i] is a representation of the 64-bit integer [i]. *) -val int64 : int64 -> representation - -(** [nativeint i] is a representation of the native integer [i]. *) -val nativeint : nativeint -> representation - -(** [float f] is a representation of the floating-point number [f]. *) -val float : float -> representation - -(** [char c] is a representation of the character [c]. *) -val char : char -> representation - -(** [bool b] is a representation of the Boolenan value [b]. *) -val bool : bool -> representation - -(** [option f o] is a representation of the option [o], where the - representation of the element, if present, is computed by the function - [f]. *) -val option : ('a -> representation) -> 'a option -> representation - -(** [list f xs] is a representation of the list [xs], where the representation - of each element is computed by the function [f]. *) -val list : ('a -> representation) -> 'a list -> representation - -(** [array f xs] is a representation of the array [xs], where the - representation of each element is computed by the function [f]. *) -val array : ('a -> representation) -> 'a array -> representation - -(** [ref r] is a representation of the reference [r], where the - representation of the content is computed by the function [f]. *) -val ref : ('a -> representation) -> 'a ref -> representation - -(** [unknown t _] is a representation of an unknown value of type [t]. *) -val unknown : type_name -> 'a -> representation - diff --git a/src/pprint/src/PPrintRenderer.ml b/src/pprint/src/PPrintRenderer.ml deleted file mode 100644 index 3449d6c3..00000000 --- a/src/pprint/src/PPrintRenderer.ml +++ /dev/null @@ -1,37 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** A common signature for the multiple document renderers proposed by {!PPrintEngine}. *) - -module type RENDERER = sig - - (** Output channels. *) - type channel - - (** Documents. *) - type document - - (** [pretty rfrac width channel document] pretty-prints the document - [document] into the output channel [channel]. The parameter [width] is - the maximum number of characters per line. The parameter [rfrac] is the - ribbon width, a fraction relative to [width]. The ribbon width is the - maximum number of non-indentation characters per line. *) - val pretty: float -> int -> channel -> document -> unit - - (** [compact channel document] prints the document [document] to the output - channel [channel]. No indentation is used. All newline instructions are - respected, that is, no groups are flattened. *) - val compact: channel -> document -> unit - -end - diff --git a/src/pprint/src/PPrintTest.ml b/src/pprint/src/PPrintTest.ml deleted file mode 100644 index 37444127..00000000 --- a/src/pprint/src/PPrintTest.ml +++ /dev/null @@ -1,64 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open PPrint - -(* This is a test file. It is not, strictly speaking, part of the library. *) - -let paragraph (s : string) = - flow (break 1) (words s) - -let document = - prefix 2 1 - (string "TITLE:") - (string "PPrint") - ^^ - hardline - ^^ - prefix 2 1 - (string "AUTHORS:") - (utf8string "François Pottier and Nicolas Pouillard") - ^^ - hardline - ^^ - prefix 2 1 - (string "ABSTRACT:") - ( - paragraph "This is an adaptation of Daan Leijen's \"PPrint\" library, - which itself is based on the ideas developed by Philip Wadler in - \"A Prettier Printer\". For more information about Wadler's and Leijen's work, - please consult the following references:" - ^^ - nest 2 ( - twice (break 1) - ^^ - separate_map (break 1) (fun s -> nest 2 (url s)) [ - "http://www.cs.uu.nl/~daan/pprint.html"; - "http://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf"; - ] - ) - ^^ - twice (break 1) - ^^ - paragraph "To install PPrint, type \"make -C src install\". ocamlfind is required." - ^^ - twice (break 1) - ^^ - paragraph "The documentation for PPrint is built by \"make doc\" and is found in the file doc/index.html." - ) - ^^ - hardline - -let () = - ToChannel.pretty 0.5 80 stdout document; - flush stdout diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 3a37d9ff..17dba718 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -93,7 +93,7 @@ type context = { kid_renames : kid KBindings.t; (* Plain tyvar -> tyvar renames, used to avoid variable/type variable name clashes *) (* Note that as well as these kid renames, we also attempt to replace entire - n_constraints with equivalent variables in doc_nc_prop and doc_nc_exp. *) + n_constraints with equivalent variables in doc_nc_exp. *) kid_id_renames : (id option) KBindings.t; (* tyvar -> argument renames *) kid_id_renames_rev : kid Bindings.t; (* reverse of kid_id_renames *) bound_nvars : KidSet.t; @@ -388,16 +388,12 @@ match nc1, nc2 with | _,_ -> mk_nc (NC_app (mk_id "iff",[arg_bool nc1; arg_bool nc2])) (* n_constraint functions are currently just Z3 functions *) -let doc_nc_fn_prop id = - match string_of_id id with - | "not" -> string "not" - | _ -> doc_id_type id - -(* n_constraint functions are currently just Z3 functions *) -let doc_nc_fn id = - match string_of_id id with - | "not" -> string "negb" - | s -> string s +let doc_nc_fn (Id_aux (id,_) as full_id) = + match id with + | Id "not" -> string "negb" + | Operator "-->" -> string "implb" + | Id "iff" -> string "Bool.eqb" + | _ -> doc_id full_id let merge_kid_count = KBindings.union (fun _ m n -> Some (m+n)) @@ -622,7 +618,7 @@ let rec doc_typ_fns ctx env = | Bool_boring -> string "bool" | Bool_complex (_,_,atom_nc) -> (* simplify won't introduce new kopts *) let var = mk_kid "_bool" in (* TODO collision avoid *) - let nc = nice_iff (nc_var var) atom_nc in + let nc = nice_iff atom_nc (nc_var var) in braces (separate space [doc_var ctx var; colon; string "bool"; ampersand; @@ -676,7 +672,7 @@ let rec doc_typ_fns ctx env = let length_constraint_pp = if KidSet.is_empty (KidSet.inter kid_set (nexp_frees m)) then None - else Some (separate space [len_pp; doc_var ctx var; equals; doc_nexp ctx m]) + else Some (separate space [len_pp; doc_var ctx var; string "=?"; doc_nexp ctx m]) in braces (separate space [doc_var ctx var; colon; tpp; @@ -694,7 +690,7 @@ let rec doc_typ_fns ctx env = let length_constraint_pp = if KidSet.is_empty (KidSet.inter kid_set (nexp_frees m)) then None - else Some (separate space [len_pp; doc_var ctx var; equals; doc_nexp ctx m]) + else Some (separate space [len_pp; doc_var ctx var; string "=?"; doc_nexp ctx m]) in braces (separate space [doc_var ctx var; colon; tpp; @@ -705,7 +701,7 @@ let rec doc_typ_fns ctx env = | Bool_boring -> string "bool" | Bool_complex (kopts,nc,atom_nc) -> let var = mk_kid "_bool" in (* TODO collision avoid *) - let nc = nice_and (nice_iff (nc_var var) atom_nc) nc in + let nc = nice_and (nice_iff atom_nc (nc_var var)) nc in braces (separate space [doc_var ctx var; colon; string "bool"; ampersand; @@ -773,94 +769,26 @@ let rec doc_typ_fns ctx env = | A_typ t -> app_typ true t | A_nexp n -> doc_nexp ctx n | A_order o -> empty - | A_bool nc -> doc_nc_prop ~prop_vars ~top:false ctx env nc + | A_bool nc -> parens (doc_nc_exp ctx env nc) in typ', atomic_typ, doc_typ_arg and doc_typ ctx env = let f,_,_ = doc_typ_fns ctx env in f and doc_atomic_typ ctx env = let _,f,_ = doc_typ_fns ctx env in f and doc_typ_arg ctx env = let _,_,f = doc_typ_fns ctx env in f -and doc_arithfact ?(prop_vars=false) ctxt env ?(exists = []) ?extra nc = - let prop = doc_nc_prop ~prop_vars ctxt env nc in +and doc_arithfact ctxt env ?(exists = []) ?extra nc = + let prop = doc_nc_exp ctxt env nc in let prop = match extra with | None -> prop - | Some pp -> separate space [pp; string "/\\"; parens prop] - in - let prop = - match exists with - | [] -> prop - | _ -> separate space ([string "exists"]@(List.map (doc_var ctxt) exists)@[comma; prop]) + | Some pp -> separate space [parens pp; string "&&"; parens prop] in - string "ArithFact" ^^ space ^^ parens prop - -(* Follows Coq precedence levels *) -and doc_nc_prop ?(top = true) ?(prop_vars = false) ctx env nc = - let locals = Env.get_locals env |> Bindings.bindings in - let nc = Env.expand_constraint_synonyms env nc in - let doc_nc_var varpp = - if prop_vars then varpp else doc_op equals varpp (string "true") - in - let nc_id_map = - List.fold_left - (fun m (v,(_,Typ_aux (typ,_))) -> - match typ with - | Typ_app (id, [A_aux (A_bool nc,_)]) when string_of_id id = "atom_bool" -> - (flatten_nc nc, v)::m - | _ -> m) [] locals - in - let rec newnc f nc = - let ncs = flatten_nc nc in - let candidates = - Util.map_filter (fun (ncs',id) -> Util.option_map (fun x -> x,id) (list_contains NC.compare ncs ncs')) nc_id_map - in - match List.sort (fun (l,_) (l',_) -> compare l l') candidates with - | ([],id)::_ -> parens (doc_nc_var (doc_id id)) - | ((h::t),id)::_ -> parens (doc_op (string "/\\") (parens (doc_nc_var (doc_id id))) (l80 (List.fold_left nc_and h t))) - | [] -> f nc - and l85 (NC_aux (nc,_) as nc_full) = - match nc with - | NC_or (nc1, nc2) -> doc_op (string "\\/") (newnc l80 nc1) (newnc l85 nc2) - | _ -> l80 nc_full - and l80 (NC_aux (nc,_) as nc_full) = - match nc with - | NC_and (nc1, nc2) -> doc_op (string "/\\") (newnc l70 nc1) (newnc l80 nc2) - | _ -> l70 nc_full - and l70 (NC_aux (nc,_) as nc_full) = - match nc with - | NC_equal (ne1, ne2) -> doc_op equals (doc_nexp ctx ne1) (doc_nexp ctx ne2) - | NC_var kid -> doc_nc_var (doc_nexp ctx (nvar kid)) - | NC_bounded_ge (ne1, ne2) -> doc_op (string ">=") (doc_nexp ctx ne1) (doc_nexp ctx ne2) - | NC_bounded_gt (ne1, ne2) -> doc_op (string ">") (doc_nexp ctx ne1) (doc_nexp ctx ne2) - | NC_bounded_le (ne1, ne2) -> doc_op (string "<=") (doc_nexp ctx ne1) (doc_nexp ctx ne2) - | NC_bounded_lt (ne1, ne2) -> doc_op (string "<") (doc_nexp ctx ne1) (doc_nexp ctx ne2) - | NC_not_equal (ne1, ne2) -> doc_op (string "<>") (doc_nexp ctx ne1) (doc_nexp ctx ne2) - | _ -> l10 nc_full - and l10 (NC_aux (nc,_) as nc_full) = - match nc with - | NC_set (kid, is) -> - separate space [string "In"; doc_var ctx kid; - brackets (separate (string "; ") - (List.map (fun i -> string (Nat_big_num.to_string i)) is))] - | NC_app (f,args) -> separate space (doc_nc_fn_prop f::List.map (doc_typ_arg ~prop_vars ctx env) args) - | _ -> l0 nc_full - and l0 (NC_aux (nc,_) as nc_full) = - match nc with - | NC_true -> string "True" - | NC_false -> string "False" - | NC_set _ - | NC_app _ - | NC_var _ - | NC_or _ - | NC_and _ - | NC_equal _ - | NC_bounded_ge _ - | NC_bounded_gt _ - | NC_bounded_le _ - | NC_bounded_lt _ - | NC_not_equal _ -> parens (l85 nc_full) - in if top then newnc l85 nc else newnc l0 nc + let prop = prop in + match exists with + | [] -> string "ArithFact" ^^ space ^^ parens prop + | _ -> string "ArithFactP" ^^ space ^^ + parens (separate space ([string "exists"]@(List.map (doc_var ctxt) exists)@[comma; prop; equals; string "true"])) (* Follows Coq precedence levels *) -let rec doc_nc_exp ctx env nc = +and doc_nc_exp ctx env nc = let locals = Env.get_locals env |> Bindings.bindings in let nc = Env.expand_constraint_synonyms env nc in let nc_id_map = @@ -871,6 +799,9 @@ let rec doc_nc_exp ctx env nc = (flatten_nc nc, v)::m | _ -> m) [] locals in + (* Look for variables in the environment which exactly express the nc, and use + them instead. As well as often being shorter, this avoids unbound type + variables added by Sail's type checker. *) let rec newnc f nc = let ncs = flatten_nc nc in let candidates = @@ -903,10 +834,16 @@ let rec doc_nc_exp ctx env nc = separate space [string "member_Z_list"; doc_var ctx kid; brackets (separate (string "; ") (List.map (fun i -> string (Nat_big_num.to_string i)) is))] + | NC_app (f,args) -> separate space (doc_nc_fn f::List.map doc_typ_arg_exp args) + | _ -> l0 nc_full + and l0 (NC_aux (nc,_) as nc_full) = + match nc with | NC_true -> string "true" | NC_false -> string "false" - | NC_app (f,args) -> separate space (doc_nc_fn f::List.map (doc_typ_arg_exp ctx env) args) | NC_var kid -> doc_nexp ctx (nvar kid) + | NC_not_equal _ + | NC_set _ + | NC_app _ | NC_equal _ | NC_bounded_ge _ | NC_bounded_gt _ @@ -914,13 +851,13 @@ let rec doc_nc_exp ctx env nc = | NC_bounded_lt _ | NC_or _ | NC_and _ -> parens (l70 nc_full) - in newnc l70 nc -and doc_typ_arg_exp ctx env (A_aux (arg,l)) = - match arg with - | A_nexp nexp -> doc_nexp ctx nexp - | A_bool nc -> doc_nc_exp ctx env nc - | A_order _ | A_typ _ -> + and doc_typ_arg_exp (A_aux (arg,l)) = + match arg with + | A_nexp nexp -> doc_nexp ctx nexp + | A_bool nc -> newnc l0 nc + | A_order _ | A_typ _ -> raise (Reporting.err_unreachable l __POS__ "Tried to pass Type or Order kind to SMT function") + in newnc l70 nc (* Check for variables in types that would be pretty-printed and are not bound in the val spec of the function. *) @@ -971,8 +908,9 @@ let doc_lit (L_aux(lit,l)) = let s = Big_int.to_string i in let ipp = utf8string s in if Big_int.less i Big_int.zero then parens ipp else ipp - | L_hex n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0x" ^ n) ^ ")" (*shouldn't happen*)*) - | L_bin n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0b" ^ n) ^ ")" (*shouldn't happen*)*) + (* Not a typo, the bbv hex notation uses the letter O *) + | L_hex n -> utf8string ("Ox\"" ^ n ^ "\"") + | L_bin n -> utf8string ("'b\"" ^ n ^ "\"") | L_undef -> utf8string "(Fail \"undefined value of unsupported type\")" | L_string s -> utf8string ("\"" ^ (coq_escape_string s) ^ "\"") @@ -1024,7 +962,7 @@ let doc_quant_item_constr ?(prop_vars=false) ctx env delimit (QI_aux (qi,_)) = match qi with | QI_id _ -> None | QI_constant _ -> None - | QI_constraint nc -> Some (bquote ^^ braces (doc_arithfact ~prop_vars ctx env nc)) + | QI_constraint nc -> Some (bquote ^^ braces (doc_arithfact ctx env nc)) (* At the moment these are all anonymous - when used we rely on Coq to fill them in. *) @@ -1187,8 +1125,9 @@ let rec doc_pat ctxt apat_needed exists_as_pairs (P_aux (p,(l,annot)) as pat, ty | _::_::_, [Typ_aux (Typ_tup typs,_)] -> typs | _,_ -> arg_typs in - let ppp = doc_unop (doc_id_ctor id) - (parens (separate_map comma (doc_pat ctxt true true) (List.combine pats arg_typs))) in + let pats_pp = separate_map comma (doc_pat ctxt true true) (List.combine pats arg_typs) in + let pats_pp = match pats with [_] -> pats_pp | _ -> parens pats_pp in + let ppp = doc_unop (doc_id_ctor id) pats_pp in if apat_needed then parens ppp else ppp end | P_app(id, []) -> doc_id_ctor id @@ -1877,7 +1816,11 @@ let doc_exp, doc_let = in let epp = if is_ctor - then group (hang 2 (call ^^ break 1 ^^ parens (flow (comma ^^ break 1) (List.map2 (doc_arg false) args arg_typs)))) + then + let argspp = match args, arg_typs with + | [arg], [arg_typ] -> doc_arg true arg arg_typ + | _, _ -> parens (flow (comma ^^ break 1) (List.map2 (doc_arg false) args arg_typs)) + in group (hang 2 (call ^^ break 1 ^^ argspp)) else let argspp = List.map2 (doc_arg true) args arg_typs in let all = @@ -2333,7 +2276,8 @@ let doc_exp, doc_let = "unsupported internal expression encountered while pretty-printing") and if_exp ctxt (elseif : bool) c t e = let if_pp = string (if elseif then "else if" else "if") in - let c_pp = top_exp ctxt true c in + let use_sumbool = condition_produces_constraint ctxt c in + let c_pp = top_exp ctxt use_sumbool c in let t_pp = top_exp ctxt false t in let else_pp = match e with | E_aux (E_if (c', t', e'), _) @@ -2347,8 +2291,8 @@ let doc_exp, doc_let = in (prefix 2 1 (soft_surround 2 1 if_pp - ((if condition_produces_constraint ctxt c then string "sumbool_of_bool" ^^ space else empty) - ^^ parens c_pp) (string "then")) + (if use_sumbool then string "sumbool_of_bool" ^/^ c_pp else c_pp) + (string "then")) t_pp) ^^ break 1 ^^ else_pp @@ -2366,7 +2310,9 @@ let doc_exp, doc_let = prefix 2 1 (separate space [string "let"; doc_id id; colon; doc_typ ctxt (env_of e) typ; coloneq]) (top_exp ctxt false e) - | LB_val(P_aux (P_typ (typ,P_aux (P_id id,_)),_),e) + | (LB_val(P_aux (P_typ (_,P_aux (P_id id,_)),_),e) + | LB_val(P_aux (P_var (P_aux (P_id id,_),_),_), e) + | LB_val(P_aux (P_typ (_,P_aux (P_var (P_aux (P_id id,_),_),_)),_), e)) when (* is auto decomposed *) not (is_enum (env_of e) id) -> prefix 2 1 @@ -2515,9 +2461,9 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = let idpp = doc_id_type id in doc_op coloneq (separate space [string "Definition"; idpp; - doc_typquant_items ~prop_vars:true empty_ctxt Env.empty parens typq; - colon; string "Prop"]) - (doc_nc_prop ~prop_vars:true empty_ctxt Env.empty nc) ^^ dot ^^ hardline ^^ + doc_typquant_items empty_ctxt Env.empty parens typq; + colon; string "bool"]) + (doc_nc_exp empty_ctxt Env.empty nc) ^^ dot ^^ hardline ^^ separate space [string "Hint Unfold"; idpp; colon; string "sail."] ^^ twice hardline | TD_abbrev _ -> empty (* TODO? *) @@ -2538,24 +2484,31 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = mk_typ (Typ_app (id, targs)) | TypQ_aux (TypQ_no_forall, _) -> mk_id_typ id in let fs_doc = group (separate_map (break 1) f_pp fs) in + let type_id_pp = doc_id_type id in + let match_parameters = + let (kopts,_) = quant_split typq in + match kopts with + | [] -> empty + | _ -> space ^^ separate_map space (fun _ -> underscore) kopts + in let doc_update_field (_,fid) = let idpp = fname fid in - let otherfield (_,fid') = - if Id.compare fid fid' == 0 then None else - let idpp = fname fid' in - Some (separate space [idpp; string ":="; idpp; string "r"]) + let pp_field alt i (_,fid') = + if Id.compare fid fid' == 0 then string alt else + let id = "f" ^ string_of_int i in + string id in match fs with | [_] -> string "Notation \"{[ r 'with' '" ^^ idpp ^^ string "' := e ]}\" :=" ^//^ string "{| " ^^ idpp ^^ string " := e |} (only parsing)." | _ -> - string "Notation \"{[ r 'with' '" ^^ idpp ^^ string "' := e ]}\" := {|" ^//^ - idpp ^^ string " := e;" ^/^ separate (semi ^^ break 1) (Util.map_filter otherfield fs) ^/^ - string "|}" ^^ dot + string "Notation \"{[ r 'with' '" ^^ idpp ^^ string "' := e ]}\" :=" ^//^ + string "match r with Build_" ^^ type_id_pp ^^ match_parameters ^^ space ^^ separate space (List.mapi (pp_field "_") fs) ^^ string " =>" ^//^ + string "Build_" ^^ type_id_pp ^^ match_parameters ^^ space ^^ separate space (List.mapi (pp_field "e") fs) ^//^ + string "end" ^^ dot in let updates_pp = separate hardline (List.map doc_update_field fs) in - let id_pp = doc_id_type id in let numfields = List.length fs in let intros_pp s = string " intros [" ^^ @@ -2564,8 +2517,8 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = in let eq_pp = if IdSet.mem id generic_eq_types then - string "Instance Decidable_eq_" ^^ id_pp ^^ space ^^ colon ^/^ - string "forall (x y : " ^^ id_pp ^^ string "), Decidable (x = y)." ^^ + string "Instance Decidable_eq_" ^^ type_id_pp ^^ space ^^ colon ^/^ + string "forall (x y : " ^^ type_id_pp ^^ string "), Decidable (x = y)." ^^ hardline ^^ intros_pp "x" ^^ intros_pp "y" ^^ separate hardline (list_init numfields (fun n -> @@ -2576,9 +2529,9 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = string "Defined." ^^ twice hardline else empty in - let reset_implicits_pp = doc_reset_implicits id_pp typq in + let reset_implicits_pp = doc_reset_implicits type_id_pp typq in doc_op coloneq - (separate space [string "Record"; id_pp; doc_typquant_items empty_ctxt Env.empty braces typq]) + (separate space [string "Record"; type_id_pp; doc_typquant_items empty_ctxt Env.empty braces typq]) ((*doc_typquant typq*) (braces (space ^^ align fs_doc ^^ space))) ^^ dot ^^ hardline ^^ reset_implicits_pp ^^ hardline ^^ eq_pp ^^ updates_pp ^^ twice hardline @@ -2743,7 +2696,7 @@ let rec atom_constraint ctxt (pat, typ) = None | _ -> Some (bquote ^^ braces (string "ArithFact" ^^ space ^^ - parens (doc_op equals (doc_id id) (doc_nexp ctxt nexp))))) + parens (doc_op (string "=?") (doc_id id) (doc_nexp ctxt nexp))))) | P_aux (P_typ (_,p),_), _ -> atom_constraint ctxt (p, typ) | _ -> None @@ -3205,7 +3158,7 @@ let doc_axiom_typschm typ_env l (tqs,typ) = let v = fresh_var () in parens (v ^^ string " : Z") ^/^ bquote ^^ braces (string "ArithFact " ^^ - parens (v ^^ string " = " ^^ string (Big_int.to_string n))) + parens (v ^^ string " =? " ^^ string (Big_int.to_string n))) | _ -> match Type_check.destruct_atom_bool typ_env typ with | Some (NC_aux (NC_var kid,_)) when KidSet.mem kid args -> @@ -3377,6 +3330,7 @@ try hardline; string "Open Scope string."; hardline; string "Open Scope bool."; hardline; + string "Open Scope Z."; hardline; hardline; hardline; separate empty (List.map doc_def defs); diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index d399ec29..993934f5 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -415,22 +415,24 @@ let doc_tannot_lem ctxt env eff typ = let min_int32 = Big_int.of_int64 (Int64.of_int32 Int32.min_int) let max_int32 = Big_int.of_int64 (Int64.of_int32 Int32.max_int) -let doc_lit_lem (L_aux(lit,l)) = +let rec doc_lit_lem (L_aux(lit,l)) = match lit with | L_unit -> utf8string "()" | L_zero -> utf8string "B0" | L_one -> utf8string "B1" | L_false -> utf8string "false" | L_true -> utf8string "true" - | L_num i when Big_int.less_equal min_int32 i && Big_int.less_equal i max_int32 -> + | L_num i -> let ipp = Big_int.to_string i in utf8string ( if Big_int.less i Big_int.zero then "((0"^ipp^"):ii)" else "("^ipp^":ii)") - | L_num i -> - utf8string (Printf.sprintf "(integerOfString \"%s\")" (Big_int.to_string i)) - | L_hex n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0x" ^ n) ^ ")" (*shouldn't happen*)*) - | L_bin n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0b" ^ n) ^ ")" (*shouldn't happen*)*) + | L_hex n when !opt_mwords -> utf8string ("0x" ^ n) + | L_bin n when !opt_mwords -> utf8string ("0b" ^ n) + | L_hex _ | L_bin _ -> + vector_string_to_bit_list (L_aux(lit,l)) + |> flow_map (semi ^^ break 0) doc_lit_lem + |> group |> align |> brackets | L_undef -> utf8string "(return (failwith \"undefined value of unsupported type\"))" | L_string s -> utf8string ("\"" ^ (String.escaped s) ^ "\"") @@ -872,8 +874,14 @@ let doc_exp_lem, doc_let_lem = else if Env.is_register id env && is_regtyp (typ_of full_exp) env then doc_id_lem (append_id id "_ref") else if is_ctor env id then doc_id_lem_ctor id else doc_id_lem id - | E_lit lit -> doc_lit_lem lit - | E_cast(typ,e) -> expV aexp_needed e + | E_lit lit -> + let env = env_of full_exp in + let typ = Env.expand_synonyms env (typ_of full_exp) in + let eff = effect_of full_exp in + if typ_needs_printed typ + then parens (doc_lit_lem lit ^^ doc_tannot_lem ctxt env (effectful eff) typ) + else doc_lit_lem lit + | E_cast (typ,e) -> expV aexp_needed e (*parens (expN e ^^ doc_tannot_lem ctxt (env_of full_exp) (effectful (effect_of full_exp)) typ)*) | E_tuple exps -> parens (align (group (separate_map (comma ^^ break 1) expN exps))) | E_record fexps -> diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index b3675263..7e98f4e3 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -170,6 +170,8 @@ let rec doc_nc nc = in atomic_nc (constraint_simp nc) +and doc_effects effs = braces (separate (comma ^^ space) (List.map (fun be -> string (string_of_base_effect be)) effs)) + and doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = match typ_aux with | Typ_id id -> doc_id id @@ -194,13 +196,14 @@ and doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = | Typ_fn (typs, typ, Effect_aux (Effect_set [], _)) -> separate space [doc_arg_typs typs; string "->"; doc_typ typ] | Typ_fn (typs, typ, Effect_aux (Effect_set effs, _)) -> - let ocaml_eff = braces (separate (comma ^^ space) (List.map (fun be -> string (string_of_base_effect be)) effs)) in if simple then separate space [doc_arg_typs typs; string "->"; doc_typ ~simple:simple typ] else - separate space [doc_arg_typs typs; string "->"; doc_typ typ; string "effect"; ocaml_eff] - | Typ_bidir (typ1, typ2) -> + separate space [doc_arg_typs typs; string "->"; doc_typ typ; string "effect"; doc_effects effs] + | Typ_bidir (typ1, typ2, Effect_aux (Effect_set [], _)) -> separate space [doc_typ typ1; string "<->"; doc_typ typ2] + | Typ_bidir (typ1, typ2, Effect_aux (Effect_set effs, _)) -> + separate space [doc_typ typ1; string "<->"; doc_typ typ2; string "effect"; doc_effects effs] | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") and doc_typ_arg (A_aux (ta_aux, _)) = match ta_aux with @@ -502,7 +505,11 @@ and doc_atomic_exp (E_aux (e_aux, _) as exp) = brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; equals; doc_exp exp3]) | E_vector_update_subrange (exp1, exp2, exp3, exp4) -> brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; string ".."; doc_atomic_exp exp3; equals; doc_exp exp4]) - | E_internal_value v -> string (Value.string_of_value v (* |> Util.green |> Util.clear *)) + | E_internal_value v -> + if !Interactive.opt_interactive then + string (Value.string_of_value v |> Util.green |> Util.clear) + else + string (Value.string_of_value v) | _ -> parens (doc_exp exp) and doc_fexps fexps = separate_map (comma ^^ space) doc_fexp fexps @@ -623,6 +630,12 @@ let doc_field (typ, id) = let doc_union (Tu_aux (Tu_ty_id (typ, id), l)) = separate space [doc_id id; colon; doc_typ typ] +let rec doc_index_range (BF_aux (ir, _)) = + match ir with + | BF_single i -> doc_nexp i + | BF_range (i, j) -> doc_nexp i ^^ string ".." ^^ doc_nexp j + | BF_concat (i, j) -> doc_index_range i ^^ comma ^^ space ^^ doc_index_range j + let doc_typ_arg_kind sep (A_aux (aux, _)) = match aux with | A_nexp _ -> space ^^ string sep ^^ space ^^string "Int" @@ -651,7 +664,10 @@ let doc_typdef (TD_aux(td,_)) = match td with | TD_variant (id, TypQ_aux (TypQ_tq qs, _), unions, _) -> separate space [string "union"; doc_id id; doc_param_quants qs; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace] - | TD_bitfield _ -> string "BITFIELD" (* should be rewritten *) + | TD_bitfield (id, typ, fields) -> + let doc_field (id, range) = separate space [doc_id id; colon; doc_index_range range] in + doc_op equals (separate space [string "bitfield"; doc_id id; colon; doc_typ typ]) + (surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace) let doc_spec ?comment:(comment=false) (VS_aux (v, annot)) = let doc_extern ext = diff --git a/src/process_file.ml b/src/process_file.ml index eeb7c0d7..d2a86595 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -56,6 +56,8 @@ let opt_isa_output_dir = ref None let opt_coq_output_dir = ref None let opt_alt_modules_coq = ref ([]:string list) let opt_alt_modules2_coq = ref ([]:string list) +let opt_memo_z3 = ref false +let opt_file_out : string option ref = ref None type out_type = | Lem_out of string list @@ -71,7 +73,6 @@ let get_lexbuf f = lexbuf, in_chan let parse_file ?loc:(l=Parse_ast.Unknown) (f : string) : Parse_ast.defs = - let open Reporting in try let lexbuf, in_chan = get_lexbuf f in begin @@ -82,12 +83,12 @@ let parse_file ?loc:(l=Parse_ast.Unknown) (f : string) : Parse_ast.defs = | Parser.Error -> let pos = Lexing.lexeme_start_p lexbuf in let tok = Lexing.lexeme lexbuf in - raise (Fatal_error (Err_syntax (pos, "current token: " ^ tok))) - | Lexer.LexError(s,p) -> - raise (Fatal_error (Err_lex (p, s))) + raise (Reporting.err_syntax pos ("current token: " ^ tok)) + | Lexer.LexError (s, p) -> + raise (Reporting.err_lex p s) end with - | Sys_error err -> raise (err_general l err) + | Sys_error err -> raise (Reporting.err_general l err) (* Simple preprocessor features for conditional file loading *) module StringSet = Set.Make(String) @@ -239,12 +240,6 @@ let rec preprocess opts = function let preprocess_ast opts (Parse_ast.Defs defs) = Parse_ast.Defs (preprocess opts defs) -let load_file_no_check opts order f = Initial_check.process_ast (preprocess_ast opts (parse_file f)) - -let load_file opts order env f = - let ast = Initial_check.process_ast (preprocess_ast opts (parse_file f)) in - Type_error.check env ast - let opt_just_check = ref false let opt_ddump_tc_ast = ref false let opt_ddump_rewrite_ast = ref None @@ -257,6 +252,33 @@ let check_ast (env : Type_check.Env.t) (defs : unit Ast.defs) : Type_check.tanno let () = if !opt_just_check then exit 0 else () in (ast, env) +let load_files ?check:(check=false) options type_envs files = + if !opt_memo_z3 then Constraint.load_digests () else (); + + let t = Profile.start () in + let parsed = List.map (fun f -> (f, parse_file f)) files in + let ast = + List.fold_right (fun (_, Parse_ast.Defs ast_nodes) (Parse_ast.Defs later_nodes) + -> Parse_ast.Defs (ast_nodes@later_nodes)) parsed (Parse_ast.Defs []) in + let ast = preprocess_ast options ast in + let ast = Initial_check.process_ast ~generate:(not check) ast in + (* The separate loop measures declarations would be awkward to type check, so + move them into the definitions beforehand. *) + let ast = Rewrites.move_loop_measures ast in + Profile.finish "parsing" t; + + let t = Profile.start () in + let (ast, type_envs) = check_ast type_envs ast in + Profile.finish "type checking" t; + + if !opt_memo_z3 then Constraint.save_digests () else (); + + let out_name = match !opt_file_out with + | None when parsed = [] -> "out.sail" + | None -> fst (List.hd parsed) + | Some f -> f ^ ".sail" in + + (out_name, ast, type_envs) let open_output_with_check opt_dir file_name = let (temp_file_name, o) = Filename.open_temp_file "ll_temp" "" in @@ -349,12 +371,12 @@ let output_coq opt_dir filename alt_modules alt_modules2 libs defs = (match alt_modules with | [] -> base_imports_default | _ -> Str.split (Str.regexp "[ \t]+") (String.concat " " alt_modules) - ) in + ) in let alt_modules2_imports = (match alt_modules2 with | [] -> [] | _ -> Str.split (Str.regexp "[ \t]+") (String.concat " " alt_modules2) - ) in + ) in let ((ot,_,_,_) as ext_ot) = open_output_with_check_unformatted opt_dir (filename ^ "_types" ^ ".v") in let ((o,_,_,_) as ext_o) = @@ -414,3 +436,10 @@ let rewrite_ast_initial env = rewrite env [("initial", fun env defs -> Rewriter. let rewrite_ast_target tgt env = rewrite env (Rewrites.rewrite_defs_target tgt) let rewrite_ast_check env = rewrite env Rewrites.rewrite_defs_check + +let descatter type_envs ast = + let ast = Scattered.descatter ast in + let ast, type_envs = rewrite_ast_initial type_envs ast in + (* Recheck after descattering so that the internal type environments + always have complete variant types *) + Type_error.check Type_check.initial_env ast diff --git a/src/process_file.mli b/src/process_file.mli index fa0aeb31..d1fa2cb8 100644 --- a/src/process_file.mli +++ b/src/process_file.mli @@ -61,9 +61,8 @@ val rewrite_ast_initial : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type val rewrite_ast_target : string -> Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t val rewrite_ast_check : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t -val load_file_no_check : (Arg.key * Arg.spec * Arg.doc) list -> Ast.order -> string -> unit Ast.defs -val load_file : (Arg.key * Arg.spec * Arg.doc) list -> Ast.order -> Type_check.Env.t -> string -> Type_check.tannot Ast.defs * Type_check.Env.t - +val opt_file_out : string option ref +val opt_memo_z3 : bool ref val opt_just_check : bool ref val opt_ddump_tc_ast : bool ref val opt_ddump_rewrite_ast : ((string * int) option) ref @@ -90,3 +89,7 @@ val output : files existed before. If it is set to [false] and an output file already exists, the output file is only updated, if its content really changes. *) val always_replace_files : bool ref + +val load_files : ?check:bool -> (Arg.key * Arg.spec * Arg.doc) list -> Type_check.Env.t -> string list -> (string * Type_check.tannot Ast.defs * Type_check.Env.t) + +val descatter : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t diff --git a/src/property.ml b/src/property.ml index 955e755d..83594f4f 100644 --- a/src/property.ml +++ b/src/property.ml @@ -132,7 +132,7 @@ type query = | Q_or of query list let default_query = - Q_or [Q_and [Q_all Assertion; Q_all Return; Q_not (Q_exist Match)]; Q_exist Overflow; Q_not (Q_all Assumption)] + Q_or [Q_and [Q_not (Q_exist Assertion); Q_all Return; Q_not (Q_exist Match)]; Q_exist Overflow; Q_not (Q_all Assumption)] module Event = struct type t = event diff --git a/src/reporting.ml b/src/reporting.ml index e89ce396..d5e3003c 100644 --- a/src/reporting.ml +++ b/src/reporting.ml @@ -132,19 +132,19 @@ let print_err l m1 m2 = type error = | Err_general of Parse_ast.l * string - | Err_unreachable of Parse_ast.l * (string * int * int * int) * string + | Err_unreachable of Parse_ast.l * (string * int * int * int) * Printexc.raw_backtrace * string | Err_todo of Parse_ast.l * string | Err_syntax of Lexing.position * string | Err_syntax_loc of Parse_ast.l * string | Err_lex of Lexing.position * string | Err_type of Parse_ast.l * string -let issues = "\n\nPlease report this as an issue on GitHub at https://github.com/rems-project/sail/issues" +let issues = "\nPlease report this as an issue on GitHub at https://github.com/rems-project/sail/issues" let dest_err = function | Err_general (l, m) -> ("Error", Loc l, m) - | Err_unreachable (l, (file, line, _, _), m) -> - (Printf.sprintf "Internal error: Unreachable code (at \"%s\" line %d)" file line, Loc l, m ^ issues) + | Err_unreachable (l, (file, line, _, _), backtrace, m) -> + (Printf.sprintf "Internal error: Unreachable code (at \"%s\" line %d)" file line, Loc l, m ^ "\n\n" ^ Printexc.raw_backtrace_to_string backtrace ^ issues) | Err_todo (l, m) -> ("Todo", Loc l, m) | Err_syntax (p, m) -> ("Syntax error", Pos p, m) | Err_syntax_loc (l, m) -> ("Syntax error", Loc l, m) @@ -155,10 +155,14 @@ exception Fatal_error of error (* Abbreviations for the very common cases *) let err_todo l m = Fatal_error (Err_todo (l, m)) -let err_unreachable l ocaml_pos m = Fatal_error (Err_unreachable (l, ocaml_pos, m)) +let err_unreachable l ocaml_pos m = + let backtrace = Printexc.get_callstack 10 in + Fatal_error (Err_unreachable (l, ocaml_pos, backtrace, m)) let err_general l m = Fatal_error (Err_general (l, m)) -let err_typ l m = Fatal_error (Err_type (l,m)) +let err_typ l m = Fatal_error (Err_type (l, m)) +let err_syntax p m = Fatal_error (Err_syntax (p, m)) let err_syntax_loc l m = Fatal_error (Err_syntax_loc (l, m)) +let err_lex p m = Fatal_error (Err_lex (p, m)) let unreachable l pos msg = raise (err_unreachable l pos msg) diff --git a/src/reporting.mli b/src/reporting.mli index 0bdff5ca..e0744c66 100644 --- a/src/reporting.mli +++ b/src/reporting.mli @@ -74,8 +74,7 @@ val simp_loc : Ast.l -> (Lexing.position * Lexing.position) option val short_loc_to_string : Parse_ast.l -> string (** [print_err fatal print_loc_source l head mes] prints an error / warning message to - std-err. It starts with printing location information stored in [l] - It then prints "head: mes". If [fatal] is set, the program exists with error-code 1 afterwards. + std-err. *) val print_err : Parse_ast.l -> string -> string -> unit @@ -83,13 +82,13 @@ val print_err : Parse_ast.l -> string -> string -> unit (** Errors stop execution and print a message; they typically have a location and message. *) -type error = +type error = private (** General errors, used for multi purpose. If you are unsure, use this one. *) | Err_general of Parse_ast.l * string (** Unreachable errors should never be thrown. It means that some code was excuted that the programmer thought of as unreachable *) - | Err_unreachable of Parse_ast.l * (string * int * int * int) * string + | Err_unreachable of Parse_ast.l * (string * int * int * int) * Printexc.raw_backtrace * string (** [Err_todo] indicates that some feature is unimplemented; it should be built using [err_todo]. *) | Err_todo of Parse_ast.l * string @@ -101,20 +100,13 @@ type error = exception Fatal_error of error -(** [err_todo l m] is an abreviatiation for [Fatal_error (Err_todo (l, m))] *) val err_todo : Parse_ast.l -> string -> exn - -(** [err_general l m] is an abreviatiation for [Fatal_error (Err_general (b, l, m))] *) val err_general : Parse_ast.l -> string -> exn - -(** [err_unreachable l __POS__ m] is an abreviatiation for [Fatal_error (Err_unreachable (l, __POS__, m))] *) val err_unreachable : Parse_ast.l -> (string * int * int * int) -> string -> exn - -(** [err_typ l m] is an abreviatiation for [Fatal_error (Err_type (l, m))] *) val err_typ : Parse_ast.l -> string -> exn - -(** [err_syntax_loc] is an abbreviation for [Fatal_error (Err_syntax_loc (l, m))] *) +val err_syntax : Lexing.position -> string -> exn val err_syntax_loc : Parse_ast.l -> string -> exn +val err_lex : Lexing.position -> string -> exn val unreachable : Parse_ast.l -> (string * int * int * int) -> string -> 'a diff --git a/src/rewrites.ml b/src/rewrites.ml index ad0ed836..863f8115 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -145,40 +145,6 @@ let lexp_is_effectful (LEXP_aux (_, (_, annot))) = match destruct_tannot annot w | Some (_, _, eff) -> effectful_effs eff | _ -> false -let explode s = - let rec exp i l = if i < 0 then l else exp (i - 1) (s.[i] :: l) in - exp (String.length s - 1) [] - -let vector_string_to_bit_list l lit = - - let hexchar_to_binlist = function - | '0' -> ['0';'0';'0';'0'] - | '1' -> ['0';'0';'0';'1'] - | '2' -> ['0';'0';'1';'0'] - | '3' -> ['0';'0';'1';'1'] - | '4' -> ['0';'1';'0';'0'] - | '5' -> ['0';'1';'0';'1'] - | '6' -> ['0';'1';'1';'0'] - | '7' -> ['0';'1';'1';'1'] - | '8' -> ['1';'0';'0';'0'] - | '9' -> ['1';'0';'0';'1'] - | 'A' -> ['1';'0';'1';'0'] - | 'B' -> ['1';'0';'1';'1'] - | 'C' -> ['1';'1';'0';'0'] - | 'D' -> ['1';'1';'0';'1'] - | 'E' -> ['1';'1';'1';'0'] - | 'F' -> ['1';'1';'1';'1'] - | _ -> raise (Reporting.err_unreachable l __POS__ "hexchar_to_binlist given unrecognized character") in - - let s_bin = match lit with - | L_hex s_hex -> List.flatten (List.map hexchar_to_binlist (explode (String.uppercase_ascii s_hex))) - | L_bin s_bin -> explode s_bin - | _ -> raise (Reporting.err_unreachable l __POS__ "s_bin given non vector literal") in - - List.map (function '0' -> L_aux (L_zero, gen_loc l) - | '1' -> L_aux (L_one, gen_loc l) - | _ -> raise (Reporting.err_unreachable (gen_loc l) __POS__ "binary had non-zero or one")) s_bin - let find_used_vars exp = (* Overapproximates the set of used identifiers, but for the use cases below this is acceptable. *) @@ -291,39 +257,26 @@ let rewrite_defs_nexp_ids, rewrite_typ_nexp_ids = DEF_spec (VS_aux (VS_val_spec (typschm, id, exts, b), a)) | DEF_type (TD_aux (TD_abbrev (id, typq, typ_arg), a)) -> DEF_type (TD_aux (TD_abbrev (id, typq, rewrite_typ_arg env typ_arg), a)) + | DEF_type (TD_aux (TD_record (id, typq, fields, b), a)) -> + let fields' = List.map (fun (t, id) -> (rewrite_typ env t, id)) fields in + DEF_type (TD_aux (TD_record (id, typq, fields', b), a)) + | DEF_type (TD_aux (TD_variant (id, typq, constrs, b), a)) -> + let constrs' = + List.map (fun (Tu_aux (Tu_ty_id (t, id), l)) -> + Tu_aux (Tu_ty_id (rewrite_typ env t, id), l)) + constrs + in + DEF_type (TD_aux (TD_variant (id, typq, constrs', b), a)) | d -> Rewriter.rewrite_def rewriters d in (fun env defs -> rewrite_defs_base { rewriters_base with - rewrite_exp = (fun _ -> map_exp_annot rewrite_annot); rewrite_def = rewrite_def env + rewrite_exp = (fun _ -> map_exp_annot rewrite_annot); + rewrite_def = rewrite_def env } defs), rewrite_typ -let rewrite_bitvector_exps env defs = - let e_aux = function - | (E_vector es, ((l, tannot) as a)) when not (is_empty_tannot tannot) -> - let env = env_of_annot (l, tannot) in - let typ = typ_of_annot (l, tannot) in - let eff = effect_of_annot tannot in - if is_bitvector_typ typ then - try - let len = mk_lit_exp (L_num (Big_int.of_int (List.length es))) in - let es = mk_exp (E_list (List.map strip_exp es)) in - let exp = mk_exp (E_app (mk_id "bitvector_of_bitlist", [len; es])) in - check_exp env exp typ - with - | _ -> E_aux (E_vector es, a) - else - E_aux (E_vector es, a) - | (e_aux, a) -> E_aux (e_aux, a) - in - let rewrite_exp _ = fold_exp { id_exp_alg with e_aux = e_aux } in - if IdSet.mem (mk_id "bitvector_of_bitlist") (val_spec_ids defs) then - rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp } defs - else defs - - let rewrite_defs_remove_assert defs = let e_assert ((E_aux (eaux, (l, _)) as exp), str) = match eaux with | E_constraint _ -> @@ -1263,7 +1216,7 @@ let rewrite_defs_vector_string_pats_to_bit_list env = match pat with | P_lit (L_aux (lit, l) as l_aux) -> begin match lit with - | L_hex _ | L_bin _ -> P_aux (P_vector (List.map (fun p -> P_aux (P_lit p, (l, mk_tannot env bit_typ no_effect))) (vector_string_to_bit_list l lit)), annot) + | L_hex _ | L_bin _ -> P_aux (P_vector (List.map (fun p -> P_aux (P_lit p, (l, mk_tannot env bit_typ no_effect))) (vector_string_to_bit_list l_aux)), annot) | lit -> P_aux (P_lit l_aux, annot) end | pat -> (P_aux (pat, annot)) @@ -1273,7 +1226,7 @@ let rewrite_defs_vector_string_pats_to_bit_list env = match exp with | E_lit (L_aux (lit, l) as l_aux) -> begin match lit with - | L_hex _ | L_bin _ -> E_aux (E_vector (List.map (fun e -> E_aux (E_lit e, (l, mk_tannot env bit_typ no_effect))) (vector_string_to_bit_list l lit)), annot) + | L_hex _ | L_bin _ -> E_aux (E_vector (List.map (fun e -> E_aux (E_lit e, (l, mk_tannot env bit_typ no_effect))) (vector_string_to_bit_list l_aux)), annot) | lit -> E_aux (E_lit l_aux, annot) end | exp -> (E_aux (exp, annot)) @@ -1287,6 +1240,39 @@ let rewrite_defs_vector_string_pats_to_bit_list env = in rewrite_defs_base { rewriters_base with rewrite_pat = rewrite_pat; rewrite_exp = rewrite_exp } +let rewrite_bit_lists_to_lits env = + (* TODO Make all rewriting passes support bitvector literals instead of + converting back and forth *) + let open Sail2_values in + let bit_of_lit = function + | L_aux (L_zero, _) -> Some B0 + | L_aux (L_one, _) -> Some B1 + | _ -> None + in + let bit_of_exp = function E_aux (E_lit lit, _) -> bit_of_lit lit | _ -> None in + let string_of_chars cs = String.concat "" (List.map (String.make 1) cs) in + let lit_of_bits bits = match hexstring_of_bits bits with + | Some h -> L_hex (string_of_chars h) + | None -> L_bin (string_of_chars (List.map bitU_char bits)) + in + let e_aux (e, (l, annot)) = + let rewrap e = E_aux (e, (l, annot)) in + try + let env = env_of_annot (l, annot) in + let typ = typ_of_annot (l, annot) in + match e with + | E_vector es when is_bitvector_typ typ -> + (match just_list (List.map bit_of_exp es) with + | Some bits -> + check_exp env (mk_exp (E_cast (typ, mk_lit_exp (lit_of_bits bits)))) typ + | None -> rewrap e) + | E_cast (typ', E_aux (E_cast (_, e'), _)) -> rewrap (E_cast (typ', e')) + | _ -> rewrap e + with _ -> rewrap e + in + let rewrite_exp rw = fold_exp { id_exp_alg with e_aux = e_aux; } in + rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp } + (* Remove pattern guards by rewriting them to if-expressions within the pattern expression. *) let rewrite_exp_guarded_pats rewriters (E_aux (exp,(l,annot)) as full_exp) = @@ -2030,7 +2016,7 @@ let rewrite_simple_types env (Defs defs) = let rec simple_lit (L_aux (lit_aux, l) as lit) = match lit_aux with | L_bin _ | L_hex _ -> - E_list (List.map (fun b -> E_aux (E_lit b, simple_annot l bit_typ)) (vector_string_to_bit_list l lit_aux)) + E_list (List.map (fun b -> E_aux (E_lit b, simple_annot l bit_typ)) (vector_string_to_bit_list lit)) | _ -> E_lit lit in let simple_def = function @@ -3147,7 +3133,7 @@ let rewrite_defs_mapping_patterns env = let x = Env.get_val_spec mapping_id env in let typ1, typ2 = match x with - | (_, Typ_aux(Typ_bidir(typ1, typ2), _)) -> typ1, typ2 + | (_, Typ_aux(Typ_bidir(typ1, typ2, _), _)) -> typ1, typ2 | (_, typ) -> raise (Reporting.err_unreachable (fst p_annot) __POS__ ("Must be bi-directional mapping: " ^ string_of_typ typ)) in @@ -3950,6 +3936,54 @@ let rewrite_defs_realise_mappings _ (Defs defs) = [realise_single_mpexp (append_placeholder mpexp) (mk_exp (E_app ((mk_id "Some"), [mk_exp (E_tuple [exp; exp_of_mpat strlen])])))] end in + let realise_val_spec = function + | (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, Typ_aux (Typ_bidir (typ1, typ2, eff), l)), _), id, _, _), ((_, (tannot:tannot)) as annot))) -> + let forwards_id = mk_id (string_of_id id ^ "_forwards") in + let forwards_matches_id = mk_id (string_of_id id ^ "_forwards_matches") in + let backwards_id = mk_id (string_of_id id ^ "_backwards") in + let backwards_matches_id = mk_id (string_of_id id ^ "_backwards_matches") in + + let env = env_of_annot annot in + let forwards_typ = Typ_aux (Typ_fn ([typ1], typ2, eff), l) in + let forwards_matches_typ = Typ_aux (Typ_fn ([typ1], bool_typ, eff), l) in + let backwards_typ = Typ_aux (Typ_fn ([typ2], typ1, eff), l) in + let backwards_matches_typ = Typ_aux (Typ_fn ([typ2], bool_typ, eff), l) in + + let forwards_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_typ, forwards_id, [], false), (Parse_ast.Unknown,())) in + let backwards_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_typ, backwards_id, [], false), (Parse_ast.Unknown,())) in + let forwards_matches_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_matches_typ, forwards_matches_id, [], false), (Parse_ast.Unknown,())) in + let backwards_matches_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_matches_typ, backwards_matches_id, [], false), (Parse_ast.Unknown,())) in + + let forwards_spec, env = Type_check.check_val_spec env forwards_spec in + let backwards_spec, env = Type_check.check_val_spec env backwards_spec in + let forwards_matches_spec, env = Type_check.check_val_spec env forwards_matches_spec in + let backwards_matches_spec, env = Type_check.check_val_spec env backwards_matches_spec in + + let prefix_id = mk_id (string_of_id id ^ "_matches_prefix") in + let string_defs = + begin if subtype_check env typ1 string_typ && subtype_check env string_typ typ1 then + let forwards_prefix_typ = Typ_aux (Typ_fn ([typ1], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ2; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + let forwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_prefix_typ, prefix_id, [], false), (Parse_ast.Unknown,())) in + let forwards_prefix_spec, env = Type_check.check_val_spec env forwards_prefix_spec in + forwards_prefix_spec + else + if subtype_check env typ2 string_typ && subtype_check env string_typ typ2 then + let backwards_prefix_typ = Typ_aux (Typ_fn ([typ2], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ1; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + let backwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_prefix_typ, prefix_id, [], false), (Parse_ast.Unknown,())) in + let backwards_prefix_spec, env = Type_check.check_val_spec env backwards_prefix_spec in + backwards_prefix_spec + else + [] + end + in + + forwards_spec + @ backwards_spec + @ forwards_matches_spec + @ backwards_matches_spec + @ string_defs + | vs -> [DEF_spec vs] + in let realise_mapdef (MD_aux (MD_mapping (id, _, mapcls), ((l, (tannot:tannot)) as annot))) = let forwards_id = mk_id (string_of_id id ^ "_forwards") in let forwards_matches_id = mk_id (string_of_id id ^ "_forwards_matches") in @@ -3964,24 +3998,14 @@ let rewrite_defs_realise_mappings _ (Defs defs) = | _ -> raise (Reporting.err_unreachable l __POS__ "mapping with no clauses?") in let (typq, bidir_typ) = Env.get_val_spec id env in - let (typ1, typ2, l) = match bidir_typ with - | Typ_aux (Typ_bidir (typ1, typ2), l) -> typ1, typ2, l + let (typ1, typ2, eff, l) = match bidir_typ with + | Typ_aux (Typ_bidir (typ1, typ2, eff), l) -> typ1, typ2, eff, l | _ -> raise (Reporting.err_unreachable l __POS__ "non-bidir type of mapping?") in - let forwards_typ = Typ_aux (Typ_fn ([typ1], typ2, no_effect), l) in - let forwards_matches_typ = Typ_aux (Typ_fn ([typ1], bool_typ, no_effect), l) in - let backwards_typ = Typ_aux (Typ_fn ([typ2], typ1, no_effect), l) in - let backwards_matches_typ = Typ_aux (Typ_fn ([typ2], bool_typ, no_effect), l) in - - let forwards_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_typ, forwards_id, [], false), (Parse_ast.Unknown,())) in - let backwards_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_typ, backwards_id, [], false), (Parse_ast.Unknown,())) in - let forwards_matches_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_matches_typ, forwards_matches_id, [], false), (Parse_ast.Unknown,())) in - let backwards_matches_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_matches_typ, backwards_matches_id, [], false), (Parse_ast.Unknown,())) in - - let forwards_spec, env = Type_check.check_val_spec env forwards_spec in - let backwards_spec, env = Type_check.check_val_spec env backwards_spec in - let forwards_matches_spec, env = Type_check.check_val_spec env forwards_matches_spec in - let backwards_matches_spec, env = Type_check.check_val_spec env backwards_matches_spec in + let forwards_typ = Typ_aux (Typ_fn ([typ1], typ2, eff), l) in + let forwards_matches_typ = Typ_aux (Typ_fn ([typ1], bool_typ, eff), l) in + let backwards_typ = Typ_aux (Typ_fn ([typ2], typ1, eff), l) in + let backwards_matches_typ = Typ_aux (Typ_fn ([typ2], bool_typ, eff), l) in let no_tannot = (Typ_annot_opt_aux (Typ_annot_opt_none, Parse_ast.Unknown)) in let forwards_match = mk_exp (E_case (arg_exp, ((List.map (fun mapcl -> strip_mapcl mapcl |> realise_mapcl true forwards_id) mapcls) |> List.flatten))) in @@ -4010,40 +4034,34 @@ let rewrite_defs_realise_mappings _ (Defs defs) = let string_defs = begin if subtype_check env typ1 string_typ && subtype_check env string_typ typ1 then let forwards_prefix_typ = Typ_aux (Typ_fn ([typ1], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ2; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in - let forwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_prefix_typ, prefix_id, [], false), (Parse_ast.Unknown,())) in - let forwards_prefix_spec, env = Type_check.check_val_spec env forwards_prefix_spec in let forwards_prefix_match = mk_exp (E_case (arg_exp, ((List.map (fun mapcl -> strip_mapcl mapcl |> realise_prefix_mapcl true prefix_id) mapcls) |> List.flatten) @ [prefix_wildcard])) in let forwards_prefix_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_none, [mk_funcl prefix_id arg_pat forwards_prefix_match]), (l, ()))) in typ_debug (lazy (Printf.sprintf "forwards prefix matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef forwards_prefix_fun |> Pretty_print_sail.to_string))); let forwards_prefix_fun, _ = Type_check.check_fundef env forwards_prefix_fun in - forwards_prefix_spec @ forwards_prefix_fun + forwards_prefix_fun else if subtype_check env typ2 string_typ && subtype_check env string_typ typ2 then let backwards_prefix_typ = Typ_aux (Typ_fn ([typ2], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ1; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in - let backwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_prefix_typ, prefix_id, [], false), (Parse_ast.Unknown,())) in - let backwards_prefix_spec, env = Type_check.check_val_spec env backwards_prefix_spec in let backwards_prefix_match = mk_exp (E_case (arg_exp, ((List.map (fun mapcl -> strip_mapcl mapcl |> realise_prefix_mapcl false prefix_id) mapcls) |> List.flatten) @ [prefix_wildcard])) in let backwards_prefix_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_none, [mk_funcl prefix_id arg_pat backwards_prefix_match]), (l, ()))) in typ_debug (lazy (Printf.sprintf "backwards prefix matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef backwards_prefix_fun |> Pretty_print_sail.to_string))); let backwards_prefix_fun, _ = Type_check.check_fundef env backwards_prefix_fun in - backwards_prefix_spec @ backwards_prefix_fun + backwards_prefix_fun else [] end in + let has_def id = IdSet.mem id (ids_of_defs (Defs defs)) in - forwards_spec - @ forwards_fun - @ backwards_spec - @ backwards_fun - @ forwards_matches_spec - @ forwards_matches_fun - @ backwards_matches_spec - @ backwards_matches_fun - @ string_defs + (if has_def forwards_id then [] else forwards_fun) + @ (if has_def backwards_id then [] else backwards_fun) + @ (if has_def forwards_matches_id then [] else forwards_matches_fun) + @ (if has_def backwards_matches_id then [] else backwards_matches_fun) + @ (if has_def prefix_id then [] else string_defs) in let rewrite_def def = match def with + | DEF_spec spec -> realise_val_spec spec | DEF_mapdef mdef -> realise_mapdef mdef | d -> [d] in @@ -4653,13 +4671,30 @@ let recheck_defs_without_effects env defs = let () = opt_no_effects := old in result -let remove_mapping_valspecs env (Defs defs) = - let allowed_def def = - match def with - | DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (_, Typ_aux (Typ_bidir _, _)), _), _, _, _), _)) -> false - | _ -> true +(* In realise_mappings we may have duplicated a user-supplied val spec, which + causes problems for some targets. Keep the first one, except use the externs + from the last one, as subsequent redefinitions override earlier ones. *) +let remove_duplicate_valspecs env (Defs defs) = + let last_externs = + List.fold_left + (fun last_externs def -> + match def with + | DEF_spec (VS_aux (VS_val_spec (_, id, externs, _), _)) -> + Bindings.add id externs last_externs + | _ -> last_externs) Bindings.empty defs in - Defs (List.filter allowed_def defs) + let (_, rev_defs) = + List.fold_left + (fun (set, defs) def -> + match def with + | DEF_spec (VS_aux (VS_val_spec (typschm, id, _, cast), l)) -> + if IdSet.mem id set then (set, defs) + else + let externs = Bindings.find id last_externs in + let vs = VS_aux (VS_val_spec (typschm, id, externs, cast), l) in + (IdSet.add id set, (DEF_spec vs)::defs) + | _ -> (set, def::defs)) (IdSet.empty, []) defs + in Defs (List.rev rev_defs) (* Move loop termination measures into loop AST nodes. This is used before @@ -4807,7 +4842,7 @@ let all_rewrites = [ ("recheck_defs_without_effects", Checking_rewriter recheck_defs_without_effects); ("optimize_recheck_defs", Basic_rewriter (fun _ -> Optimize.recheck)); ("realise_mappings", Basic_rewriter rewrite_defs_realise_mappings); - ("remove_mapping_valspecs", Basic_rewriter remove_mapping_valspecs); + ("remove_duplicate_valspecs", Basic_rewriter remove_duplicate_valspecs); ("toplevel_string_append", Basic_rewriter rewrite_defs_toplevel_string_append); ("pat_string_append", Basic_rewriter rewrite_defs_pat_string_append); ("mapping_builtins", Basic_rewriter rewrite_defs_mapping_patterns); @@ -4831,7 +4866,7 @@ let all_rewrites = [ ("remove_bitvector_pats", Basic_rewriter rewrite_defs_remove_bitvector_pats); ("remove_numeral_pats", Basic_rewriter rewrite_defs_remove_numeral_pats); ("guarded_pats", Basic_rewriter rewrite_defs_guarded_pats); - ("bitvector_exps", Basic_rewriter rewrite_bitvector_exps); + ("bit_lists_to_lits", Basic_rewriter rewrite_bit_lists_to_lits); ("exp_lift_assign", Basic_rewriter rewrite_defs_exp_lift_assign); ("early_return", Basic_rewriter rewrite_defs_early_return); ("nexp_ids", Basic_rewriter rewrite_defs_nexp_ids); @@ -4850,14 +4885,14 @@ let all_rewrites = [ ("simple_types", Basic_rewriter rewrite_simple_types); ("overload_cast", Basic_rewriter rewrite_overload_cast); ("top_sort_defs", Basic_rewriter (fun _ -> top_sort_defs)); - ("constant_fold", String_rewriter (fun target -> Basic_rewriter (fun _ -> Constant_fold.rewrite_constant_function_calls target))); + ("constant_fold", String_rewriter (fun target -> Basic_rewriter (fun _ -> Constant_fold.(rewrite_constant_function_calls no_fixed target)))); ("split", String_rewriter (fun str -> Basic_rewriter (rewrite_split_fun_ctor_pats str))); ("properties", Basic_rewriter (fun _ -> Property.rewrite)); ] let rewrites_lem = [ ("realise_mappings", []); - ("remove_mapping_valspecs", []); + ("remove_duplicate_valspecs", []); ("toplevel_string_append", []); ("pat_string_append", []); ("mapping_builtins", []); @@ -4881,7 +4916,6 @@ let rewrites_lem = [ ("remove_numeral_pats", []); ("pattern_literals", [Literal_arg "lem"]); ("guarded_pats", []); - ("bitvector_exps", []); (* ("register_ref_writes", rewrite_register_ref_writes); *) ("nexp_ids", []); ("fix_val_specs", []); @@ -4902,12 +4936,13 @@ let rewrites_lem = [ ("remove_superfluous_letbinds", []); ("remove_superfluous_returns", []); ("merge_function_clauses", []); + ("bit_lists_to_lits", []); ("recheck_defs", []) ] let rewrites_coq = [ ("realise_mappings", []); - ("remove_mapping_valspecs", []); + ("remove_duplicate_valspecs", []); ("toplevel_string_append", []); ("pat_string_append", []); ("mapping_builtins", []); @@ -4923,7 +4958,6 @@ let rewrites_coq = [ ("remove_numeral_pats", []); ("pattern_literals", [Literal_arg "lem"]); ("guarded_pats", []); - ("bitvector_exps", []); (* ("register_ref_writes", rewrite_register_ref_writes); *) ("nexp_ids", []); ("fix_val_specs", []); @@ -4953,6 +4987,7 @@ let rewrites_coq = [ ("internal_lets", []); ("remove_superfluous_letbinds", []); ("remove_superfluous_returns", []); + ("bit_lists_to_lits", []); ("recheck_defs", []) ] diff --git a/src/sail.ml b/src/sail.ml index e792e652..ea642470 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -53,12 +53,10 @@ open Process_file module Big_int = Nat_big_num let lib = ref ([] : string list) -let opt_file_out : string option ref = ref None let opt_interactive_script : string option ref = ref None let opt_print_version = ref false let opt_target = ref None let opt_tofrominterp_output_dir : string option ref = ref None -let opt_memo_z3 = ref false let opt_sanity = ref false let opt_includes_c = ref ([]:string list) let opt_specialize_c = ref false @@ -110,6 +108,9 @@ let options = Arg.align ([ " output an OCaml translated version of the input"); ( "-ocaml-nobuild", Arg.Set Ocaml_backend.opt_ocaml_nobuild, + ""); + ( "-ocaml_nobuild", + Arg.Set Ocaml_backend.opt_ocaml_nobuild, " do not build generated OCaml"); ( "-ocaml_trace", Arg.Tuple [set_target "ocaml"; Arg.Set Initial_check.opt_undefined_gen; Arg.Set Ocaml_backend.opt_trace_ocaml], @@ -119,6 +120,9 @@ let options = Arg.align ([ " set a custom directory to build generated OCaml"); ( "-ocaml-coverage", Arg.Set Ocaml_backend.opt_ocaml_coverage, + ""); + ( "-ocaml_coverage", + Arg.Set Ocaml_backend.opt_ocaml_coverage, " build OCaml with bisect_ppx coverage reporting (requires opam packages bisect_ppx-ocamlbuild and bisect_ppx)."); ( "-ocaml_generators", Arg.String (fun s -> opt_ocaml_generators := s::!opt_ocaml_generators), @@ -145,10 +149,10 @@ let options = Arg.align ([ set_target "ir", " print intermediate representation"); ( "-smt", - set_target "smt", + Arg.Tuple [set_target "smt"; Arg.Clear Jib_compile.opt_track_throw], " print SMT translated version of input"); ( "-smt_auto", - Arg.Tuple [set_target "smt"; Arg.Set Jib_smt.opt_auto], + Arg.Tuple [set_target "smt"; Arg.Clear Jib_compile.opt_track_throw; Arg.Set Jib_smt.opt_auto], " generate SMT and automatically call the solver (implies -smt)"); ( "-smt_ignore_overflow", Arg.Set Jib_smt.opt_ignore_overflow, @@ -301,9 +305,15 @@ let options = Arg.align ([ ( "-undefined_gen", Arg.Set Initial_check.opt_undefined_gen, " generate undefined_type functions for types in the specification"); + ( "-grouped_regstate", + Arg.Set State.opt_type_grouped_regstate, + " group registers with same type together in generated register state record"); ( "-enum_casts", Arg.Set Initial_check.opt_enum_casts, " allow enumerations to be automatically casted to numeric range types"); + ( "-new_bitfields", + Arg.Set Type_check.opt_new_bitfields, + " use new bitfield syntax"); ( "-non_lexical_flow", Arg.Set Nl_flow.opt_nl_flow, " allow non-lexical flow typing"); @@ -397,43 +407,6 @@ let _ = opt_file_arguments := (!opt_file_arguments) @ [s]) usage_msg -let load_files ?check:(check=false) type_envs files = - if !opt_memo_z3 then Constraint.load_digests () else (); - - let t = Profile.start () in - let parsed = List.map (fun f -> (f, parse_file f)) files in - let ast = - List.fold_right (fun (_, Parse_ast.Defs ast_nodes) (Parse_ast.Defs later_nodes) - -> Parse_ast.Defs (ast_nodes@later_nodes)) parsed (Parse_ast.Defs []) in - let ast = Process_file.preprocess_ast options ast in - let ast = Initial_check.process_ast ~generate:(not check) ast in - (* The separate loop measures declarations would be awkward to type check, so - move them into the definitions beforehand. *) - let ast = Rewrites.move_loop_measures ast in - Profile.finish "parsing" t; - - let t = Profile.start () in - let (ast, type_envs) = check_ast type_envs ast in - Profile.finish "type checking" t; - - if !opt_memo_z3 then Constraint.save_digests () else (); - - if check then - ("out.sail", ast, type_envs) - else - let ast = Scattered.descatter ast in - let ast, type_envs = rewrite_ast_initial type_envs ast in - (* Recheck after descattering so that the internal type environments always - have complete variant types *) - let ast, type_envs = Type_error.check Type_check.initial_env ast in - - let out_name = match !opt_file_out with - | None when parsed = [] -> "out.sail" - | None -> fst (List.hd parsed) - | Some f -> f ^ ".sail" in - - (out_name, ast, type_envs) - let prover_regstate tgt ast type_envs = match tgt with | Some "coq" -> @@ -513,7 +486,7 @@ let target name out_name ast type_envs = | Some "smt" when !opt_smt_serialize -> let ast_smt, type_envs = Specialize.(specialize typ_ord_specialization type_envs ast) in let ast_smt, type_envs = Specialize.(specialize_passes 2 int_specialization_with_externs type_envs ast_smt) in - let jib, ctx = Jib_smt.compile type_envs ast_smt in + let jib, _, ctx = Jib_smt.compile type_envs ast_smt in let name_file = match !opt_file_out with | Some f -> f ^ ".smt_model" @@ -576,7 +549,8 @@ let main () = print_endline version else begin - let out_name, ast, type_envs = load_files Type_check.initial_env !opt_file_arguments in + let out_name, ast, type_envs = load_files options Type_check.initial_env !opt_file_arguments in + let ast, type_envs = descatter type_envs ast in let ast, type_envs = List.fold_right (fun file (ast,_) -> Splice.splice ast file) (!opt_splice) (ast, type_envs) diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 164bcefa..03994657 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -17,6 +17,14 @@ let opt_trace = ref false let trace_depth = ref 0 let random = ref false + +let opt_cycle_limit = ref 0 +let cycle_count = ref 0 + +let cycle_limit_reached () = + cycle_count := !cycle_count + 1; + !opt_cycle_limit != 0 && !cycle_count >= !opt_cycle_limit + let sail_call (type t) (f : _ -> t) = let module M = struct exception Return of t end @@ -274,9 +282,7 @@ let rec replicate_bits (bits, n) = let identity x = x - - -(* +(* Returns list of n bits of integer m starting from offset o >= 0 (bits numbered from least significant). Uses twos-complement representation for m<0 and pads most significant bits in sign-extended way. Most significant bit is head of returned list. @@ -529,7 +535,7 @@ let fast_read_ram (data_size, addr) = !vector let tag_ram = (ref Mem.empty : (bool Mem.t) ref);; - + let write_tag_bool (addr, tag) = let addri = uint addr in tag_ram := Mem.add addri tag !tag_ram @@ -551,7 +557,6 @@ let lor_int (n, m) = Big_int.bitwise_or n m let land_int (n, m) = Big_int.bitwise_and n m let lxor_int (n, m) = Big_int.bitwise_xor n m - let debug (str1, n, str2, v) = prerr_endline (str1 ^ Big_int.to_string n ^ str2 ^ string_of_bits v) let eq_string (str1, str2) = String.compare str1 str2 == 0 diff --git a/src/sail_pp.ml b/src/sail_pp.ml new file mode 100644 index 00000000..30f93a3e --- /dev/null +++ b/src/sail_pp.ml @@ -0,0 +1,904 @@ +(* generated by Ott 0.30 from: ../language/sail.ott *) +open PPrintEngine +open PPrintCombinators +open + +let rec pp_raw_l_default + +and pp_raw_id_aux x = match x with +| Id_aux_aux(Id(x),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Id" ^^ string "(" ^^ string "\"" ^^ string x ^^ string "\"" ^^ string ")" +| Id_aux_aux(Operator(x),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Operator" ^^ string "(" ^^ string "\"" ^^ string x ^^ string "\"" ^^ string ")" + +and pp_raw_id x = match x with +| Id_aux(id_aux,l) -> string "Id_aux" ^^ string "(" ^^ pp_raw_id_aux id_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_kid_aux x = match x with +| Kid_aux_aux(Var(x),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Var" ^^ string "(" ^^ string "\"" ^^ string x ^^ string "\"" ^^ string ")" + +and pp_raw_kid x = match x with +| Kid_aux(kid_aux,l) -> string "Kid_aux" ^^ string "(" ^^ pp_raw_kid_aux kid_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_kind_aux x = match x with +| K_aux(K_type,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "K_type" +| K_aux(K_int,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "K_int" +| K_aux(K_order,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "K_order" +| K_aux(K_bool,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "K_bool" + +and pp_raw_kind x = match x with +| K_aux(kind_aux,l) -> string "K_aux" ^^ string "(" ^^ pp_raw_kind_aux kind_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_nexp_aux x = match x with +| Nexp_aux(Nexp_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| Nexp_aux(Nexp_var(kid),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_var" ^^ string "(" ^^ pp_raw_kid kid ^^ string ")" +| Nexp_aux(Nexp_constant(num),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_constant" ^^ string "(" ^^ string "\"" ^^ string num ^^ string "\"" ^^ string ")" +| Nexp_aux(Nexp_app(id,nexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (nexp0) -> string "(" ^^ pp_raw_nexp nexp0 ^^ string ")") nexp0) ^^ string "]" ^^ string ")" +| Nexp_aux(Nexp_times(nexp1,nexp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_times" ^^ string "(" ^^ pp_raw_nexp nexp1 ^^ string "," ^^ pp_raw_nexp nexp2 ^^ string ")" +| Nexp_aux(Nexp_sum(nexp1,nexp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_sum" ^^ string "(" ^^ pp_raw_nexp nexp1 ^^ string "," ^^ pp_raw_nexp nexp2 ^^ string ")" +| Nexp_aux(Nexp_minus(nexp1,nexp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_minus" ^^ string "(" ^^ pp_raw_nexp nexp1 ^^ string "," ^^ pp_raw_nexp nexp2 ^^ string ")" +| Nexp_aux(Nexp_exp(nexp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_exp" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string ")" +| Nexp_aux(Nexp_neg(nexp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_neg" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string ")" + +and pp_raw_nexp x = match x with +| Nexp_aux(nexp_aux,l) -> string "Nexp_aux" ^^ string "(" ^^ pp_raw_nexp_aux nexp_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_order_aux x = match x with +| Ord_aux(Ord_var(kid),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Ord_var" ^^ string "(" ^^ pp_raw_kid kid ^^ string ")" +| Ord_aux(Ord_inc,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Ord_inc" +| Ord_aux(Ord_dec,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Ord_dec" + +and pp_raw_order x = match x with +| Ord_aux(order_aux,l) -> string "Ord_aux" ^^ string "(" ^^ pp_raw_order_aux order_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_base_effect_aux x = match x with +| BE_aux(BE_rreg,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_rreg" +| BE_aux(BE_wreg,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_wreg" +| BE_aux(BE_rmem,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_rmem" +| BE_aux(BE_rmemt,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_rmemt" +| BE_aux(BE_wmem,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_wmem" +| BE_aux(BE_eamem,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_eamem" +| BE_aux(BE_exmem,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_exmem" +| BE_aux(BE_wmv,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_wmv" +| BE_aux(BE_wmvt,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_wmvt" +| BE_aux(BE_barr,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_barr" +| BE_aux(BE_depend,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_depend" +| BE_aux(BE_undef,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_undef" +| BE_aux(BE_unspec,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_unspec" +| BE_aux(BE_nondet,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_nondet" +| BE_aux(BE_escape,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_escape" +| BE_aux(BE_config,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_config" + +and pp_raw_base_effect x = match x with +| BE_aux(base_effect_aux,l) -> string "BE_aux" ^^ string "(" ^^ pp_raw_base_effect_aux base_effect_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_effect_aux x = match x with +| Effect_aux(Effect_set(base_effect0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Effect_set" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (base_effect0) -> string "(" ^^ pp_raw_base_effect base_effect0 ^^ string ")") base_effect0) ^^ string "]" ^^ string ")" + +and pp_raw_effect x = match x with +| Effect_aux(effect_aux,l) -> string "Effect_aux" ^^ string "(" ^^ pp_raw_effect_aux effect_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_typ_aux x = match x with +| Typ_aux(Typ_internal_unknown,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_internal_unknown" +| Typ_aux(Typ_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| Typ_aux(Typ_var(kid),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_var" ^^ string "(" ^^ pp_raw_kid kid ^^ string ")" +| Typ_aux(Typ_fn(typ0,typ2,effect),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_fn" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (typ0) -> string "(" ^^ pp_raw_typ typ0 ^^ string ")") typ0) ^^ string "]" ^^ string "," ^^ pp_raw_typ typ2 ^^ string "," ^^ pp_raw_effect effect ^^ string ")" +| Typ_aux(Typ_bidir(typ1,typ2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_bidir" ^^ string "(" ^^ pp_raw_typ typ1 ^^ string "," ^^ pp_raw_typ typ2 ^^ string ")" +| Typ_aux(Typ_tup(typ0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_tup" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (typ0) -> string "(" ^^ pp_raw_typ typ0 ^^ string ")") typ0) ^^ string "]" ^^ string ")" +| Typ_aux(Typ_app(id,typ_arg0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (typ_arg0) -> string "(" ^^ pp_raw_typ_arg typ_arg0 ^^ string ")") typ_arg0) ^^ string "]" ^^ string ")" +| Typ_aux(Typ_exist(kinded_id0,n_constraint,typ),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_exist" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (kinded_id0) -> string "(" ^^ pp_raw_kinded_id kinded_id0 ^^ string ")") kinded_id0) ^^ string "]" ^^ string "," ^^ pp_raw_n_constraint n_constraint ^^ string "," ^^ pp_raw_typ typ ^^ string ")" + +and pp_raw_typ x = match x with +| Typ_aux(typ_aux,l) -> string "Typ_aux" ^^ string "(" ^^ pp_raw_typ_aux typ_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_typ_arg_aux x = match x with +| A_aux(A_nexp(nexp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "A_nexp" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string ")" +| A_aux(A_typ(typ),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "A_typ" ^^ string "(" ^^ pp_raw_typ typ ^^ string ")" +| A_aux(A_order(order),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "A_order" ^^ string "(" ^^ pp_raw_order order ^^ string ")" +| A_aux(A_bool(n_constraint),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "A_bool" ^^ string "(" ^^ pp_raw_n_constraint n_constraint ^^ string ")" + +and pp_raw_typ_arg x = match x with +| A_aux(typ_arg_aux,l) -> string "A_aux" ^^ string "(" ^^ pp_raw_typ_arg_aux typ_arg_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_n_constraint_aux x = match x with +| NC_aux(NC_equal(nexp,nexp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_equal" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string "," ^^ pp_raw_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_ge(nexp,nexp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_bounded_ge" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string "," ^^ pp_raw_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_gt(nexp,nexp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_bounded_gt" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string "," ^^ pp_raw_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_le(nexp,nexp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_bounded_le" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string "," ^^ pp_raw_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_lt(nexp,nexp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_bounded_lt" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string "," ^^ pp_raw_nexp nexp_prime ^^ string ")" +| NC_aux(NC_not_equal(nexp,nexp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_not_equal" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string "," ^^ pp_raw_nexp nexp_prime ^^ string ")" +| NC_aux(NC_set(kid,num0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_set" ^^ string "(" ^^ pp_raw_kid kid ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (num0) -> string "(" ^^ string "\"" ^^ string num0 ^^ string "\"" ^^ string ")") num0) ^^ string "]" ^^ string ")" +| NC_aux(NC_or(n_constraint,n_constraint_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_or" ^^ string "(" ^^ pp_raw_n_constraint n_constraint ^^ string "," ^^ pp_raw_n_constraint n_constraint_prime ^^ string ")" +| NC_aux(NC_and(n_constraint,n_constraint_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_and" ^^ string "(" ^^ pp_raw_n_constraint n_constraint ^^ string "," ^^ pp_raw_n_constraint n_constraint_prime ^^ string ")" +| NC_aux(NC_app(id,typ_arg0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (typ_arg0) -> string "(" ^^ pp_raw_typ_arg typ_arg0 ^^ string ")") typ_arg0) ^^ string "]" ^^ string ")" +| NC_aux(NC_var(kid),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_var" ^^ string "(" ^^ pp_raw_kid kid ^^ string ")" +| NC_aux(NC_true,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_true" +| NC_aux(NC_false,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_false" + +and pp_raw_n_constraint x = match x with +| NC_aux(n_constraint_aux,l) -> string "NC_aux" ^^ string "(" ^^ pp_raw_n_constraint_aux n_constraint_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_kinded_id_aux x = match x with +| KOpt_aux(KOpt_kind(kind,kid),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "KOpt_kind" ^^ string "(" ^^ pp_raw_kind kind ^^ string "," ^^ pp_raw_kid kid ^^ string ")" + +and pp_raw_kinded_id x = match x with +| KOpt_aux(kinded_id_aux,l) -> string "KOpt_aux" ^^ string "(" ^^ pp_raw_kinded_id_aux kinded_id_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_quant_item_aux x = match x with +| QI_aux(QI_id(kinded_id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "QI_id" ^^ string "(" ^^ pp_raw_kinded_id kinded_id ^^ string ")" +| QI_aux(QI_constraint(n_constraint),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "QI_constraint" ^^ string "(" ^^ pp_raw_n_constraint n_constraint ^^ string ")" +| QI_aux(QI_constant(kinded_id0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "QI_constant" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (kinded_id0) -> string "(" ^^ pp_raw_kinded_id kinded_id0 ^^ string ")") kinded_id0) ^^ string "]" ^^ string ")" + +and pp_raw_quant_item x = match x with +| QI_aux(quant_item_aux,l) -> string "QI_aux" ^^ string "(" ^^ pp_raw_quant_item_aux quant_item_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_typquant_aux x = match x with +| TypQ_aux(TypQ_tq(quant_item0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "TypQ_tq" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (quant_item0) -> string "(" ^^ pp_raw_quant_item quant_item0 ^^ string ")") quant_item0) ^^ string "]" ^^ string ")" +| TypQ_aux(TypQ_no_forall,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "TypQ_no_forall" + +and pp_raw_typquant x = match x with +| TypQ_aux(typquant_aux,l) -> string "TypQ_aux" ^^ string "(" ^^ pp_raw_typquant_aux typquant_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_typschm_aux x = match x with +| TypSchm_aux(TypSchm_ts(typquant,typ),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "TypSchm_ts" ^^ string "(" ^^ pp_raw_typquant typquant ^^ string "," ^^ pp_raw_typ typ ^^ string ")" + +and pp_raw_typschm x = match x with +| TypSchm_aux(typschm_aux,l) -> string "TypSchm_aux" ^^ string "(" ^^ pp_raw_typschm_aux typschm_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_type_def x = match x with +| TD_aux(type_def_aux) -> string "TD_aux" ^^ string "(" ^^ pp_raw_type_def_aux type_def_aux ^^ string ")" + +and pp_raw_type_def_aux x = match x with +| TD_abbrev(id,typquant,typ_arg) -> string "TD_abbrev" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_typquant typquant ^^ string "," ^^ pp_raw_typ_arg typ_arg ^^ string ")" +| TD_record(id,typquant,typ0_id0,semi_opt) -> string "TD_record" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_typquant typquant ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (typ0,id0) -> string "(" ^^ pp_raw_typ typ0 ^^ string "," ^^ pp_raw_id id0 ^^ string ")") typ0_id0) ^^ string "]" ^^ string "," ^^ pp_raw_semi_opt semi_opt ^^ string ")" +| TD_variant(id,typquant,type_union0,semi_opt) -> string "TD_variant" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_typquant typquant ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (type_union0) -> string "(" ^^ pp_raw_type_union type_union0 ^^ string ")") type_union0) ^^ string "]" ^^ string "," ^^ pp_raw_semi_opt semi_opt ^^ string ")" +| TD_enum(id,id0,semi_opt) -> string "TD_enum" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (id0) -> string "(" ^^ pp_raw_id id0 ^^ string ")") id0) ^^ string "]" ^^ string "," ^^ pp_raw_semi_opt semi_opt ^^ string ")" +| TD_bitfield(id,typ,id0_index_range0) -> string "TD_bitfield" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_typ typ ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (id0,index_range0) -> string "(" ^^ pp_raw_id id0 ^^ string "," ^^ pp_raw_index_range index_range0 ^^ string ")") id0_index_range0) ^^ string "]" ^^ string ")" + +and pp_raw_type_union_aux x = match x with +| Tu_aux(Tu_ty_id(typ,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Tu_ty_id" ^^ string "(" ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_id id ^^ string ")" + +and pp_raw_type_union x = match x with +| Tu_aux(type_union_aux,l) -> string "Tu_aux" ^^ string "(" ^^ pp_raw_type_union_aux type_union_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_index_range_aux x = match x with +| BF_aux(BF_single(nexp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BF_single" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string ")" +| BF_aux(BF_range(nexp1,nexp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BF_range" ^^ string "(" ^^ pp_raw_nexp nexp1 ^^ string "," ^^ pp_raw_nexp nexp2 ^^ string ")" +| BF_aux(BF_concat(index_range1,index_range2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BF_concat" ^^ string "(" ^^ pp_raw_index_range index_range1 ^^ string "," ^^ pp_raw_index_range index_range2 ^^ string ")" + +and pp_raw_index_range x = match x with +| BF_aux(index_range_aux,l) -> string "BF_aux" ^^ string "(" ^^ pp_raw_index_range_aux index_range_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_lit_aux x = match x with +| L_aux(L_unit,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_unit" +| L_aux(L_zero,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_zero" +| L_aux(L_one,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_one" +| L_aux(L_true,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_true" +| L_aux(L_false,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_false" +| L_aux(L_num(num),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_num" ^^ string "(" ^^ string "\"" ^^ string num ^^ string "\"" ^^ string ")" +| L_aux(L_hex(hex),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_hex" ^^ string "(" ^^ string "\"" ^^ string hex ^^ string "\"" ^^ string ")" +| L_aux(L_bin(bin),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_bin" ^^ string "(" ^^ string "\"" ^^ string bin ^^ string "\"" ^^ string ")" +| L_aux(L_string(string),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_string" ^^ string "(" ^^ string "\"" ^^ string string ^^ string "\"" ^^ string ")" +| L_aux(L_undef,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_undef" +| L_aux(L_real(real),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_real" ^^ string "(" ^^ string "\"" ^^ string real ^^ string "\"" ^^ string ")" + +and pp_raw_lit x = match x with +| L_aux(lit_aux,l) -> string "L_aux" ^^ string "(" ^^ pp_raw_lit_aux lit_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_semi_opt_default + +and pp_raw_typ_pat_aux x = match x with +| TP_aux(TP_wild,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "TP_wild" +| TP_aux(TP_var(kid),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "TP_var" ^^ string "(" ^^ pp_raw_kid kid ^^ string ")" +| TP_aux(TP_app(id,typ_pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "TP_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (typ_pat0) -> string "(" ^^ pp_raw_typ_pat typ_pat0 ^^ string ")") typ_pat0) ^^ string "]" ^^ string ")" + +and pp_raw_typ_pat x = match x with +| TP_aux(typ_pat_aux,l) -> string "TP_aux" ^^ string "(" ^^ pp_raw_typ_pat_aux typ_pat_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_pat_aux x = match x with +| P_aux(P_lit(lit),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_lit" ^^ string "(" ^^ pp_raw_lit lit ^^ string ")" +| P_aux(P_wild,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_wild" +| P_aux(P_or(pat1,pat2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_or" ^^ string "(" ^^ pp_raw_pat pat1 ^^ string "," ^^ pp_raw_pat pat2 ^^ string ")" +| P_aux(P_not(pat),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_not" ^^ string "(" ^^ pp_raw_pat pat ^^ string ")" +| P_aux(P_as(pat,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_as" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_id id ^^ string ")" +| P_aux(P_typ(typ,pat),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_typ" ^^ string "(" ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_pat pat ^^ string ")" +| P_aux(P_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| P_aux(P_var(pat,typ_pat),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_var" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_typ_pat typ_pat ^^ string ")" +| P_aux(P_app(id,pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (pat0) -> string "(" ^^ pp_raw_pat pat0 ^^ string ")") pat0) ^^ string "]" ^^ string ")" +| P_aux(P_vector(pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_vector" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (pat0) -> string "(" ^^ pp_raw_pat pat0 ^^ string ")") pat0) ^^ string "]" ^^ string ")" +| P_aux(P_vector_concat(pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_vector_concat" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (pat0) -> string "(" ^^ pp_raw_pat pat0 ^^ string ")") pat0) ^^ string "]" ^^ string ")" +| P_aux(P_tup(pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_tup" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (pat0) -> string "(" ^^ pp_raw_pat pat0 ^^ string ")") pat0) ^^ string "]" ^^ string ")" +| P_aux(P_list(pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_list" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (pat0) -> string "(" ^^ pp_raw_pat pat0 ^^ string ")") pat0) ^^ string "]" ^^ string ")" +| P_aux(P_cons(pat1,pat2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_cons" ^^ string "(" ^^ pp_raw_pat pat1 ^^ string "," ^^ pp_raw_pat pat2 ^^ string ")" +| P_aux(P_string_append(pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_string_append" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (pat0) -> string "(" ^^ pp_raw_pat pat0 ^^ string ")") pat0) ^^ string "]" ^^ string ")" + +and pp_raw_pat x = match x with +| P_aux(pat_aux,annot) -> string "P_aux" ^^ string "(" ^^ pp_raw_pat_aux pat_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_loop_default + +and pp_raw_internal_loop_measure_aux x = match x with +| Measure_aux(Measure_none,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Measure_none" +| Measure_aux(Measure_some(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Measure_some" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_internal_loop_measure x = match x with +| Measure_aux(internal_loop_measure_aux,l) -> string "Measure_aux" ^^ string "(" ^^ pp_raw_internal_loop_measure_aux internal_loop_measure_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_exp_aux x = match x with +| E_aux(E_block(exp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_block" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (exp0) -> string "(" ^^ pp_raw_exp exp0 ^^ string ")") exp0) ^^ string "]" ^^ string ")" +| E_aux(E_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| E_aux(E_lit(lit),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_lit" ^^ string "(" ^^ pp_raw_lit lit ^^ string ")" +| E_aux(E_cast(typ,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_cast" ^^ string "(" ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_app(id,exp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (exp0) -> string "(" ^^ pp_raw_exp exp0 ^^ string ")") exp0) ^^ string "]" ^^ string ")" +| E_aux(E_app_infix(exp1,id,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_app_infix" ^^ string "(" ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_id id ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| E_aux(E_tuple(exp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_tuple" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (exp0) -> string "(" ^^ pp_raw_exp exp0 ^^ string ")") exp0) ^^ string "]" ^^ string ")" +| E_aux(E_if(exp1,exp2,exp3),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_if" ^^ string "(" ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string "," ^^ pp_raw_exp exp3 ^^ string ")" +| E_aux(E_loop(loop,internal_loop_measure,exp1,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_loop" ^^ string "(" ^^ pp_raw_loop loop ^^ string "," ^^ pp_raw_internal_loop_measure internal_loop_measure ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| E_aux(E_for(id,exp1,exp2,exp3,order,exp4),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_for" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string "," ^^ pp_raw_exp exp3 ^^ string "," ^^ pp_raw_order order ^^ string "," ^^ pp_raw_exp exp4 ^^ string ")" +| E_aux(E_vector(exp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_vector" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (exp0) -> string "(" ^^ pp_raw_exp exp0 ^^ string ")") exp0) ^^ string "]" ^^ string ")" +| E_aux(E_vector_access(exp,exp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_vector_access" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp_prime ^^ string ")" +| E_aux(E_vector_subrange(exp,exp1,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_vector_subrange" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| E_aux(E_vector_update(exp,exp1,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_vector_update" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| E_aux(E_vector_update_subrange(exp,exp1,exp2,exp3),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_vector_update_subrange" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string "," ^^ pp_raw_exp exp3 ^^ string ")" +| E_aux(E_vector_append(exp1,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_vector_append" ^^ string "(" ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| E_aux(E_list(exp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_list" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (exp0) -> string "(" ^^ pp_raw_exp exp0 ^^ string ")") exp0) ^^ string "]" ^^ string ")" +| E_aux(E_cons(exp1,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_cons" ^^ string "(" ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| E_aux(E_record(fexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_record" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (fexp0) -> string "(" ^^ pp_raw_fexp fexp0 ^^ string ")") fexp0) ^^ string "]" ^^ string ")" +| E_aux(E_record_update(exp,fexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_record_update" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (fexp0) -> string "(" ^^ pp_raw_fexp fexp0 ^^ string ")") fexp0) ^^ string "]" ^^ string ")" +| E_aux(E_field(exp,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_field" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_id id ^^ string ")" +| E_aux(E_case(exp,pexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_case" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (pexp0) -> string "(" ^^ pp_raw_pexp pexp0 ^^ string ")") pexp0) ^^ string "]" ^^ string ")" +| E_aux(E_let(letbind,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_let" ^^ string "(" ^^ pp_raw_letbind letbind ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_assign(lexp,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_assign" ^^ string "(" ^^ pp_raw_lexp lexp ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_sizeof(nexp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_sizeof" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string ")" +| E_aux(E_return(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_return" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_exit(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_exit" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_ref(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_ref" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| E_aux(E_throw(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_throw" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_try(exp,pexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_try" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (pexp0) -> string "(" ^^ pp_raw_pexp pexp0 ^^ string ")") pexp0) ^^ string "]" ^^ string ")" +| E_aux(E_assert(exp,exp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_assert" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp_prime ^^ string ")" +| E_aux(E_var(lexp,exp,exp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_var" ^^ string "(" ^^ pp_raw_lexp lexp ^^ string "," ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp_prime ^^ string ")" +| E_aux(E_internal_plet(pat,exp,exp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_internal_plet" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp_prime ^^ string ")" +| E_aux(E_internal_return(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_internal_return" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_internal_value(value),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_internal_value" ^^ string "(" ^^ string "\"" ^^ string value ^^ string "\"" ^^ string ")" +| E_aux(E_constraint(n_constraint),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_constraint" ^^ string "(" ^^ pp_raw_n_constraint n_constraint ^^ string ")" + +and pp_raw_exp x = match x with +| E_aux(exp_aux,annot) -> string "E_aux" ^^ string "(" ^^ pp_raw_exp_aux exp_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_lexp_aux x = match x with +| LEXP_aux(LEXP_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| LEXP_aux(LEXP_deref(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_deref" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" +| LEXP_aux(LEXP_memory(id,exp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_memory" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (exp0) -> string "(" ^^ pp_raw_exp exp0 ^^ string ")") exp0) ^^ string "]" ^^ string ")" +| LEXP_aux(LEXP_cast(typ,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_cast" ^^ string "(" ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_id id ^^ string ")" +| LEXP_aux(LEXP_tup(lexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_tup" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (lexp0) -> string "(" ^^ pp_raw_lexp lexp0 ^^ string ")") lexp0) ^^ string "]" ^^ string ")" +| LEXP_aux(LEXP_vector_concat(lexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_vector_concat" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (lexp0) -> string "(" ^^ pp_raw_lexp lexp0 ^^ string ")") lexp0) ^^ string "]" ^^ string ")" +| LEXP_aux(LEXP_vector(lexp,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_vector" ^^ string "(" ^^ pp_raw_lexp lexp ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| LEXP_aux(LEXP_vector_range(lexp,exp1,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_vector_range" ^^ string "(" ^^ pp_raw_lexp lexp ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| LEXP_aux(LEXP_field(lexp,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_field" ^^ string "(" ^^ pp_raw_lexp lexp ^^ string "," ^^ pp_raw_id id ^^ string ")" + +and pp_raw_lexp x = match x with +| LEXP_aux(lexp_aux,annot) -> string "LEXP_aux" ^^ string "(" ^^ pp_raw_lexp_aux lexp_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_fexp_aux x = match x with +| FE_aux(FE_Fexp(id,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "FE_Fexp" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_fexp x = match x with +| FE_aux(fexp_aux,annot) -> string "FE_aux" ^^ string "(" ^^ pp_raw_fexp_aux fexp_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_opt_default_aux x = match x with +| Def_val_aux(Def_val_empty,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Def_val_empty" +| Def_val_aux(Def_val_dec(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Def_val_dec" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_opt_default x = match x with +| Def_val_aux(opt_default_aux,annot) -> string "Def_val_aux" ^^ string "(" ^^ pp_raw_opt_default_aux opt_default_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_pexp_aux x = match x with +| Pat_aux(Pat_exp(pat,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Pat_exp" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| Pat_aux(Pat_when(pat,exp1,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Pat_when" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_pexp x = match x with +| Pat_aux(pexp_aux,annot) -> string "Pat_aux" ^^ string "(" ^^ pp_raw_pexp_aux pexp_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_tannot_opt_aux x = match x with +| Typ_annot_opt_aux(Typ_annot_opt_none,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_annot_opt_none" +| Typ_annot_opt_aux(Typ_annot_opt_some(typquant,typ),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_annot_opt_some" ^^ string "(" ^^ pp_raw_typquant typquant ^^ string "," ^^ pp_raw_typ typ ^^ string ")" + +and pp_raw_tannot_opt x = match x with +| Typ_annot_opt_aux(tannot_opt_aux,l) -> string "Typ_annot_opt_aux" ^^ string "(" ^^ pp_raw_tannot_opt_aux tannot_opt_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_rec_opt_aux x = match x with +| Rec_aux(Rec_nonrec,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Rec_nonrec" +| Rec_aux(Rec_rec,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Rec_rec" +| Rec_aux(Rec_measure(pat,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Rec_measure" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_rec_opt x = match x with +| Rec_aux(rec_opt_aux,l) -> string "Rec_aux" ^^ string "(" ^^ pp_raw_rec_opt_aux rec_opt_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_effect_opt_aux x = match x with +| Effect_opt_aux(Effect_opt_none,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Effect_opt_none" +| Effect_opt_aux(Effect_opt_effect(effect),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Effect_opt_effect" ^^ string "(" ^^ pp_raw_effect effect ^^ string ")" + +and pp_raw_effect_opt x = match x with +| Effect_opt_aux(effect_opt_aux,l) -> string "Effect_opt_aux" ^^ string "(" ^^ pp_raw_effect_opt_aux effect_opt_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_pexp_funcl x = match x with +| Pat_funcl_exp(pat,exp) -> string "Pat_funcl_exp" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| Pat_funcl_when(pat,exp1,exp) -> string "Pat_funcl_when" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_funcl_aux x = match x with +| FCL_aux(FCL_Funcl(id,pexp_funcl),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "FCL_Funcl" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_pexp_funcl pexp_funcl ^^ string ")" + +and pp_raw_funcl x = match x with +| FCL_aux(funcl_aux,annot) -> string "FCL_aux" ^^ string "(" ^^ pp_raw_funcl_aux funcl_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_fundef_aux x = match x with +| FD_aux(FD_function(rec_opt,tannot_opt,effect_opt,funcl0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "FD_function" ^^ string "(" ^^ pp_raw_rec_opt rec_opt ^^ string "," ^^ pp_raw_tannot_opt tannot_opt ^^ string "," ^^ pp_raw_effect_opt effect_opt ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (funcl0) -> string "(" ^^ pp_raw_funcl funcl0 ^^ string ")") funcl0) ^^ string "]" ^^ string ")" + +and pp_raw_fundef x = match x with +| FD_aux(fundef_aux,annot) -> string "FD_aux" ^^ string "(" ^^ pp_raw_fundef_aux fundef_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_mpat_aux x = match x with +| MP_aux(MP_lit(lit),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_lit" ^^ string "(" ^^ pp_raw_lit lit ^^ string ")" +| MP_aux(MP_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| MP_aux(MP_app(id,mpat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (mpat0) -> string "(" ^^ pp_raw_mpat mpat0 ^^ string ")") mpat0) ^^ string "]" ^^ string ")" +| MP_aux(MP_vector(mpat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_vector" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (mpat0) -> string "(" ^^ pp_raw_mpat mpat0 ^^ string ")") mpat0) ^^ string "]" ^^ string ")" +| MP_aux(MP_vector_concat(mpat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_vector_concat" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (mpat0) -> string "(" ^^ pp_raw_mpat mpat0 ^^ string ")") mpat0) ^^ string "]" ^^ string ")" +| MP_aux(MP_tup(mpat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_tup" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (mpat0) -> string "(" ^^ pp_raw_mpat mpat0 ^^ string ")") mpat0) ^^ string "]" ^^ string ")" +| MP_aux(MP_list(mpat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_list" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (mpat0) -> string "(" ^^ pp_raw_mpat mpat0 ^^ string ")") mpat0) ^^ string "]" ^^ string ")" +| MP_aux(MP_cons(mpat1,mpat2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_cons" ^^ string "(" ^^ pp_raw_mpat mpat1 ^^ string "," ^^ pp_raw_mpat mpat2 ^^ string ")" +| MP_aux(MP_string_append(mpat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_string_append" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (mpat0) -> string "(" ^^ pp_raw_mpat mpat0 ^^ string ")") mpat0) ^^ string "]" ^^ string ")" +| MP_aux(MP_typ(mpat,typ),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_typ" ^^ string "(" ^^ pp_raw_mpat mpat ^^ string "," ^^ pp_raw_typ typ ^^ string ")" +| MP_aux(MP_as(mpat,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_as" ^^ string "(" ^^ pp_raw_mpat mpat ^^ string "," ^^ pp_raw_id id ^^ string ")" + +and pp_raw_mpat x = match x with +| MP_aux(mpat_aux,annot) -> string "MP_aux" ^^ string "(" ^^ pp_raw_mpat_aux mpat_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_mpexp_aux x = match x with +| MPat_aux(MPat_pat(mpat),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MPat_pat" ^^ string "(" ^^ pp_raw_mpat mpat ^^ string ")" +| MPat_aux(MPat_when(mpat,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MPat_when" ^^ string "(" ^^ pp_raw_mpat mpat ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_mpexp x = match x with +| MPat_aux(mpexp_aux,annot) -> string "MPat_aux" ^^ string "(" ^^ pp_raw_mpexp_aux mpexp_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_mapcl_aux x = match x with +| MCL_aux(MCL_bidir(mpexp1,mpexp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MCL_bidir" ^^ string "(" ^^ pp_raw_mpexp mpexp1 ^^ string "," ^^ pp_raw_mpexp mpexp2 ^^ string ")" +| MCL_aux(MCL_forwards(mpexp,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MCL_forwards" ^^ string "(" ^^ pp_raw_mpexp mpexp ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| MCL_aux(MCL_backwards(mpexp,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MCL_backwards" ^^ string "(" ^^ pp_raw_mpexp mpexp ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_mapcl x = match x with +| MCL_aux(mapcl_aux,annot) -> string "MCL_aux" ^^ string "(" ^^ pp_raw_mapcl_aux mapcl_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_mapdef_aux x = match x with +| MD_aux(MD_mapping(id,tannot_opt,mapcl0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MD_mapping" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_tannot_opt tannot_opt ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (mapcl0) -> string "(" ^^ pp_raw_mapcl mapcl0 ^^ string ")") mapcl0) ^^ string "]" ^^ string ")" + +and pp_raw_mapdef x = match x with +| MD_aux(mapdef_aux,annot) -> string "MD_aux" ^^ string "(" ^^ pp_raw_mapdef_aux mapdef_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_letbind_aux x = match x with +| LB_aux(LB_val(pat,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LB_val" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_letbind x = match x with +| LB_aux(letbind_aux,annot) -> string "LB_aux" ^^ string "(" ^^ pp_raw_letbind_aux letbind_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_val_spec x = match x with +| VS_aux(val_spec_aux) -> string "VS_aux" ^^ string "(" ^^ pp_raw_val_spec_aux val_spec_aux ^^ string ")" + +and pp_raw_val_spec_aux x = match x with + +and pp_raw_default_spec_aux x = match x with +| DT_aux(DT_order(order),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "DT_order" ^^ string "(" ^^ pp_raw_order order ^^ string ")" + +and pp_raw_default_spec x = match x with +| DT_aux(default_spec_aux,l) -> string "DT_aux" ^^ string "(" ^^ pp_raw_default_spec_aux default_spec_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_scattered_def_aux x = match x with +| SD_aux(SD_function(rec_opt,tannot_opt,effect_opt,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_function" ^^ string "(" ^^ pp_raw_rec_opt rec_opt ^^ string "," ^^ pp_raw_tannot_opt tannot_opt ^^ string "," ^^ pp_raw_effect_opt effect_opt ^^ string "," ^^ pp_raw_id id ^^ string ")" +| SD_aux(SD_funcl(funcl),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_funcl" ^^ string "(" ^^ pp_raw_funcl funcl ^^ string ")" +| SD_aux(SD_variant(id,typquant),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_variant" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_typquant typquant ^^ string ")" +| SD_aux(SD_unioncl(id,type_union),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_unioncl" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_type_union type_union ^^ string ")" +| SD_aux(SD_mapping(id,tannot_opt),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_mapping" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_tannot_opt tannot_opt ^^ string ")" +| SD_aux(SD_mapcl(id,mapcl),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_mapcl" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_mapcl mapcl ^^ string ")" +| SD_aux(SD_end(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_end" ^^ string "(" ^^ pp_raw_id id ^^ string ")" + +and pp_raw_scattered_def x = match x with +| SD_aux(scattered_def_aux,annot) -> string "SD_aux" ^^ string "(" ^^ pp_raw_scattered_def_aux scattered_def_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_reg_id_aux x = match x with +| RI_aux(RI_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "RI_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" + +and pp_raw_reg_id x = match x with +| RI_aux(reg_id_aux,annot) -> string "RI_aux" ^^ string "(" ^^ pp_raw_reg_id_aux reg_id_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_alias_spec_aux x = match x with +| AL_aux(AL_subreg(reg_id,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "AL_subreg" ^^ string "(" ^^ pp_raw_reg_id reg_id ^^ string "," ^^ pp_raw_id id ^^ string ")" +| AL_aux(AL_bit(reg_id,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "AL_bit" ^^ string "(" ^^ pp_raw_reg_id reg_id ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| AL_aux(AL_slice(reg_id,exp,exp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "AL_slice" ^^ string "(" ^^ pp_raw_reg_id reg_id ^^ string "," ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp_prime ^^ string ")" +| AL_aux(AL_concat(reg_id,reg_id_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "AL_concat" ^^ string "(" ^^ pp_raw_reg_id reg_id ^^ string "," ^^ pp_raw_reg_id reg_id_prime ^^ string ")" + +and pp_raw_alias_spec x = match x with +| AL_aux(alias_spec_aux,annot) -> string "AL_aux" ^^ string "(" ^^ pp_raw_alias_spec_aux alias_spec_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_dec_spec_aux x = match x with +| DEC_aux(DEC_reg(effect,effect_prime,typ,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "DEC_reg" ^^ string "(" ^^ pp_raw_effect effect ^^ string "," ^^ pp_raw_effect effect_prime ^^ string "," ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_id id ^^ string ")" +| DEC_aux(DEC_config(id,typ,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "DEC_config" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| DEC_aux(DEC_alias(id,alias_spec),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "DEC_alias" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_alias_spec alias_spec ^^ string ")" +| DEC_aux(DEC_typ_alias(typ,id,alias_spec),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "DEC_typ_alias" ^^ string "(" ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_id id ^^ string "," ^^ pp_raw_alias_spec alias_spec ^^ string ")" + +and pp_raw_dec_spec x = match x with +| DEC_aux(dec_spec_aux,annot) -> string "DEC_aux" ^^ string "(" ^^ pp_raw_dec_spec_aux dec_spec_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_prec x = match x with +| Infix -> string "Infix" +| InfixL -> string "InfixL" +| InfixR -> string "InfixR" + +and pp_raw_loop_measure x = match x with +| Loop(loop,exp) -> string "Loop" ^^ string "(" ^^ pp_raw_loop loop ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_def x = match x with +| DEF_type(type_def) -> string "DEF_type" ^^ string "(" ^^ pp_raw_type_def type_def ^^ string ")" +| DEF_fundef(fundef) -> string "DEF_fundef" ^^ string "(" ^^ pp_raw_fundef fundef ^^ string ")" +| DEF_mapdef(mapdef) -> string "DEF_mapdef" ^^ string "(" ^^ pp_raw_mapdef mapdef ^^ string ")" +| DEF_val(letbind) -> string "DEF_val" ^^ string "(" ^^ pp_raw_letbind letbind ^^ string ")" +| DEF_spec(val_spec) -> string "DEF_spec" ^^ string "(" ^^ pp_raw_val_spec val_spec ^^ string ")" +| DEF_fixity(prec,num,id) -> string "DEF_fixity" ^^ string "(" ^^ pp_raw_prec prec ^^ string "," ^^ string "\"" ^^ string num ^^ string "\"" ^^ string "," ^^ pp_raw_id id ^^ string ")" +| DEF_overload(id,id0) -> string "DEF_overload" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (id0) -> string "(" ^^ pp_raw_id id0 ^^ string ")") id0) ^^ string "]" ^^ string ")" +| DEF_default(default_spec) -> string "DEF_default" ^^ string "(" ^^ pp_raw_default_spec default_spec ^^ string ")" +| DEF_scattered(scattered_def) -> string "DEF_scattered" ^^ string "(" ^^ pp_raw_scattered_def scattered_def ^^ string ")" +| DEF_measure(id,pat,exp) -> string "DEF_measure" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| DEF_loop_measures(id,loop_measure0) -> string "DEF_loop_measures" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (loop_measure0) -> string "(" ^^ pp_raw_loop_measure loop_measure0 ^^ string ")") loop_measure0) ^^ string "]" ^^ string ")" +| DEF_reg_dec(dec_spec) -> string "DEF_reg_dec" ^^ string "(" ^^ pp_raw_dec_spec dec_spec ^^ string ")" +| DEF_internal_mutrec(fundef0) -> string "DEF_internal_mutrec" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (fundef0) -> string "(" ^^ pp_raw_fundef fundef0 ^^ string ")") fundef0) ^^ string "]" ^^ string ")" +| DEF_pragma(string1,string2,l) -> string "DEF_pragma" ^^ string "(" ^^ string "\"" ^^ string string1 ^^ string "\"" ^^ string "," ^^ string "\"" ^^ string string2 ^^ string "\"" ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_defs x = match x with +| Defs(def0) -> string "Defs" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (def0) -> string "(" ^^ pp_raw_def def0 ^^ string ")") def0) ^^ string "]" ^^ string ")" + + +let rec pp_l_default + +and pp_id_aux x = match x with +| Id_aux_aux(Id(x),ott_menhir_loc) -> string x +| Id_aux_aux(Operator(x),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ string "operator" ^^ string " " ^^ string x ^^ string " " ^^ string ")" ^^ string ")" + +and pp_id x = match x with +| Id_aux(id_aux,l) -> string "(" ^^ pp_id_aux id_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_kid_aux x = match x with +| Kid_aux_aux(Var(x),ott_menhir_loc) -> string "(" ^^ string "'" ^^ string " " ^^ string x ^^ string ")" + +and pp_kid x = match x with +| Kid_aux(kid_aux,l) -> string "(" ^^ pp_kid_aux kid_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_kind_aux x = match x with +| K_aux(K_type,ott_menhir_loc) -> string "Type" +| K_aux(K_int,ott_menhir_loc) -> string "Int" +| K_aux(K_order,ott_menhir_loc) -> string "Order" +| K_aux(K_bool,ott_menhir_loc) -> string "Bool" + +and pp_kind x = match x with +| K_aux(kind_aux,l) -> string "(" ^^ pp_kind_aux kind_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_nexp_aux x = match x with +| Nexp_aux(Nexp_id(id),ott_menhir_loc) -> pp_id id +| Nexp_aux(Nexp_var(kid),ott_menhir_loc) -> pp_kid kid +| Nexp_aux(Nexp_constant(num),ott_menhir_loc) -> string num +| Nexp_aux(Nexp_app(id,nexp0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (nexp0) -> pp_nexp nexp0) nexp0) ^^ string " " ^^ string ")" ^^ string ")" +| Nexp_aux(Nexp_times(nexp1,nexp2),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp1 ^^ string " " ^^ string "*" ^^ string " " ^^ pp_nexp nexp2 ^^ string ")" +| Nexp_aux(Nexp_sum(nexp1,nexp2),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp1 ^^ string " " ^^ string "+" ^^ string " " ^^ pp_nexp nexp2 ^^ string ")" +| Nexp_aux(Nexp_minus(nexp1,nexp2),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp1 ^^ string " " ^^ string "-" ^^ string " " ^^ pp_nexp nexp2 ^^ string ")" +| Nexp_aux(Nexp_exp(nexp),ott_menhir_loc) -> string "(" ^^ string "2" ^^ string " " ^^ string "^" ^^ string " " ^^ pp_nexp nexp ^^ string ")" +| Nexp_aux(Nexp_neg(nexp),ott_menhir_loc) -> string "(" ^^ string "-" ^^ string " " ^^ pp_nexp nexp ^^ string ")" + +and pp_nexp x = match x with +| Nexp_aux(nexp_aux,l) -> string "(" ^^ pp_nexp_aux nexp_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_order_aux x = match x with +| Ord_aux(Ord_var(kid),ott_menhir_loc) -> pp_kid kid +| Ord_aux(Ord_inc,ott_menhir_loc) -> string "inc" +| Ord_aux(Ord_dec,ott_menhir_loc) -> string "dec" + +and pp_order x = match x with +| Ord_aux(order_aux,l) -> string "(" ^^ pp_order_aux order_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_base_effect_aux x = match x with +| BE_aux(BE_rreg,ott_menhir_loc) -> string "rreg" +| BE_aux(BE_wreg,ott_menhir_loc) -> string "wreg" +| BE_aux(BE_rmem,ott_menhir_loc) -> string "rmem" +| BE_aux(BE_rmemt,ott_menhir_loc) -> string "rmemt" +| BE_aux(BE_wmem,ott_menhir_loc) -> string "wmem" +| BE_aux(BE_eamem,ott_menhir_loc) -> string "wmea" +| BE_aux(BE_exmem,ott_menhir_loc) -> string "exmem" +| BE_aux(BE_wmv,ott_menhir_loc) -> string "wmv" +| BE_aux(BE_wmvt,ott_menhir_loc) -> string "wmvt" +| BE_aux(BE_barr,ott_menhir_loc) -> string "barr" +| BE_aux(BE_depend,ott_menhir_loc) -> string "depend" +| BE_aux(BE_undef,ott_menhir_loc) -> string "undef" +| BE_aux(BE_unspec,ott_menhir_loc) -> string "unspec" +| BE_aux(BE_nondet,ott_menhir_loc) -> string "nondet" +| BE_aux(BE_escape,ott_menhir_loc) -> string "escape" +| BE_aux(BE_config,ott_menhir_loc) -> string "config" + +and pp_base_effect x = match x with +| BE_aux(base_effect_aux,l) -> string "(" ^^ pp_base_effect_aux base_effect_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_effect_aux x = match x with +| Effect_aux(Effect_set(base_effect0),ott_menhir_loc) -> string "(" ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (base_effect0) -> pp_base_effect base_effect0) base_effect0) ^^ string " " ^^ string "}" ^^ string ")" + +and pp_effect x = match x with +| Effect_aux(effect_aux,l) -> string "(" ^^ pp_effect_aux effect_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_typ_aux x = match x with +| Typ_aux(Typ_internal_unknown,ott_menhir_loc) -> string "" +| Typ_aux(Typ_id(id),ott_menhir_loc) -> pp_id id +| Typ_aux(Typ_var(kid),ott_menhir_loc) -> pp_kid kid +| Typ_aux(Typ_fn(typ0,typ2,effect),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (typ0) -> pp_typ typ0) typ0) ^^ string " " ^^ string ")" ^^ string " " ^^ string "->" ^^ string " " ^^ pp_typ typ2 ^^ string " " ^^ string "effectkw" ^^ string " " ^^ pp_effect effect ^^ string ")" +| Typ_aux(Typ_bidir(typ1,typ2),ott_menhir_loc) -> string "(" ^^ pp_typ typ1 ^^ string " " ^^ string "<->" ^^ string " " ^^ pp_typ typ2 ^^ string ")" +| Typ_aux(Typ_tup(typ0),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (typ0) -> pp_typ typ0) typ0) ^^ string " " ^^ string ")" ^^ string ")" +| Typ_aux(Typ_app(id,typ_arg0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (typ_arg0) -> pp_typ_arg typ_arg0) typ_arg0) ^^ string " " ^^ string ")" ^^ string ")" +| Typ_aux(Typ_exist(kinded_id0,n_constraint,typ),ott_menhir_loc) -> string "(" ^^ string "{" ^^ string " " ^^ separate (string " ") (List.map (function (kinded_id0) -> pp_kinded_id kinded_id0) kinded_id0) ^^ string " " ^^ string "," ^^ string " " ^^ pp_n_constraint n_constraint ^^ string " " ^^ string "." ^^ string " " ^^ pp_typ typ ^^ string " " ^^ string "}" ^^ string ")" + +and pp_typ x = match x with +| Typ_aux(typ_aux,l) -> string "(" ^^ pp_typ_aux typ_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_typ_arg_aux x = match x with +| A_aux(A_nexp(nexp),ott_menhir_loc) -> pp_nexp nexp +| A_aux(A_typ(typ),ott_menhir_loc) -> pp_typ typ +| A_aux(A_order(order),ott_menhir_loc) -> pp_order order +| A_aux(A_bool(n_constraint),ott_menhir_loc) -> pp_n_constraint n_constraint + +and pp_typ_arg x = match x with +| A_aux(typ_arg_aux,l) -> string "(" ^^ pp_typ_arg_aux typ_arg_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_n_constraint_aux x = match x with +| NC_aux(NC_equal(nexp,nexp_prime),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp ^^ string " " ^^ string "==" ^^ string " " ^^ pp_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_ge(nexp,nexp_prime),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp ^^ string " " ^^ string ">=" ^^ string " " ^^ pp_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_gt(nexp,nexp_prime),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp ^^ string " " ^^ string ">" ^^ string " " ^^ pp_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_le(nexp,nexp_prime),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp ^^ string " " ^^ string "<=" ^^ string " " ^^ pp_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_lt(nexp,nexp_prime),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp ^^ string " " ^^ string "<" ^^ string " " ^^ pp_nexp nexp_prime ^^ string ")" +| NC_aux(NC_not_equal(nexp,nexp_prime),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp ^^ string " " ^^ string "!=" ^^ string " " ^^ pp_nexp nexp_prime ^^ string ")" +| NC_aux(NC_set(kid,num0),ott_menhir_loc) -> string "(" ^^ pp_kid kid ^^ string " " ^^ string "IN" ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (num0) -> string num0) num0) ^^ string " " ^^ string "}" ^^ string ")" +| NC_aux(NC_or(n_constraint,n_constraint_prime),ott_menhir_loc) -> string "(" ^^ pp_n_constraint n_constraint ^^ string " " ^^ string "&" ^^ string " " ^^ pp_n_constraint n_constraint_prime ^^ string ")" +| NC_aux(NC_and(n_constraint,n_constraint_prime),ott_menhir_loc) -> string "(" ^^ pp_n_constraint n_constraint ^^ string " " ^^ string "|" ^^ string " " ^^ pp_n_constraint n_constraint_prime ^^ string ")" +| NC_aux(NC_app(id,typ_arg0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (typ_arg0) -> pp_typ_arg typ_arg0) typ_arg0) ^^ string " " ^^ string ")" ^^ string ")" +| NC_aux(NC_var(kid),ott_menhir_loc) -> pp_kid kid +| NC_aux(NC_true,ott_menhir_loc) -> string "true" +| NC_aux(NC_false,ott_menhir_loc) -> string "false" + +and pp_n_constraint x = match x with +| NC_aux(n_constraint_aux,l) -> string "(" ^^ pp_n_constraint_aux n_constraint_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_kinded_id_aux x = match x with +| KOpt_aux(KOpt_kind(kind,kid),ott_menhir_loc) -> string "(" ^^ pp_kind kind ^^ string " " ^^ pp_kid kid ^^ string ")" + +and pp_kinded_id x = match x with +| KOpt_aux(kinded_id_aux,l) -> string "(" ^^ pp_kinded_id_aux kinded_id_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_quant_item_aux x = match x with +| QI_aux(QI_id(kinded_id),ott_menhir_loc) -> pp_kinded_id kinded_id +| QI_aux(QI_constraint(n_constraint),ott_menhir_loc) -> pp_n_constraint n_constraint +| QI_aux(QI_constant(kinded_id0),ott_menhir_loc) -> separate (string " ") (List.map (function (kinded_id0) -> pp_kinded_id kinded_id0) kinded_id0) + +and pp_quant_item x = match x with +| QI_aux(quant_item_aux,l) -> string "(" ^^ pp_quant_item_aux quant_item_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_typquant_aux x = match x with +| TypQ_aux(TypQ_tq(quant_item0),ott_menhir_loc) -> string "(" ^^ string "forall" ^^ string " " ^^ separate (string ",") (List.map (function (quant_item0) -> pp_quant_item quant_item0) quant_item0) ^^ string " " ^^ string "." ^^ string ")" +| TypQ_aux(TypQ_no_forall,ott_menhir_loc) -> string "" + +and pp_typquant x = match x with +| TypQ_aux(typquant_aux,l) -> string "(" ^^ pp_typquant_aux typquant_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_typschm_aux x = match x with +| TypSchm_aux(TypSchm_ts(typquant,typ),ott_menhir_loc) -> string "(" ^^ pp_typquant typquant ^^ string " " ^^ pp_typ typ ^^ string ")" + +and pp_typschm x = match x with +| TypSchm_aux(typschm_aux,l) -> string "(" ^^ pp_typschm_aux typschm_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_type_def x = match x with +| TD_aux(type_def_aux) -> pp_type_def_aux type_def_aux + +and pp_type_def_aux x = match x with +| TD_abbrev(id,typquant,typ_arg) -> string "(" ^^ string "type" ^^ string " " ^^ pp_id id ^^ string " " ^^ pp_typquant typquant ^^ string " " ^^ string "=" ^^ string " " ^^ pp_typ_arg typ_arg ^^ string ")" +| TD_record(id,typquant,typ0_id0,semi_opt) -> string "(" ^^ string "typedef" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ string "const" ^^ string " " ^^ string "struct" ^^ string " " ^^ pp_typquant typquant ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ";") (List.map (function (typ0,id0) -> pp_typ typ0 ^^ string " " ^^ pp_id id0) typ0_id0) ^^ string " " ^^ pp_semi_opt semi_opt ^^ string " " ^^ string "}" ^^ string ")" +| TD_variant(id,typquant,type_union0,semi_opt) -> string "(" ^^ string "typedef" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ string "const" ^^ string " " ^^ string "union" ^^ string " " ^^ pp_typquant typquant ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ";") (List.map (function (type_union0) -> pp_type_union type_union0) type_union0) ^^ string " " ^^ pp_semi_opt semi_opt ^^ string " " ^^ string "}" ^^ string ")" +| TD_enum(id,id0,semi_opt) -> string "(" ^^ string "typedef" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ string "enumerate" ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ";") (List.map (function (id0) -> pp_id id0) id0) ^^ string " " ^^ pp_semi_opt semi_opt ^^ string " " ^^ string "}" ^^ string ")" +| TD_bitfield(id,typ,id0_index_range0) -> string "(" ^^ string "bitfield" ^^ string " " ^^ pp_id id ^^ string " " ^^ string ":" ^^ string " " ^^ pp_typ typ ^^ string " " ^^ string "=" ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (id0,index_range0) -> pp_id id0 ^^ string " " ^^ string ":" ^^ string " " ^^ pp_index_range index_range0) id0_index_range0) ^^ string " " ^^ string "}" ^^ string ")" + +and pp_type_union_aux x = match x with +| Tu_aux(Tu_ty_id(typ,id),ott_menhir_loc) -> string "(" ^^ pp_typ typ ^^ string " " ^^ pp_id id ^^ string ")" + +and pp_type_union x = match x with +| Tu_aux(type_union_aux,l) -> string "(" ^^ pp_type_union_aux type_union_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_index_range_aux x = match x with +| BF_aux(BF_single(nexp),ott_menhir_loc) -> pp_nexp nexp +| BF_aux(BF_range(nexp1,nexp2),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp1 ^^ string " " ^^ string ".." ^^ string " " ^^ pp_nexp nexp2 ^^ string ")" +| BF_aux(BF_concat(index_range1,index_range2),ott_menhir_loc) -> string "(" ^^ pp_index_range index_range1 ^^ string " " ^^ string "," ^^ string " " ^^ pp_index_range index_range2 ^^ string ")" + +and pp_index_range x = match x with +| BF_aux(index_range_aux,l) -> string "(" ^^ pp_index_range_aux index_range_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_lit_aux x = match x with +| L_aux(L_unit,ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ string ")" ^^ string ")" +| L_aux(L_zero,ott_menhir_loc) -> string "bitzero" +| L_aux(L_one,ott_menhir_loc) -> string "bitone" +| L_aux(L_true,ott_menhir_loc) -> string "true" +| L_aux(L_false,ott_menhir_loc) -> string "false" +| L_aux(L_num(num),ott_menhir_loc) -> string num +| L_aux(L_hex(hex),ott_menhir_loc) -> string hex +| L_aux(L_bin(bin),ott_menhir_loc) -> string bin +| L_aux(L_string(string),ott_menhir_loc) -> string string +| L_aux(L_undef,ott_menhir_loc) -> string "undefined" +| L_aux(L_real(real),ott_menhir_loc) -> string real + +and pp_lit x = match x with +| L_aux(lit_aux,l) -> string "(" ^^ pp_lit_aux lit_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_semi_opt_default + +and pp_typ_pat_aux x = match x with +| TP_aux(TP_wild,ott_menhir_loc) -> string "_" +| TP_aux(TP_var(kid),ott_menhir_loc) -> pp_kid kid +| TP_aux(TP_app(id,typ_pat0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (typ_pat0) -> pp_typ_pat typ_pat0) typ_pat0) ^^ string " " ^^ string ")" ^^ string ")" + +and pp_typ_pat x = match x with +| TP_aux(typ_pat_aux,l) -> string "(" ^^ pp_typ_pat_aux typ_pat_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_pat_aux x = match x with +| P_aux(P_lit(lit),ott_menhir_loc) -> pp_lit lit +| P_aux(P_wild,ott_menhir_loc) -> string "_" +| P_aux(P_or(pat1,pat2),ott_menhir_loc) -> string "(" ^^ pp_pat pat1 ^^ string " " ^^ string "|" ^^ string " " ^^ pp_pat pat2 ^^ string ")" +| P_aux(P_not(pat),ott_menhir_loc) -> string "(" ^^ string "~" ^^ string " " ^^ pp_pat pat ^^ string ")" +| P_aux(P_as(pat,id),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ pp_pat pat ^^ string " " ^^ string "as" ^^ string " " ^^ pp_id id ^^ string " " ^^ string ")" ^^ string ")" +| P_aux(P_typ(typ,pat),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ pp_typ typ ^^ string " " ^^ string ")" ^^ string " " ^^ pp_pat pat ^^ string ")" +| P_aux(P_id(id),ott_menhir_loc) -> pp_id id +| P_aux(P_var(pat,typ_pat),ott_menhir_loc) -> string "(" ^^ pp_pat pat ^^ string " " ^^ pp_typ_pat typ_pat ^^ string ")" +| P_aux(P_app(id,pat0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (pat0) -> pp_pat pat0) pat0) ^^ string " " ^^ string ")" ^^ string ")" +| P_aux(P_vector(pat0),ott_menhir_loc) -> string "(" ^^ string "[" ^^ string " " ^^ separate (string ",") (List.map (function (pat0) -> pp_pat pat0) pat0) ^^ string " " ^^ string "]" ^^ string ")" +| P_aux(P_vector_concat(pat0),ott_menhir_loc) -> separate (string "@") (List.map (function (pat0) -> pp_pat pat0) pat0) +| P_aux(P_tup(pat0),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (pat0) -> pp_pat pat0) pat0) ^^ string " " ^^ string ")" ^^ string ")" +| P_aux(P_list(pat0),ott_menhir_loc) -> string "(" ^^ string "[||" ^^ string " " ^^ separate (string ",") (List.map (function (pat0) -> pp_pat pat0) pat0) ^^ string " " ^^ string "||]" ^^ string ")" +| P_aux(P_cons(pat1,pat2),ott_menhir_loc) -> string "(" ^^ pp_pat pat1 ^^ string " " ^^ string "::" ^^ string " " ^^ pp_pat pat2 ^^ string ")" +| P_aux(P_string_append(pat0),ott_menhir_loc) -> separate (string "^^") (List.map (function (pat0) -> pp_pat pat0) pat0) + +and pp_pat x = match x with +| P_aux(pat_aux,annot) -> string "(" ^^ pp_pat_aux pat_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_loop_default + +and pp_internal_loop_measure_aux x = match x with +| Measure_aux(Measure_none,ott_menhir_loc) -> string "" +| Measure_aux(Measure_some(exp),ott_menhir_loc) -> string "(" ^^ string "termination_measure" ^^ string " " ^^ string "{" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "}" ^^ string ")" + +and pp_internal_loop_measure x = match x with +| Measure_aux(internal_loop_measure_aux,l) -> string "(" ^^ pp_internal_loop_measure_aux internal_loop_measure_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_exp_aux x = match x with +| E_aux(E_block(exp0),ott_menhir_loc) -> string "(" ^^ string "{" ^^ string " " ^^ separate (string ";") (List.map (function (exp0) -> pp_exp exp0) exp0) ^^ string " " ^^ string "}" ^^ string ")" +| E_aux(E_id(id),ott_menhir_loc) -> pp_id id +| E_aux(E_lit(lit),ott_menhir_loc) -> pp_lit lit +| E_aux(E_cast(typ,exp),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ pp_typ typ ^^ string " " ^^ string ")" ^^ string " " ^^ pp_exp exp ^^ string ")" +| E_aux(E_app(id,exp0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (exp0) -> pp_exp exp0) exp0) ^^ string " " ^^ string ")" ^^ string ")" +| E_aux(E_app_infix(exp1,id,exp2),ott_menhir_loc) -> string "(" ^^ pp_exp exp1 ^^ string " " ^^ pp_id id ^^ string " " ^^ pp_exp exp2 ^^ string ")" +| E_aux(E_tuple(exp0),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (exp0) -> pp_exp exp0) exp0) ^^ string " " ^^ string ")" ^^ string ")" +| E_aux(E_if(exp1,exp2,exp3),ott_menhir_loc) -> string "(" ^^ string "if" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string "then" ^^ string " " ^^ pp_exp exp2 ^^ string " " ^^ string "else" ^^ string " " ^^ pp_exp exp3 ^^ string ")" +| E_aux(E_loop(loop,internal_loop_measure,exp1,exp2),ott_menhir_loc) -> string "(" ^^ pp_loop loop ^^ string " " ^^ pp_internal_loop_measure internal_loop_measure ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ pp_exp exp2 ^^ string ")" +| E_aux(E_for(id,exp1,exp2,exp3,order,exp4),ott_menhir_loc) -> string "(" ^^ string "foreach" ^^ string " " ^^ string "(" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "from" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string "to" ^^ string " " ^^ pp_exp exp2 ^^ string " " ^^ string "by" ^^ string " " ^^ pp_exp exp3 ^^ string " " ^^ string "in" ^^ string " " ^^ pp_order order ^^ string " " ^^ string ")" ^^ string " " ^^ pp_exp exp4 ^^ string ")" +| E_aux(E_vector(exp0),ott_menhir_loc) -> string "(" ^^ string "[" ^^ string " " ^^ separate (string ",") (List.map (function (exp0) -> pp_exp exp0) exp0) ^^ string " " ^^ string "]" ^^ string ")" +| E_aux(E_vector_access(exp,exp_prime),ott_menhir_loc) -> string "(" ^^ pp_exp exp ^^ string " " ^^ string "[" ^^ string " " ^^ pp_exp exp_prime ^^ string " " ^^ string "]" ^^ string ")" +| E_aux(E_vector_subrange(exp,exp1,exp2),ott_menhir_loc) -> string "(" ^^ pp_exp exp ^^ string " " ^^ string "[" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string ".." ^^ string " " ^^ pp_exp exp2 ^^ string " " ^^ string "]" ^^ string ")" +| E_aux(E_vector_update(exp,exp1,exp2),ott_menhir_loc) -> string "(" ^^ string "[" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "with" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp2 ^^ string " " ^^ string "]" ^^ string ")" +| E_aux(E_vector_update_subrange(exp,exp1,exp2,exp3),ott_menhir_loc) -> string "(" ^^ string "[" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "with" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string ".." ^^ string " " ^^ pp_exp exp2 ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp3 ^^ string " " ^^ string "]" ^^ string ")" +| E_aux(E_vector_append(exp1,exp2),ott_menhir_loc) -> string "(" ^^ pp_exp exp1 ^^ string " " ^^ string "@" ^^ string " " ^^ pp_exp exp2 ^^ string ")" +| E_aux(E_list(exp0),ott_menhir_loc) -> string "(" ^^ string "[|" ^^ string " " ^^ separate (string ",") (List.map (function (exp0) -> pp_exp exp0) exp0) ^^ string " " ^^ string "|]" ^^ string ")" +| E_aux(E_cons(exp1,exp2),ott_menhir_loc) -> string "(" ^^ pp_exp exp1 ^^ string " " ^^ string "::" ^^ string " " ^^ pp_exp exp2 ^^ string ")" +| E_aux(E_record(fexp0),ott_menhir_loc) -> string "(" ^^ string "struct" ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (fexp0) -> pp_fexp fexp0) fexp0) ^^ string " " ^^ string "}" ^^ string ")" +| E_aux(E_record_update(exp,fexp0),ott_menhir_loc) -> string "(" ^^ string "{" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "with" ^^ string " " ^^ separate (string ",") (List.map (function (fexp0) -> pp_fexp fexp0) fexp0) ^^ string " " ^^ string "}" ^^ string ")" +| E_aux(E_field(exp,id),ott_menhir_loc) -> string "(" ^^ pp_exp exp ^^ string " " ^^ string "." ^^ string " " ^^ pp_id id ^^ string ")" +| E_aux(E_case(exp,pexp0),ott_menhir_loc) -> string "(" ^^ string "match" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (pexp0) -> pp_pexp pexp0) pexp0) ^^ string " " ^^ string "}" ^^ string ")" +| E_aux(E_let(letbind,exp),ott_menhir_loc) -> string "(" ^^ pp_letbind letbind ^^ string " " ^^ string "in" ^^ string " " ^^ pp_exp exp ^^ string ")" +| E_aux(E_assign(lexp,exp),ott_menhir_loc) -> string "(" ^^ pp_lexp lexp ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" +| E_aux(E_sizeof(nexp),ott_menhir_loc) -> string "(" ^^ string "sizeof" ^^ string " " ^^ pp_nexp nexp ^^ string ")" +| E_aux(E_return(exp),ott_menhir_loc) -> string "(" ^^ string "return" ^^ string " " ^^ pp_exp exp ^^ string ")" +| E_aux(E_exit(exp),ott_menhir_loc) -> string "(" ^^ string "exit" ^^ string " " ^^ pp_exp exp ^^ string ")" +| E_aux(E_ref(id),ott_menhir_loc) -> string "(" ^^ string "ref" ^^ string " " ^^ pp_id id ^^ string ")" +| E_aux(E_throw(exp),ott_menhir_loc) -> string "(" ^^ string "throw" ^^ string " " ^^ pp_exp exp ^^ string ")" +| E_aux(E_try(exp,pexp0),ott_menhir_loc) -> string "(" ^^ string "try" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "catch" ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (pexp0) -> pp_pexp pexp0) pexp0) ^^ string " " ^^ string "}" ^^ string ")" +| E_aux(E_assert(exp,exp_prime),ott_menhir_loc) -> string "(" ^^ string "assert" ^^ string " " ^^ string "(" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "," ^^ string " " ^^ pp_exp exp_prime ^^ string " " ^^ string ")" ^^ string ")" +| E_aux(E_var(lexp,exp,exp_prime),ott_menhir_loc) -> string "(" ^^ string "var" ^^ string " " ^^ pp_lexp lexp ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "in" ^^ string " " ^^ pp_exp exp_prime ^^ string ")" +| E_aux(E_internal_plet(pat,exp,exp_prime),ott_menhir_loc) -> string "(" ^^ string "let" ^^ string " " ^^ pp_pat pat ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "in" ^^ string " " ^^ pp_exp exp_prime ^^ string ")" +| E_aux(E_internal_return(exp),ott_menhir_loc) -> string "(" ^^ string "return_int" ^^ string " " ^^ string "(" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string ")" ^^ string ")" +| E_aux(E_internal_value(value),ott_menhir_loc) -> string value +| E_aux(E_constraint(n_constraint),ott_menhir_loc) -> string "(" ^^ string "constraint" ^^ string " " ^^ pp_n_constraint n_constraint ^^ string ")" + +and pp_exp x = match x with +| E_aux(exp_aux,annot) -> string "(" ^^ pp_exp_aux exp_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_lexp_aux x = match x with +| LEXP_aux(LEXP_id(id),ott_menhir_loc) -> pp_id id +| LEXP_aux(LEXP_deref(exp),ott_menhir_loc) -> string "(" ^^ string "deref" ^^ string " " ^^ pp_exp exp ^^ string ")" +| LEXP_aux(LEXP_memory(id,exp0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (exp0) -> pp_exp exp0) exp0) ^^ string " " ^^ string ")" ^^ string ")" +| LEXP_aux(LEXP_cast(typ,id),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ pp_typ typ ^^ string " " ^^ string ")" ^^ string " " ^^ pp_id id ^^ string ")" +| LEXP_aux(LEXP_tup(lexp0),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (lexp0) -> pp_lexp lexp0) lexp0) ^^ string " " ^^ string ")" ^^ string ")" +| LEXP_aux(LEXP_vector_concat(lexp0),ott_menhir_loc) -> separate (string "@") (List.map (function (lexp0) -> pp_lexp lexp0) lexp0) +| LEXP_aux(LEXP_vector(lexp,exp),ott_menhir_loc) -> string "(" ^^ pp_lexp lexp ^^ string " " ^^ string "[" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "]" ^^ string ")" +| LEXP_aux(LEXP_vector_range(lexp,exp1,exp2),ott_menhir_loc) -> string "(" ^^ pp_lexp lexp ^^ string " " ^^ string "[" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string ".." ^^ string " " ^^ pp_exp exp2 ^^ string " " ^^ string "]" ^^ string ")" +| LEXP_aux(LEXP_field(lexp,id),ott_menhir_loc) -> string "(" ^^ pp_lexp lexp ^^ string " " ^^ string "." ^^ string " " ^^ pp_id id ^^ string ")" + +and pp_lexp x = match x with +| LEXP_aux(lexp_aux,annot) -> string "(" ^^ pp_lexp_aux lexp_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_fexp_aux x = match x with +| FE_aux(FE_Fexp(id,exp),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_fexp x = match x with +| FE_aux(fexp_aux,annot) -> string "(" ^^ pp_fexp_aux fexp_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_opt_default_aux x = match x with +| Def_val_aux(Def_val_empty,ott_menhir_loc) -> string "" +| Def_val_aux(Def_val_dec(exp),ott_menhir_loc) -> string "(" ^^ string ";" ^^ string " " ^^ string "default" ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_opt_default x = match x with +| Def_val_aux(opt_default_aux,annot) -> string "(" ^^ pp_opt_default_aux opt_default_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_pexp_aux x = match x with +| Pat_aux(Pat_exp(pat,exp),ott_menhir_loc) -> string "(" ^^ pp_pat pat ^^ string " " ^^ string "->" ^^ string " " ^^ pp_exp exp ^^ string ")" +| Pat_aux(Pat_when(pat,exp1,exp),ott_menhir_loc) -> string "(" ^^ pp_pat pat ^^ string " " ^^ string "when" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string "->" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_pexp x = match x with +| Pat_aux(pexp_aux,annot) -> string "(" ^^ pp_pexp_aux pexp_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_tannot_opt_aux x = match x with +| Typ_annot_opt_aux(Typ_annot_opt_none,ott_menhir_loc) -> string "" +| Typ_annot_opt_aux(Typ_annot_opt_some(typquant,typ),ott_menhir_loc) -> string "(" ^^ pp_typquant typquant ^^ string " " ^^ pp_typ typ ^^ string ")" + +and pp_tannot_opt x = match x with +| Typ_annot_opt_aux(tannot_opt_aux,l) -> string "(" ^^ pp_tannot_opt_aux tannot_opt_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_rec_opt_aux x = match x with +| Rec_aux(Rec_nonrec,ott_menhir_loc) -> string "" +| Rec_aux(Rec_rec,ott_menhir_loc) -> string "rec" +| Rec_aux(Rec_measure(pat,exp),ott_menhir_loc) -> string "(" ^^ string "{" ^^ string " " ^^ pp_pat pat ^^ string " " ^^ string "->" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "}" ^^ string ")" + +and pp_rec_opt x = match x with +| Rec_aux(rec_opt_aux,l) -> string "(" ^^ pp_rec_opt_aux rec_opt_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_effect_opt_aux x = match x with +| Effect_opt_aux(Effect_opt_none,ott_menhir_loc) -> string "" +| Effect_opt_aux(Effect_opt_effect(effect),ott_menhir_loc) -> string "(" ^^ string "effectkw" ^^ string " " ^^ pp_effect effect ^^ string ")" + +and pp_effect_opt x = match x with +| Effect_opt_aux(effect_opt_aux,l) -> string "(" ^^ pp_effect_opt_aux effect_opt_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_pexp_funcl x = match x with +| Pat_funcl_exp(pat,exp) -> string "(" ^^ pp_pat pat ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" +| Pat_funcl_when(pat,exp1,exp) -> string "(" ^^ string "(" ^^ string " " ^^ pp_pat pat ^^ string " " ^^ string "when" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string ")" ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_funcl_aux x = match x with +| FCL_aux(FCL_Funcl(id,pexp_funcl),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ pp_pexp_funcl pexp_funcl ^^ string ")" + +and pp_funcl x = match x with +| FCL_aux(funcl_aux,annot) -> string "(" ^^ pp_funcl_aux funcl_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_fundef_aux x = match x with +| FD_aux(FD_function(rec_opt,tannot_opt,effect_opt,funcl0),ott_menhir_loc) -> string "(" ^^ string "function" ^^ string " " ^^ pp_rec_opt rec_opt ^^ string " " ^^ pp_tannot_opt tannot_opt ^^ string " " ^^ pp_effect_opt effect_opt ^^ string " " ^^ separate (string "and") (List.map (function (funcl0) -> pp_funcl funcl0) funcl0) ^^ string ")" + +and pp_fundef x = match x with +| FD_aux(fundef_aux,annot) -> string "(" ^^ pp_fundef_aux fundef_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_mpat_aux x = match x with +| MP_aux(MP_lit(lit),ott_menhir_loc) -> pp_lit lit +| MP_aux(MP_id(id),ott_menhir_loc) -> pp_id id +| MP_aux(MP_app(id,mpat0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (mpat0) -> pp_mpat mpat0) mpat0) ^^ string " " ^^ string ")" ^^ string ")" +| MP_aux(MP_vector(mpat0),ott_menhir_loc) -> string "(" ^^ string "[" ^^ string " " ^^ separate (string ",") (List.map (function (mpat0) -> pp_mpat mpat0) mpat0) ^^ string " " ^^ string "]" ^^ string ")" +| MP_aux(MP_vector_concat(mpat0),ott_menhir_loc) -> separate (string "@") (List.map (function (mpat0) -> pp_mpat mpat0) mpat0) +| MP_aux(MP_tup(mpat0),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (mpat0) -> pp_mpat mpat0) mpat0) ^^ string " " ^^ string ")" ^^ string ")" +| MP_aux(MP_list(mpat0),ott_menhir_loc) -> string "(" ^^ string "[||" ^^ string " " ^^ separate (string ",") (List.map (function (mpat0) -> pp_mpat mpat0) mpat0) ^^ string " " ^^ string "||]" ^^ string ")" +| MP_aux(MP_cons(mpat1,mpat2),ott_menhir_loc) -> string "(" ^^ pp_mpat mpat1 ^^ string " " ^^ string "::" ^^ string " " ^^ pp_mpat mpat2 ^^ string ")" +| MP_aux(MP_string_append(mpat0),ott_menhir_loc) -> separate (string "^^") (List.map (function (mpat0) -> pp_mpat mpat0) mpat0) +| MP_aux(MP_typ(mpat,typ),ott_menhir_loc) -> string "(" ^^ pp_mpat mpat ^^ string " " ^^ string ":" ^^ string " " ^^ pp_typ typ ^^ string ")" +| MP_aux(MP_as(mpat,id),ott_menhir_loc) -> string "(" ^^ pp_mpat mpat ^^ string " " ^^ string "as" ^^ string " " ^^ pp_id id ^^ string ")" + +and pp_mpat x = match x with +| MP_aux(mpat_aux,annot) -> string "(" ^^ pp_mpat_aux mpat_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_mpexp_aux x = match x with +| MPat_aux(MPat_pat(mpat),ott_menhir_loc) -> pp_mpat mpat +| MPat_aux(MPat_when(mpat,exp),ott_menhir_loc) -> string "(" ^^ pp_mpat mpat ^^ string " " ^^ string "when" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_mpexp x = match x with +| MPat_aux(mpexp_aux,annot) -> string "(" ^^ pp_mpexp_aux mpexp_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_mapcl_aux x = match x with +| MCL_aux(MCL_bidir(mpexp1,mpexp2),ott_menhir_loc) -> string "(" ^^ pp_mpexp mpexp1 ^^ string " " ^^ string "<->" ^^ string " " ^^ pp_mpexp mpexp2 ^^ string ")" +| MCL_aux(MCL_forwards(mpexp,exp),ott_menhir_loc) -> string "(" ^^ pp_mpexp mpexp ^^ string " " ^^ string "=>" ^^ string " " ^^ pp_exp exp ^^ string ")" +| MCL_aux(MCL_backwards(mpexp,exp),ott_menhir_loc) -> string "(" ^^ pp_mpexp mpexp ^^ string " " ^^ string "<-" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_mapcl x = match x with +| MCL_aux(mapcl_aux,annot) -> string "(" ^^ pp_mapcl_aux mapcl_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_mapdef_aux x = match x with +| MD_aux(MD_mapping(id,tannot_opt,mapcl0),ott_menhir_loc) -> string "(" ^^ string "mapping" ^^ string " " ^^ pp_id id ^^ string " " ^^ pp_tannot_opt tannot_opt ^^ string " " ^^ string "=" ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (mapcl0) -> pp_mapcl mapcl0) mapcl0) ^^ string " " ^^ string "}" ^^ string ")" + +and pp_mapdef x = match x with +| MD_aux(mapdef_aux,annot) -> string "(" ^^ pp_mapdef_aux mapdef_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_letbind_aux x = match x with +| LB_aux(LB_val(pat,exp),ott_menhir_loc) -> string "(" ^^ string "let" ^^ string " " ^^ pp_pat pat ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_letbind x = match x with +| LB_aux(letbind_aux,annot) -> string "(" ^^ pp_letbind_aux letbind_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_val_spec x = match x with +| VS_aux(val_spec_aux) -> pp_val_spec_aux val_spec_aux + +and pp_val_spec_aux x = match x with + +and pp_default_spec_aux x = match x with +| DT_aux(DT_order(order),ott_menhir_loc) -> string "(" ^^ string "default" ^^ string " " ^^ string "Order" ^^ string " " ^^ pp_order order ^^ string ")" + +and pp_default_spec x = match x with +| DT_aux(default_spec_aux,l) -> string "(" ^^ pp_default_spec_aux default_spec_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_scattered_def_aux x = match x with +| SD_aux(SD_function(rec_opt,tannot_opt,effect_opt,id),ott_menhir_loc) -> string "(" ^^ string "scattered" ^^ string " " ^^ string "function" ^^ string " " ^^ pp_rec_opt rec_opt ^^ string " " ^^ pp_tannot_opt tannot_opt ^^ string " " ^^ pp_effect_opt effect_opt ^^ string " " ^^ pp_id id ^^ string ")" +| SD_aux(SD_funcl(funcl),ott_menhir_loc) -> string "(" ^^ string "function" ^^ string " " ^^ string "clause" ^^ string " " ^^ pp_funcl funcl ^^ string ")" +| SD_aux(SD_variant(id,typquant),ott_menhir_loc) -> string "(" ^^ string "scattered" ^^ string " " ^^ string "typedef" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ string "const" ^^ string " " ^^ string "union" ^^ string " " ^^ pp_typquant typquant ^^ string ")" +| SD_aux(SD_unioncl(id,type_union),ott_menhir_loc) -> string "(" ^^ string "union" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "member" ^^ string " " ^^ pp_type_union type_union ^^ string ")" +| SD_aux(SD_mapping(id,tannot_opt),ott_menhir_loc) -> string "(" ^^ string "scattered" ^^ string " " ^^ string "mapping" ^^ string " " ^^ pp_id id ^^ string " " ^^ string ":" ^^ string " " ^^ pp_tannot_opt tannot_opt ^^ string ")" +| SD_aux(SD_mapcl(id,mapcl),ott_menhir_loc) -> string "(" ^^ string "mapping" ^^ string " " ^^ string "clause" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ pp_mapcl mapcl ^^ string ")" +| SD_aux(SD_end(id),ott_menhir_loc) -> string "(" ^^ string "end" ^^ string " " ^^ pp_id id ^^ string ")" + +and pp_scattered_def x = match x with +| SD_aux(scattered_def_aux,annot) -> string "(" ^^ pp_scattered_def_aux scattered_def_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_reg_id_aux x = match x with +| RI_aux(RI_id(id),ott_menhir_loc) -> pp_id id + +and pp_reg_id x = match x with +| RI_aux(reg_id_aux,annot) -> string "(" ^^ pp_reg_id_aux reg_id_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_alias_spec_aux x = match x with +| AL_aux(AL_subreg(reg_id,id),ott_menhir_loc) -> string "(" ^^ pp_reg_id reg_id ^^ string " " ^^ string "." ^^ string " " ^^ pp_id id ^^ string ")" +| AL_aux(AL_bit(reg_id,exp),ott_menhir_loc) -> string "(" ^^ pp_reg_id reg_id ^^ string " " ^^ string "[" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "]" ^^ string ")" +| AL_aux(AL_slice(reg_id,exp,exp_prime),ott_menhir_loc) -> string "(" ^^ pp_reg_id reg_id ^^ string " " ^^ string "[" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string ".." ^^ string " " ^^ pp_exp exp_prime ^^ string " " ^^ string "]" ^^ string ")" +| AL_aux(AL_concat(reg_id,reg_id_prime),ott_menhir_loc) -> string "(" ^^ pp_reg_id reg_id ^^ string " " ^^ string ":" ^^ string " " ^^ pp_reg_id reg_id_prime ^^ string ")" + +and pp_alias_spec x = match x with +| AL_aux(alias_spec_aux,annot) -> string "(" ^^ pp_alias_spec_aux alias_spec_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_dec_spec_aux x = match x with +| DEC_aux(DEC_reg(effect,effect_prime,typ,id),ott_menhir_loc) -> string "(" ^^ string "register" ^^ string " " ^^ pp_effect effect ^^ string " " ^^ pp_effect effect_prime ^^ string " " ^^ pp_typ typ ^^ string " " ^^ pp_id id ^^ string ")" +| DEC_aux(DEC_config(id,typ,exp),ott_menhir_loc) -> string "(" ^^ string "register" ^^ string " " ^^ string "configuration" ^^ string " " ^^ pp_id id ^^ string " " ^^ string ":" ^^ string " " ^^ pp_typ typ ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" +| DEC_aux(DEC_alias(id,alias_spec),ott_menhir_loc) -> string "(" ^^ string "register" ^^ string " " ^^ string "alias" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ pp_alias_spec alias_spec ^^ string ")" +| DEC_aux(DEC_typ_alias(typ,id,alias_spec),ott_menhir_loc) -> string "(" ^^ string "register" ^^ string " " ^^ string "alias" ^^ string " " ^^ pp_typ typ ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ pp_alias_spec alias_spec ^^ string ")" + +and pp_dec_spec x = match x with +| DEC_aux(dec_spec_aux,annot) -> string "(" ^^ pp_dec_spec_aux dec_spec_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_prec x = match x with +| Infix -> string "infix" +| InfixL -> string "infixl" +| InfixR -> string "infixr" + +and pp_loop_measure x = match x with +| Loop(loop,exp) -> string "(" ^^ pp_loop loop ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_def x = match x with +| DEF_type(type_def) -> pp_type_def type_def +| DEF_fundef(fundef) -> pp_fundef fundef +| DEF_mapdef(mapdef) -> pp_mapdef mapdef +| DEF_val(letbind) -> pp_letbind letbind +| DEF_spec(val_spec) -> pp_val_spec val_spec +| DEF_fixity(prec,num,id) -> string "(" ^^ string "fix" ^^ string " " ^^ pp_prec prec ^^ string " " ^^ string num ^^ string " " ^^ pp_id id ^^ string ")" +| DEF_overload(id,id0) -> string "(" ^^ string "overload" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "[" ^^ string " " ^^ separate (string ";") (List.map (function (id0) -> pp_id id0) id0) ^^ string " " ^^ string "]" ^^ string ")" +| DEF_default(default_spec) -> pp_default_spec default_spec +| DEF_scattered(scattered_def) -> pp_scattered_def scattered_def +| DEF_measure(id,pat,exp) -> string "(" ^^ string "termination_measure" ^^ string " " ^^ pp_id id ^^ string " " ^^ pp_pat pat ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" +| DEF_loop_measures(id,loop_measure0) -> string "(" ^^ string "termination_measure" ^^ string " " ^^ pp_id id ^^ string " " ^^ separate (string ",") (List.map (function (loop_measure0) -> pp_loop_measure loop_measure0) loop_measure0) ^^ string ")" +| DEF_reg_dec(dec_spec) -> pp_dec_spec dec_spec +| DEF_internal_mutrec(fundef0) -> separate (string " ") (List.map (function (fundef0) -> pp_fundef fundef0) fundef0) +| DEF_pragma(string1,string2,l) -> string "(" ^^ string "$" ^^ string " " ^^ string string1 ^^ string " " ^^ string string2 ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_defs x = match x with +| Defs(def0) -> separate (string " ") (List.map (function (def0) -> pp_def def0) def0) + diff --git a/src/slice.ml b/src/slice.ml index 1ac390bd..c249fb5a 100644 --- a/src/slice.ml +++ b/src/slice.ml @@ -130,7 +130,7 @@ and typ_ids' (Typ_aux (aux, _)) = IdSet.add id (List.fold_left IdSet.union IdSet.empty (List.map typ_arg_ids' args)) | Typ_fn (typs, typ, _) -> IdSet.union (typ_ids' typ) (List.fold_left IdSet.union IdSet.empty (List.map typ_ids' typs)) - | Typ_bidir (typ1, typ2) -> + | Typ_bidir (typ1, typ2, _) -> IdSet.union (typ_ids' typ1) (typ_ids' typ2) | Typ_tup typs -> List.fold_left IdSet.union IdSet.empty (List.map typ_ids' typs) @@ -169,13 +169,23 @@ let add_def_to_graph graph def = let scan_lexp self lexp_aux annot = let env = env_of_annot annot in begin match lexp_aux with - | LEXP_cast (typ, _) -> - IdSet.iter (fun id -> graph := G.add_edge self (Type id) !graph) (typ_ids typ) + | LEXP_cast (typ, id) -> + IdSet.iter (fun id -> graph := G.add_edge self (Type id) !graph) (typ_ids typ); + begin match Env.lookup_id id env with + | Register _ -> + graph := G.add_edge self (Register id) !graph + | Enum _ -> graph := G.add_edge self (Constructor id) !graph + | _ -> + if IdSet.mem id (Env.get_toplevel_lets env) then + graph := G.add_edge self (Letbind id) !graph + else () + end | LEXP_memory (id, _) -> graph := G.add_edge self (Function id) !graph | LEXP_id id -> begin match Env.lookup_id id env with - | Register _ -> graph := G.add_edge self (Register id) !graph + | Register _ -> + graph := G.add_edge self (Register id) !graph | Enum _ -> graph := G.add_edge self (Constructor id) !graph | _ -> if IdSet.mem id (Env.get_toplevel_lets env) then @@ -361,24 +371,20 @@ let () = let slice_roots = ref IdSet.empty in let slice_cuts = ref IdSet.empty in - (fun arg -> + ArgString ("identifiers", fun arg -> Action (fun () -> let args = Str.split (Str.regexp " +") arg in let ids = List.map mk_id args |> IdSet.of_list in Specialize.add_initial_calls ids; slice_roots := IdSet.union ids !slice_roots - ) |> register_command - ~name:"slice_roots" - ~help:(sprintf ":slice_roots %s - Set the roots for %s" (arg "identifiers") (command "slice")); + )) |> register_command ~name:"slice_roots" ~help:"Set the roots for :slice"; - (fun arg -> + ArgString ("identifiers", fun arg -> Action (fun () -> let args = Str.split (Str.regexp " +") arg in let ids = List.map mk_id args |> IdSet.of_list in slice_cuts := IdSet.union ids !slice_cuts - ) |> register_command - ~name:"slice_cuts" - ~help:(sprintf ":slice_cuts %s - Set the roots for %s" (arg "identifiers") (command "slice")); + )) |> register_command ~name:"slice_cuts" ~help:"Set the cuts for :slice"; - (fun arg -> + Action (fun () -> let module NodeSet = Set.Make(Node) in let module G = Graph.Make(Node) in let g = graph_of_ast !ast in @@ -388,10 +394,11 @@ let () = ast := filter_ast cuts g !ast ) |> register_command ~name:"slice" - ~help:(sprintf ":slice - Slice AST to the definitions which the functions given by %s depend on, up to the functions given by %s" - (command "slice_roots") (command "slice_cuts")); + ~help:"Slice AST to the definitions which the functions given \ + by :slice_roots depend on, up to the functions given \ + by :slice_cuts"; - (fun arg -> + Action (fun () -> let module NodeSet = Set.Make(Node) in let module NodeMap = Map.Make(Node) in let module G = Graph.Make(Node) in @@ -409,7 +416,7 @@ let () = ~name:"thin_slice" ~help:(sprintf ":thin_slice - Slice AST to the function definitions given with %s" (command "slice_roots")); - (fun arg -> + ArgString ("format", fun arg -> Action (fun () -> let format = if arg = "" then "svg" else arg in let dotfile, out_chan = Filename.open_temp_file "sail_graph_" ".gz" in let image = Filename.temp_file "sail_graph_" ("." ^ format) in @@ -418,9 +425,8 @@ let () = let _ = Unix.system (Printf.sprintf "dot -T%s %s -o %s" format dotfile image) in let _ = Unix.system (Printf.sprintf "xdg-open %s" image) in () - ) |> register_command - ~name:"graph" - ~help:(sprintf ":graph %s - Draw a callgraph using dot in %s (default svg if none provided), and open with xdg-open" - (arg "format") (arg "format")); + )) |> register_command + ~name:"graph" + ~help:"Draw a callgraph using dot in :0 (e.g. svg), and open with xdg-open" diff --git a/src/smtlib.ml b/src/smtlib.ml index b90f33a7..e12657c3 100644 --- a/src/smtlib.ml +++ b/src/smtlib.ml @@ -60,6 +60,30 @@ type smt_typ = | Tuple of smt_typ list | Array of smt_typ * smt_typ +let rec smt_typ_compare t1 t2 = + match t1, t2 with + | Bitvec n, Bitvec m -> compare n m + | Bool, Bool -> 0 + | String, String -> 0 + | Real, Real -> 0 + | Datatype (name1, _), Datatype (name2, _) -> String.compare name1 name2 + | Tuple ts1, Tuple ts2 -> Util.lex_ord_list smt_typ_compare ts1 ts2 + | Array (t11, t12), Array (t21, t22) -> + let c = smt_typ_compare t11 t21 in + if c = 0 then smt_typ_compare t12 t22 else c + | Bitvec _, _ -> 1 + | _, Bitvec _ -> -1 + | Bool, _ -> 1 + | _, Bool -> -1 + | String, _ -> 1 + | _, String -> -1 + | Real, _ -> 1 + | _, Real -> -1 + | Datatype _, _ -> 1 + | _, Datatype _ -> -1 + | Tuple _, _ -> 1 + | _, Tuple _ -> -1 + let rec smt_typ_equal t1 t2 = match t1, t2 with | Bitvec n, Bitvec m -> n = m @@ -89,11 +113,11 @@ let mk_variant name ctors = type smt_exp = | Bool_lit of bool - | Hex of string - | Bin of string + | Bitvec_lit of Sail2_values.bitU list | Real_lit of string | String_lit of string | Var of string + | Shared of string | Read_res of string | Enum of string | Fn of string * smt_exp list @@ -102,6 +126,11 @@ type smt_exp = | SignExtend of int * smt_exp | Extract of int * int * smt_exp | Tester of string * smt_exp + | Syntactic of smt_exp * smt_exp list + | Struct of string * (string * smt_exp) list + | Field of string * smt_exp + (* Used by sail-axiomatic, should never be generated by sail -smt! *) + | Forall of (string * smt_typ) list * smt_exp let rec fold_smt_exp f = function | Fn (name, args) -> f (Fn (name, List.map (fold_smt_exp f) args)) @@ -110,7 +139,11 @@ let rec fold_smt_exp f = function | SignExtend (n, exp) -> f (SignExtend (n, fold_smt_exp f exp)) | Extract (n, m, exp) -> f (Extract (n, m, fold_smt_exp f exp)) | Tester (ctor, exp) -> f (Tester (ctor, fold_smt_exp f exp)) - | (Bool_lit _ | Hex _ | Bin _ | Real_lit _ | String_lit _ | Var _ | Read_res _ | Enum _ as exp) -> f exp + | Forall (binders, exp) -> f (Forall (binders, fold_smt_exp f exp)) + | Syntactic (exp, exps) -> f (Syntactic (fold_smt_exp f exp, List.map (fold_smt_exp f) exps)) + | Field (name, exp) -> f (Field (name, fold_smt_exp f exp)) + | Struct (name, fields) -> f (Struct (name, List.map (fun (field, exp) -> field, fold_smt_exp f exp) fields)) + | (Bool_lit _ | Bitvec_lit _ | Real_lit _ | String_lit _ | Var _ | Shared _ | Read_res _ | Enum _ as exp) -> f exp let smt_conj = function | [] -> Bool_lit true @@ -136,21 +169,13 @@ let bvshl x y = Fn ("bvshl", [x; y]) let bvlshr x y = Fn ("bvlshr", [x; y]) let bvult x y = Fn ("bvult", [x; y]) -let bvzero n = - if n mod 4 = 0 then - Hex (String.concat "" (Util.list_init (n / 4) (fun _ -> "0"))) - else - Bin (String.concat "" (Util.list_init n (fun _ -> "0"))) +let bvzero n = Bitvec_lit (Sail2_operators_bitlists.zeros (Big_int.of_int n)) -let bvones n = - if n mod 4 = 0 then - Hex (String.concat "" (Util.list_init (n / 4) (fun _ -> "F"))) - else - Bin (String.concat "" (Util.list_init n (fun _ -> "1"))) +let bvones n = Bitvec_lit (Sail2_operators_bitlists.ones (Big_int.of_int n)) let simp_equal x y = match x, y with - | Bin str1, Bin str2 -> Some (str1 = str2) + | Bitvec_lit bv1, Bitvec_lit bv2 -> Some (Sail2_operators_bitlists.eq_vec bv1 bv2) | _, _ -> None let simp_and xs = @@ -175,6 +200,16 @@ let simp_or xs = else Fn ("or", xs) +let rec all_bitvec_lit = function + | Bitvec_lit _ :: rest -> all_bitvec_lit rest + | [] -> true + | _ :: _ -> false + +let rec merge_bitvec_lit = function + | Bitvec_lit b :: rest -> b @ merge_bitvec_lit rest + | [] -> [] + | _ :: _ -> assert false + let simp_fn = function | Fn ("not", [Fn ("not", [exp])]) -> exp | Fn ("not", [Bool_lit b]) -> Bool_lit (not b) @@ -184,6 +219,9 @@ let simp_fn = function | Fn ("and", xs) -> simp_and xs | Fn ("=>", [Bool_lit true; y]) -> y | Fn ("=>", [Bool_lit false; y]) -> Bool_lit true + | Fn ("bvsub", [Bitvec_lit bv1; Bitvec_lit bv2]) -> Bitvec_lit (Sail2_operators_bitlists.sub_vec bv1 bv2) + | Fn ("bvadd", [Bitvec_lit bv1; Bitvec_lit bv2]) -> Bitvec_lit (Sail2_operators_bitlists.add_vec bv1 bv2) + | Fn ("concat", xs) when all_bitvec_lit xs -> Bitvec_lit (merge_bitvec_lit xs) | Fn ("=", [x; y]) as exp -> begin match simp_equal x y with | Some b -> Bool_lit b @@ -205,7 +243,16 @@ let rec simp_smt_exp vars kinds = function | Some exp -> simp_smt_exp vars kinds exp | None -> Var v end - | (Read_res _ | Enum _ | Hex _ | Bin _ | Bool_lit _ | String_lit _ | Real_lit _ as exp) -> exp + | (Read_res _ | Shared _ | Enum _ | Bitvec_lit _ | Bool_lit _ | String_lit _ | Real_lit _ as exp) -> exp + | Field (field, exp) -> + let exp = simp_smt_exp vars kinds exp in + begin match exp with + | Struct (_, fields) -> + List.assoc field fields + | _ -> Field (field, exp) + end + | Struct (name, fields) -> + Struct (name, List.map (fun (field, exp) -> field, simp_smt_exp vars kinds exp) fields) | Fn (f, exps) -> let exps = List.map (simp_smt_exp vars kinds) exps in simp_fn (Fn (f, exps)) @@ -220,8 +267,8 @@ let rec simp_smt_exp vars kinds = function | Extract (i, j, exp) -> let exp = simp_smt_exp vars kinds exp in begin match exp with - | Bin str -> - Bin (String.sub str ((String.length str - 1) - i) ((i + 1) - j)) + | Bitvec_lit bv -> + Bitvec_lit (Sail2_operators_bitlists.subrange_vec_dec bv (Big_int.of_int i) (Big_int.of_int j)) | _ -> Extract (i, j, exp) end | Tester (str, exp) -> @@ -235,48 +282,167 @@ let rec simp_smt_exp vars kinds = function end | _ -> Tester (str, exp) end + | Syntactic (exp, _) -> exp | SignExtend (i, exp) -> let exp = simp_smt_exp vars kinds exp in - SignExtend (i, exp) + begin match exp with + | Bitvec_lit bv -> + Bitvec_lit (Sail2_operators_bitlists.sign_extend bv (Big_int.of_int (i + List.length bv))) + | _ -> SignExtend (i, exp) + end + | Forall (binders, exp) -> Forall (binders, exp) + +type read_info = { + name : string; + node : int; + active : smt_exp; + kind : smt_exp; + addr_type : smt_typ; + addr : smt_exp; + ret_type : smt_typ; + doc : string + } + +type write_info = { + name : string; + node : int; + active : smt_exp; + kind : smt_exp; + addr_type : smt_typ; + addr : smt_exp; + data_type : smt_typ; + data : smt_exp; + doc : string + } + +type barrier_info = { + name : string; + node : int; + active : smt_exp; + kind : smt_exp; + doc : string + } + +type branch_info = { + name : string; + node : int; + active : smt_exp; + addr_type : smt_typ; + addr : smt_exp; + doc : string + } + +type cache_op_info = { + name : string; + node : int; + active : smt_exp; + kind : smt_exp; + addr_type : smt_typ; + addr : smt_exp; + doc : string + } type smt_def = | Define_fun of string * (string * smt_typ) list * smt_typ * smt_exp + | Declare_fun of string * smt_typ list * smt_typ | Declare_const of string * smt_typ | Define_const of string * smt_typ * smt_exp - | Write_mem of string * int * smt_exp * smt_exp * smt_exp * smt_typ * smt_exp * smt_typ + (* Same as Define_const, but it'll never be removed by simplification *) + | Preserve_const of string * smt_typ * smt_exp + | Write_mem of write_info | Write_mem_ea of string * int * smt_exp * smt_exp * smt_exp * smt_typ * smt_exp * smt_typ - | Read_mem of string * int * smt_exp * smt_typ * smt_exp * smt_exp * smt_typ - | Barrier of string * int * smt_exp * smt_exp + | Read_mem of read_info + | Barrier of barrier_info + | Branch_announce of branch_info + | Cache_maintenance of cache_op_info | Excl_res of string * int * smt_exp | Declare_datatypes of string * (string * (string * smt_typ) list) list | Declare_tuple of int | Assert of smt_exp +let smt_def_map_exp f = function + | Define_fun (name, args, ty, exp) -> Define_fun (name, args, ty, f exp) + | Declare_fun (name, args, ty) -> Declare_fun (name, args, ty) + | Declare_const (name, ty) -> Declare_const (name, ty) + | Define_const (name, ty, exp) -> Define_const (name, ty, f exp) + | Preserve_const (name, ty, exp) -> Preserve_const (name, ty, f exp) + | Write_mem w -> Write_mem { w with active = f w.active; kind = f w.kind; addr = f w.addr; data = f w.data } + | Write_mem_ea (name, node, active, wk, addr, addr_ty, data_size, data_size_ty) -> + Write_mem_ea (name, node, f active, f wk, f addr, addr_ty, f data_size, data_size_ty) + | Read_mem r -> Read_mem { r with active = f r.active; kind = f r.kind; addr = f r.addr } + | Barrier b -> Barrier { b with active = f b.active; kind = f b.kind } + | Cache_maintenance m -> Cache_maintenance { m with active = f m.active; kind = f m.kind ; addr = f m.addr } + | Branch_announce c -> Branch_announce { c with active = f c.active; addr = f c.addr } + | Excl_res (name, node, active) -> Excl_res (name, node, f active) + | Declare_datatypes (name, ctors) -> Declare_datatypes (name, ctors) + | Declare_tuple n -> Declare_tuple n + | Assert exp -> Assert (f exp) + +let smt_def_iter_exp f = function + | Define_fun (name, args, ty, exp) -> f exp + | Define_const (name, ty, exp) -> f exp + | Preserve_const (name, ty, exp) -> f exp + | Write_mem w -> f w.active; f w.kind; f w.addr; f w.data + | Write_mem_ea (name, node, active, wk, addr, addr_ty, data_size, data_size_ty) -> + f active; f wk; f addr; f data_size + | Read_mem r -> f r.active; f r.kind; f r.addr + | Barrier b -> f b.active; f b.kind + | Cache_maintenance m -> f m.active; f m.kind; f m.addr + | Branch_announce c -> f c.active; f c.addr + | Excl_res (name, node, active) -> f active + | Assert exp -> f exp + | Declare_fun _ | Declare_const _ | Declare_tuple _ | Declare_datatypes _ -> () + let declare_datatypes = function | Datatype (name, ctors) -> Declare_datatypes (name, ctors) | _ -> assert false +(** For generating SMT with multiple threads (i.e. for litmus tests), + we suffix all the variables in the generated SMT with a thread + identifier to avoid any name clashes between the two threads. *) + let suffix_variables_exp sfx = - fold_smt_exp (function Var v -> Var (v ^ sfx) | exp -> exp) + fold_smt_exp (function Var v -> Var (v ^ sfx) | Read_res v -> Read_res (v ^ sfx) | exp -> exp) + +let suffix_variables_read_info sfx (r : read_info) = + let suffix exp = suffix_variables_exp sfx exp in + { r with name = r.name ^ sfx; active = suffix r.active; kind = suffix r.kind; addr = suffix r.addr } + +let suffix_variables_write_info sfx (w : write_info) = + let suffix exp = suffix_variables_exp sfx exp in + { w with name = w.name ^ sfx; active = suffix w.active; kind = suffix w.kind; addr = suffix w.addr; data = suffix w.data } + +let suffix_variables_barrier_info sfx (b : barrier_info) = + let suffix exp = suffix_variables_exp sfx exp in + { b with name = b.name ^ sfx; active = suffix b.active; kind = suffix b.kind } + +let suffix_variables_branch_info sfx (c : branch_info) = + let suffix exp = suffix_variables_exp sfx exp in + { c with name = c.name ^ sfx; active = suffix c.active; addr = suffix c.addr } + +let suffix_variables_cache_op_info sfx (m : cache_op_info) = + let suffix exp = suffix_variables_exp sfx exp in + { m with name = m.name ^ sfx; kind = suffix m.kind; active = suffix m.active; addr = suffix m.addr } let suffix_variables_def sfx = function | Define_fun (name, args, ty, exp) -> Define_fun (name ^ sfx, List.map (fun (arg, ty) -> sfx ^ arg, ty) args, ty, suffix_variables_exp sfx exp) + | Declare_fun (name, tys, ty) -> + Declare_fun (name ^ sfx, tys, ty) | Declare_const (name, ty) -> Declare_const (name ^ sfx, ty) | Define_const (name, ty, exp) -> Define_const (name ^ sfx, ty, suffix_variables_exp sfx exp) - | Write_mem (name, node, active, wk, addr, addr_ty, data, data_ty) -> - Write_mem (name ^ sfx, node, suffix_variables_exp sfx active, suffix_variables_exp sfx wk, - suffix_variables_exp sfx addr, addr_ty, suffix_variables_exp sfx data, data_ty) + | Preserve_const (name, ty, exp) -> + Preserve_const (name, ty, suffix_variables_exp sfx exp) + | Write_mem w -> Write_mem (suffix_variables_write_info sfx w) | Write_mem_ea (name, node, active , wk, addr, addr_ty, data_size, data_size_ty) -> - Write_mem (name ^ sfx, node, suffix_variables_exp sfx active, suffix_variables_exp sfx wk, - suffix_variables_exp sfx addr, addr_ty, suffix_variables_exp sfx data_size, data_size_ty) - | Read_mem (name, node, active, ty, rk, addr, addr_ty) -> - Read_mem (name ^ sfx, node, suffix_variables_exp sfx active, ty, suffix_variables_exp sfx rk, - suffix_variables_exp sfx addr, addr_ty) - | Barrier (name, node, active, bk) -> - Barrier (name ^ sfx, node, suffix_variables_exp sfx active, suffix_variables_exp sfx bk) + Write_mem_ea (name ^ sfx, node, suffix_variables_exp sfx active, suffix_variables_exp sfx wk, + suffix_variables_exp sfx addr, addr_ty, suffix_variables_exp sfx data_size, data_size_ty) + | Read_mem r -> Read_mem (suffix_variables_read_info sfx r) + | Barrier b -> Barrier (suffix_variables_barrier_info sfx b) + | Cache_maintenance m -> Cache_maintenance (suffix_variables_cache_op_info sfx m) + | Branch_announce c -> Branch_announce (suffix_variables_branch_info sfx c) | Excl_res (name, node, active) -> Excl_res (name ^ sfx, node, suffix_variables_exp sfx active) | Declare_datatypes (name, ctors) -> @@ -286,54 +452,37 @@ let suffix_variables_def sfx = function | Assert exp -> Assert (suffix_variables_exp sfx exp) -let merge_datatypes defs1 defs2 = - let module StringSet = Set.Make(String) in - let datatype_name = function - | Declare_datatypes (name, _) -> name - | _ -> assert false - in - let names = List.fold_left (fun set def -> StringSet.add (datatype_name def) set) StringSet.empty defs1 in - defs1 @ List.filter (fun def -> not (StringSet.mem (datatype_name def) names)) defs2 - -let merge_tuples defs1 defs2 = - let tuple_size = function - | Declare_tuple size -> size - | _ -> assert false - in - let names = List.fold_left (fun set def -> Util.IntSet.add (tuple_size def) set) Util.IntSet.empty defs1 in - defs1 @ List.filter (fun def -> not (Util.IntSet.mem (tuple_size def) names)) defs2 - -let merge_smt_defs defs1 defs2 = - let is_tuple = function - | Declare_datatypes _ | Declare_tuple _ -> true - | _ -> false - in - let is_datatype = function - | Declare_datatypes _ | Declare_tuple _ -> true - | _ -> false - in - let datatypes1, body1 = List.partition is_datatype defs1 in - let datatypes2, body2 = List.partition is_datatype defs2 in - let tuples1, datatypes1 = List.partition is_tuple datatypes1 in - let tuples2, datatypes2 = List.partition is_tuple datatypes2 in - merge_tuples tuples1 tuples2 @ merge_datatypes datatypes1 datatypes2 @ body1 @ body2 - let pp_sfun str docs = let open PPrint in parens (separate space (string str :: docs)) +let rec pp_smt_typ = + let open PPrint in + function + | Bool -> string "Bool" + | String -> string "String" + | Real -> string "Real" + | Bitvec n -> string (Printf.sprintf "(_ BitVec %d)" n) + | Datatype (name, _) -> string name + | Tuple tys -> pp_sfun ("Tup" ^ string_of_int (List.length tys)) (List.map pp_smt_typ tys) + | Array (ty1, ty2) -> pp_sfun "Array" [pp_smt_typ ty1; pp_smt_typ ty2] + +let pp_str_smt_typ (str, ty) = let open PPrint in parens (string str ^^ space ^^ pp_smt_typ ty) + let rec pp_smt_exp = let open PPrint in function | Bool_lit b -> string (string_of_bool b) | Real_lit str -> string str | String_lit str -> string ("\"" ^ str ^ "\"") - | Hex str -> string ("#x" ^ str) - | Bin str -> string ("#b" ^ str) + | Bitvec_lit bv -> string (Sail2_values.show_bitlist_prefix '#' bv) | Var str -> string str + | Shared str -> string str | Read_res str -> string (str ^ "_ret") | Enum str -> string str | Fn (str, exps) -> parens (string str ^^ space ^^ separate_map space pp_smt_exp exps) + | Field (str, exp) -> parens (string str ^^ space ^^ pp_smt_exp exp) + | Struct (str, fields) -> parens (string str ^^ space ^^ separate_map space (fun (_, exp) -> pp_smt_exp exp) fields) | Ctor (str, exps) -> parens (string str ^^ space ^^ separate_map space pp_smt_exp exps) | Ite (cond, then_exp, else_exp) -> parens (separate space [string "ite"; pp_smt_exp cond; pp_smt_exp then_exp; pp_smt_exp else_exp]) @@ -343,19 +492,9 @@ let rec pp_smt_exp = parens (string (Printf.sprintf "(_ is %s)" kind) ^^ space ^^ pp_smt_exp exp) | SignExtend (i, exp) -> parens (string (Printf.sprintf "(_ sign_extend %d)" i) ^^ space ^^ pp_smt_exp exp) - -let rec pp_smt_typ = - let open PPrint in - function - | Bool -> string "Bool" - | String -> string "String" - | Real -> string "Real" - | Bitvec n -> string (Printf.sprintf "(_ BitVec %d)" n) - | Datatype (name, _) -> string name - | Tuple tys -> pp_sfun ("Tup" ^ string_of_int (List.length tys)) (List.map pp_smt_typ tys) - | Array (ty1, ty2) -> pp_sfun "Array" [pp_smt_typ ty1; pp_smt_typ ty2] - -let pp_str_smt_typ (str, ty) = let open PPrint in string str ^^ space ^^ pp_smt_typ ty + | Syntactic (exp, _) -> pp_smt_exp exp + | Forall (binders, exp) -> + parens (string "forall" ^^ space ^^ parens (separate_map space pp_str_smt_typ binders) ^^ space ^^ pp_smt_exp exp) let pp_smt_def = let open PPrint in @@ -367,18 +506,23 @@ let pp_smt_def = ^^ space ^^ pp_smt_typ ty ^//^ pp_smt_exp exp) + | Declare_fun (name, args, ty) -> + parens (string "declare-fun" ^^ space ^^ string name + ^^ space ^^ parens (separate_map space pp_smt_typ args) + ^^ space ^^ pp_smt_typ ty) + | Declare_const (name, ty) -> pp_sfun "declare-const" [string name; pp_smt_typ ty] - | Define_const (name, ty, exp) -> + | Define_const (name, ty, exp) | Preserve_const (name, ty, exp) -> pp_sfun "define-const" [string name; pp_smt_typ ty; pp_smt_exp exp] - | Write_mem (name, _, active, wk, addr, addr_ty, data, data_ty) -> - pp_sfun "define-const" [string (name ^ "_kind"); string "Zwrite_kind"; pp_smt_exp wk] ^^ hardline - ^^ pp_sfun "define-const" [string (name ^ "_active"); pp_smt_typ Bool; pp_smt_exp active] ^^ hardline - ^^ pp_sfun "define-const" [string (name ^ "_data"); pp_smt_typ data_ty; pp_smt_exp data] ^^ hardline - ^^ pp_sfun "define-const" [string (name ^ "_addr"); pp_smt_typ addr_ty; pp_smt_exp addr] ^^ hardline - ^^ pp_sfun "declare-const" [string (name ^ "_ret"); pp_smt_typ Bool] + | Write_mem w -> + pp_sfun "define-const" [string (w.name ^ "_kind"); string "Zwrite_kind"; pp_smt_exp w.kind] ^^ hardline + ^^ pp_sfun "define-const" [string (w.name ^ "_active"); pp_smt_typ Bool; pp_smt_exp w.active] ^^ hardline + ^^ pp_sfun "define-const" [string (w.name ^ "_data"); pp_smt_typ w.data_type; pp_smt_exp w.data] ^^ hardline + ^^ pp_sfun "define-const" [string (w.name ^ "_addr"); pp_smt_typ w.addr_type; pp_smt_exp w.addr] ^^ hardline + ^^ pp_sfun "declare-const" [string (w.name ^ "_ret"); pp_smt_typ Bool] | Write_mem_ea (name, _, active, wk, addr, addr_ty, data_size, data_size_ty) -> pp_sfun "define-const" [string (name ^ "_kind"); string "Zwrite_kind"; pp_smt_exp wk] ^^ hardline @@ -386,15 +530,24 @@ let pp_smt_def = ^^ pp_sfun "define-const" [string (name ^ "_size"); pp_smt_typ data_size_ty; pp_smt_exp data_size] ^^ hardline ^^ pp_sfun "define-const" [string (name ^ "_addr"); pp_smt_typ addr_ty; pp_smt_exp addr] - | Read_mem (name, _, active, ty, rk, addr, addr_ty) -> - pp_sfun "define-const" [string (name ^ "_kind"); string "Zread_kind"; pp_smt_exp rk] ^^ hardline - ^^ pp_sfun "define-const" [string (name ^ "_active"); pp_smt_typ Bool; pp_smt_exp active] ^^ hardline - ^^ pp_sfun "define-const" [string (name ^ "_addr"); pp_smt_typ addr_ty; pp_smt_exp addr] ^^ hardline - ^^ pp_sfun "declare-const" [string (name ^ "_ret"); pp_smt_typ ty] + | Read_mem r -> + pp_sfun "define-const" [string (r.name ^ "_kind"); string "Zread_kind"; pp_smt_exp r.kind] ^^ hardline + ^^ pp_sfun "define-const" [string (r.name ^ "_active"); pp_smt_typ Bool; pp_smt_exp r.active] ^^ hardline + ^^ pp_sfun "define-const" [string (r.name ^ "_addr"); pp_smt_typ r.addr_type; pp_smt_exp r.addr] ^^ hardline + ^^ pp_sfun "declare-const" [string (r.name ^ "_ret"); pp_smt_typ r.ret_type] - | Barrier (name, _, active, bk) -> - pp_sfun "define-const" [string (name ^ "_kind"); string "Zbarrier_kind"; pp_smt_exp bk] ^^ hardline - ^^ pp_sfun "define-const" [string (name ^ "_active"); pp_smt_typ Bool; pp_smt_exp active] + | Barrier b -> + pp_sfun "define-const" [string (b.name ^ "_kind"); string "Zbarrier_kind"; pp_smt_exp b.kind] ^^ hardline + ^^ pp_sfun "define-const" [string (b.name ^ "_active"); pp_smt_typ Bool; pp_smt_exp b.active] + + | Cache_maintenance m -> + pp_sfun "define-const" [string (m.name ^ "_active"); pp_smt_typ Bool; pp_smt_exp m.active] ^^ hardline + ^^ pp_sfun "define-const" [string (m.name ^ "_kind"); string "Zcache_op_kind"; pp_smt_exp m.kind] ^^ hardline + ^^ pp_sfun "define-const" [string (m.name ^ "_addr"); pp_smt_typ m.addr_type; pp_smt_exp m.addr] + + | Branch_announce c -> + pp_sfun "define-const" [string (c.name ^ "_active"); pp_smt_typ Bool; pp_smt_exp c.active] ^^ hardline + ^^ pp_sfun "define-const" [string (c.name ^ "_addr"); pp_smt_typ c.addr_type; pp_smt_exp c.addr] | Excl_res (name, _, active) -> pp_sfun "declare-const" [string (name ^ "_res"); pp_smt_typ Bool] ^^ hardline @@ -404,7 +557,7 @@ let pp_smt_def = let pp_ctor (ctor_name, fields) = match fields with | [] -> parens (string ctor_name) - | _ -> pp_sfun ctor_name (List.map (fun field -> parens (pp_str_smt_typ field)) fields) + | _ -> pp_sfun ctor_name (List.map pp_str_smt_typ fields) in pp_sfun "declare-datatypes" [Printf.ksprintf string "((%s 0))" name; @@ -529,7 +682,7 @@ let check_counterexample ast env fname function_id args arg_ctyps arg_smt_names prerr_endline (sprintf "Solver found counterexample: %s" Util.("ok" |> green |> clear)); let counterexample = build_counterexample args arg_ctyps arg_smt_names model in List.iter (fun (id, v) -> prerr_endline (" " ^ string_of_id id ^ " -> " ^ string_of_value v)) counterexample; - let istate = initial_state ast env primops in + let istate = initial_state ast env !primops in let annot = (Parse_ast.Unknown, Type_check.mk_tannot env bool_typ no_effect) in let call = E_aux (E_app (function_id, List.map (fun (_, v) -> E_aux (E_internal_value v, (Parse_ast.Unknown, Type_check.empty_tannot))) counterexample), annot) in let result = run (Step (lazy "", istate, return call, [])) in diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 40855eec..75f2ff6e 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -89,8 +89,8 @@ let rec free_type_names_t consider_var (Typ_aux (t, l)) = match t with | Typ_id name -> Nameset.add (string_of_id name) mt | Typ_fn (arg_typs,ret_typ,_) -> List.fold_left Nameset.union (free_type_names_t consider_var ret_typ) (List.map (free_type_names_t consider_var) arg_typs) - | Typ_bidir (t1, t2) -> Nameset.union (free_type_names_t consider_var t1) - (free_type_names_t consider_var t2) + | Typ_bidir (t1,t2,_) -> Nameset.union (free_type_names_t consider_var t1) + (free_type_names_t consider_var t2) | Typ_tup ts -> free_type_names_ts consider_var ts | Typ_app (name,targs) -> Nameset.add (string_of_id name) (free_type_names_t_args consider_var targs) | Typ_exist (kopts,_,t') -> List.fold_left (fun s kopt -> Nameset.remove (string_of_kid (kopt_kid kopt)) s) (free_type_names_t consider_var t') kopts @@ -121,7 +121,7 @@ let rec fv_of_typ consider_var bound used (Typ_aux (t,l)) : Nameset.t = | Typ_id id -> conditional_add_typ bound used id | Typ_fn(arg,ret,_) -> fv_of_typ consider_var bound (List.fold_left Nameset.union Nameset.empty (List.map (fv_of_typ consider_var bound used) arg)) ret - | Typ_bidir(t1, t2) -> fv_of_typ consider_var bound (fv_of_typ consider_var bound used t1) t2 (* TODO FIXME? *) + | Typ_bidir(t1,t2,_) -> fv_of_typ consider_var bound (fv_of_typ consider_var bound used t1) t2 (* TODO FIXME? *) | Typ_tup ts -> List.fold_right (fun t n -> fv_of_typ consider_var bound n t) ts used | Typ_app(id,targs) -> List.fold_right (fun ta n -> fv_of_targ consider_var bound n ta) targs (conditional_add_typ bound used id) diff --git a/src/specialize.ml b/src/specialize.ml index 483697ce..d705b83a 100644 --- a/src/specialize.ml +++ b/src/specialize.ml @@ -92,7 +92,7 @@ let rec nexp_simp_typ (Typ_aux (typ_aux, l)) = | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc, nexp_simp_typ typ) | Typ_fn (arg_typs, ret_typ, effect) -> Typ_fn (List.map nexp_simp_typ arg_typs, nexp_simp_typ ret_typ, effect) - | Typ_bidir (t1, t2) -> Typ_bidir (nexp_simp_typ t1, nexp_simp_typ t2) + | Typ_bidir (t1, t2, effect) -> Typ_bidir (nexp_simp_typ t1, nexp_simp_typ t2, effect) | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" in Typ_aux (typ_aux, l) @@ -170,8 +170,8 @@ let string_of_instantiation instantiation = | Typ_app (id, args) -> string_of_id id ^ "(" ^ Util.string_of_list "," string_of_typ_arg args ^ ")" | Typ_fn (arg_typs, ret_typ, eff) -> "(" ^ Util.string_of_list ", " string_of_typ arg_typs ^ ") -> " ^ string_of_typ ret_typ ^ " effect " ^ string_of_effect eff - | Typ_bidir (t1, t2) -> - string_of_typ t1 ^ " <-> " ^ string_of_typ t2 + | Typ_bidir (t1, t2, eff) -> + string_of_typ t1 ^ " <-> " ^ string_of_typ t2 ^ " effect " ^ string_of_effect eff | Typ_exist (kids, nc, typ) -> "exist " ^ Util.string_of_list " " kid_name kids ^ ", " ^ string_of_n_constraint nc ^ ". " ^ string_of_typ typ | Typ_internal_unknown -> "UNKNOWN" @@ -290,7 +290,7 @@ let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = | Typ_exist (kopts, nc, typ) -> typ_frees ~exs:(KidSet.of_list (List.map kopt_kid kopts)) typ | Typ_fn (arg_typs, ret_typ, _) -> List.fold_left KidSet.union (typ_frees ~exs:exs ret_typ) (List.map (typ_frees ~exs:exs) arg_typs) - | Typ_bidir (t1, t2) -> KidSet.union (typ_frees ~exs:exs t1) (typ_frees ~exs:exs t2) + | Typ_bidir (t1, t2, _) -> KidSet.union (typ_frees ~exs:exs t1) (typ_frees ~exs:exs t2) | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and typ_arg_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) = match typ_arg_aux with @@ -308,7 +308,7 @@ let rec typ_int_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = | Typ_exist (kopts, nc, typ) -> typ_int_frees ~exs:(KidSet.of_list (List.map kopt_kid kopts)) typ | Typ_fn (arg_typs, ret_typ, _) -> List.fold_left KidSet.union (typ_int_frees ~exs:exs ret_typ) (List.map (typ_int_frees ~exs:exs) arg_typs) - | Typ_bidir (t1, t2) -> KidSet.union (typ_int_frees ~exs:exs t1) (typ_int_frees ~exs:exs t2) + | Typ_bidir (t1, t2, _) -> KidSet.union (typ_int_frees ~exs:exs t1) (typ_int_frees ~exs:exs t2) | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and typ_arg_int_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) = match typ_arg_aux with @@ -325,7 +325,7 @@ let rec remove_implicit (Typ_aux (aux, l) as t) = | Typ_internal_unknown -> Typ_aux (Typ_internal_unknown, l) | Typ_tup typs -> Typ_aux (Typ_tup (List.map remove_implicit typs), l) | Typ_fn (arg_typs, ret_typ, effs) -> Typ_aux (Typ_fn (List.map remove_implicit arg_typs, remove_implicit ret_typ, effs), l) - | Typ_bidir (typ1, typ2) -> Typ_aux (Typ_bidir (remove_implicit typ1, remove_implicit typ2), l) + | Typ_bidir (typ1, typ2, effs) -> Typ_aux (Typ_bidir (remove_implicit typ1, remove_implicit typ2, effs), l) | Typ_app (Id_aux (Id "implicit", _), args) -> Typ_aux (Typ_app (mk_id "atom", List.map remove_implicit_arg args), l) | Typ_app (id, args) -> Typ_aux (Typ_app (id, List.map remove_implicit_arg args), l) | Typ_id id -> Typ_aux (Typ_id id, l) @@ -602,11 +602,9 @@ let rec specialize_passes n spec env ast = let specialize = specialize_passes (-1) let () = - let open Printf in let open Interactive in - - (fun _ -> + Action (fun () -> let ast', env' = specialize typ_ord_specialization !env !ast in ast := ast'; - env := env') - |> register_command ~name:"specialize" ~help:":specialize - Specialize Type and Order type variables in the AST" + env := env' + ) |> register_command ~name:"specialize" ~help:"Specialize Type and Order type variables in the AST" diff --git a/src/state.ml b/src/state.ml index 9d79fef0..478a3fd5 100644 --- a/src/state.ml +++ b/src/state.ml @@ -58,6 +58,8 @@ open PPrint open Pretty_print_common open Pretty_print_sail +let opt_type_grouped_regstate = ref false + let defs_of_string = ast_of_def_string let is_defined defs name = IdSet.mem (mk_id name) (ids_of_defs (Defs defs)) @@ -78,11 +80,48 @@ let find_registers defs = | _ -> acc ) [] defs -let generate_regstate = function - | [] -> ["type regstate = unit"] +let generate_register_id_enum = function + | [] -> ["type register_id = unit"] | registers -> - let reg (typ, id) = Printf.sprintf "%s : %s" (string_of_id id) (to_string (doc_typ typ)) in - ["struct regstate = { " ^ (String.concat ", " (List.map reg registers)) ^ " }"] + let reg (typ, id) = string_of_id id in + ["type register_id = " ^ String.concat " | " (List.map reg registers)] + +let rec id_of_regtyp builtins mwords (Typ_aux (t, l) as typ) = match t with + | Typ_id id -> id + | Typ_app (id, args) -> + let name_arg (A_aux (targ, _)) = match targ with + | A_typ targ -> string_of_id (id_of_regtyp builtins mwords targ) + | A_nexp nexp when is_nexp_constant (nexp_simp nexp) -> + string_of_nexp (nexp_simp nexp) + | A_order (Ord_aux (Ord_inc, _)) -> "inc" + | A_order (Ord_aux (Ord_dec, _)) -> "dec" + | _ -> + raise (Reporting.err_typ l "Unsupported register type") + in + if IdSet.mem id builtins && not (mwords && is_bitvector_typ typ) then id else + append_id id (String.concat "_" ("" :: List.map name_arg args)) + | _ -> raise (Reporting.err_typ l "Unsupported register type") + +let regstate_field typ = append_id (id_of_regtyp IdSet.empty false typ) "_reg" + +let generate_regstate registers = + let regstate_def = + if registers = [] then + TD_abbrev (mk_id "regstate", mk_typquant [], mk_typ_arg (A_typ unit_typ)) + else + let fields = + if !opt_type_grouped_regstate then + List.map + (fun (typ, id) -> + (function_typ [string_typ] typ no_effect, + regstate_field typ)) + registers + |> List.sort_uniq (fun (typ1, id1) (typ2, id2) -> Id.compare id1 id2) + else registers + in + TD_record (mk_id "regstate", mk_typquant [], fields, false) + in + Defs [DEF_type (TD_aux (regstate_def, (Unknown, ())))] let generate_initial_regstate defs = let registers = find_registers defs in @@ -181,27 +220,15 @@ let generate_initial_regstate defs = | _ -> inits) ([], Bindings.empty) defs in let init_reg (typ, id) = string_of_id id ^ " = " ^ lookup_init_val init_vals typ in - init_defs @ - ["let initial_regstate : regstate = struct { " ^ (String.concat ", " (List.map init_reg registers)) ^ " }"] + List.map defs_of_string + (init_defs @ + ["let initial_regstate : regstate = struct { " ^ + (String.concat ", " (List.map init_reg registers)) ^ + " }"]) with | _ -> [] (* Do not generate an initial register state if anything goes wrong *) -let rec regval_constr_id mwords (Typ_aux (t, l) as typ) = match t with - | Typ_id id -> id - | Typ_app (id, args) -> - let name_arg (A_aux (targ, _)) = match targ with - | A_typ targ -> string_of_id (regval_constr_id mwords targ) - | A_nexp nexp when is_nexp_constant (nexp_simp nexp) -> - string_of_nexp (nexp_simp nexp) - | A_order (Ord_aux (Ord_inc, _)) -> "inc" - | A_order (Ord_aux (Ord_dec, _)) -> "dec" - | _ -> - raise (Reporting.err_typ l "Unsupported register type") - in - let builtins = IdSet.of_list (List.map mk_id ["vector"; "bitvector"; "list"; "option"]) in - if IdSet.mem id builtins && not (mwords && is_bitvector_typ typ) then id else - append_id id (String.concat "_" ("" :: List.map name_arg args)) - | _ -> raise (Reporting.err_typ l "Unsupported register type") +let regval_constr_id = id_of_regtyp (IdSet.of_list (List.map mk_id ["vector"; "bitvector"; "list"; "option"])) let register_base_types mwords typs = let rec add_base_typs typs (Typ_aux (t, _) as typ) = @@ -211,8 +238,8 @@ let register_base_types mwords typs = when IdSet.mem id builtins && not (mwords && is_bitvector_typ typ) -> let add_typ_arg base_typs (A_aux (targ, _)) = match targ with - | A_typ typ -> add_base_typs typs typ - | _ -> typs + | A_typ typ -> add_base_typs base_typs typ + | _ -> base_typs in List.fold_left add_typ_arg typs args | _ -> Bindings.add (regval_constr_id mwords typ) typ typs @@ -223,13 +250,14 @@ let generate_regval_typ typs = let constr (constr_id, typ) = Printf.sprintf "Regval_%s : %s" (string_of_id constr_id) (to_string (doc_typ typ)) in let builtins = - "Regval_vector : (int, bool, list(register_value)), " ^ + "Regval_vector : list(register_value), " ^ "Regval_list : list(register_value), " ^ "Regval_option : option(register_value)" in - ["union register_value = { " ^ - (String.concat ", " (builtins :: List.map constr (Bindings.bindings typs))) ^ - " }"] + [defs_of_string + ("union register_value = { " ^ + (String.concat ", " (builtins :: List.map constr (Bindings.bindings typs))) ^ + " }")] let add_regval_conv id typ (Defs defs) = let id = string_of_id id in @@ -253,11 +281,9 @@ let add_regval_conv id typ (Defs defs) = let rec regval_convs_lem mwords (Typ_aux (t, _) as typ) = match t with | Typ_app _ when (is_vector_typ typ || is_bitvector_typ typ) && not (mwords && is_bitvector_typ typ) -> let size, ord, etyp = vector_typ_args_of typ in - let size = string_of_nexp (nexp_simp size) in - let is_inc = if is_order_inc ord then "true" else "false" in let etyp_of, of_etyp = regval_convs_lem mwords etyp in "(fun v -> vector_of_regval " ^ etyp_of ^ " v)", - "(fun v -> regval_of_vector " ^ of_etyp ^ " " ^ size ^ " " ^ is_inc ^ " v)" + "(fun v -> regval_of_vector " ^ of_etyp ^ " v)" | Typ_app (id, [A_aux (A_typ etyp, _)]) when string_of_id id = "list" -> let etyp_of, of_etyp = regval_convs_lem mwords etyp in @@ -277,12 +303,12 @@ let register_refs_lem mwords registers = separate_map hardline string [ "val vector_of_regval : forall 'a. (register_value -> maybe 'a) -> register_value -> maybe (list 'a)"; "let vector_of_regval of_regval = function"; - " | Regval_vector (_, _, v) -> just_list (List.map of_regval v)"; + " | Regval_vector v -> just_list (List.map of_regval v)"; " | _ -> Nothing"; "end"; ""; - "val regval_of_vector : forall 'a. ('a -> register_value) -> integer -> bool -> list 'a -> register_value"; - "let regval_of_vector regval_of size is_inc xs = Regval_vector (size, is_inc, List.map regval_of xs)"; + "val regval_of_vector : forall 'a. ('a -> register_value) -> list 'a -> register_value"; + "let regval_of_vector regval_of xs = Regval_vector (List.map regval_of xs)"; ""; "val list_of_regval : forall 'a. (register_value -> maybe 'a) -> register_value -> maybe (list 'a)"; "let list_of_regval of_regval = function"; @@ -307,12 +333,20 @@ let register_refs_lem mwords registers = in let register_ref (typ, id) = let idd = string (string_of_id id) in + let (read_from, write_to) = + if !opt_type_grouped_regstate then + let field_idd = string (string_of_id (regstate_field typ)) in + (field_idd ^^ space ^^ dquotes idd, + doc_op equals field_idd (string "(fun reg -> if reg = \"" ^^ idd ^^ string "\" then v else s." ^^ field_idd ^^ string " reg)")) + else + (idd, doc_op equals idd (string "v")) + in (* let field = if prefix_recordtype then string "regstate_" ^^ idd else idd in *) let of_regval, regval_of = regval_convs_lem mwords typ in concat [string "let "; idd; string "_ref = <|"; hardline; string " name = \""; idd; string "\";"; hardline; - string " read_from = (fun s -> s."; idd; string ");"; hardline; - string " write_to = (fun v s -> (<| s with "; idd; string " = v |>));"; hardline; + string " read_from = (fun s -> s."; read_from; string ");"; hardline; + string " write_to = (fun v s -> (<| s with "; write_to; string " |>));"; hardline; string " of_regval = "; string of_regval; string ";"; hardline; string " regval_of = "; string regval_of; string " |>"; hardline] in @@ -393,7 +427,7 @@ let generate_isa_lemmas mwords (Defs defs : tannot defs) = separate_map hardline string [ "lemma vector_of_rv_rv_of_vector[simp]:"; " assumes \"\\<And>v. of_rv (rv_of v) = Some v\""; - " shows \"vector_of_regval of_rv (regval_of_vector rv_of len is_inc v) = Some v\""; + " shows \"vector_of_regval of_rv (regval_of_vector rv_of v) = Some v\""; "proof -"; " from assms have \"of_rv \\<circ> rv_of = Some\" by auto"; " then show ?thesis by (auto simp: vector_of_regval_def regval_of_vector_def)"; @@ -421,7 +455,7 @@ let rec regval_convs_coq (Typ_aux (t, _) as typ) = match t with let is_inc = if is_order_inc ord then "true" else "false" in let etyp_of, of_etyp = regval_convs_coq etyp in "(fun v => vector_of_regval " ^ size ^ " " ^ etyp_of ^ " v)", - "(fun v => regval_of_vector " ^ of_etyp ^ " " ^ size ^ " " ^ is_inc ^ " v)" + "(fun v => regval_of_vector " ^ of_etyp ^ " v)" | Typ_app (id, [A_aux (A_typ etyp, _)]) when string_of_id id = "list" -> let etyp_of, of_etyp = regval_convs_coq etyp in @@ -440,11 +474,11 @@ let register_refs_coq registers = let generic_convs = separate_map hardline string [ "Definition vector_of_regval {a} n (of_regval : register_value -> option a) (rv : register_value) : option (vec a n) := match rv with"; - " | Regval_vector (n', _, v) => if n =? n' then map_bind (vec_of_list n) (just_list (List.map of_regval v)) else None"; + " | Regval_vector v => if n =? length_list v then map_bind (vec_of_list n) (just_list (List.map of_regval v)) else None"; " | _ => None"; "end."; ""; - "Definition regval_of_vector {a} (regval_of : a -> register_value) (size : Z) (is_inc : bool) (xs : vec a size) : register_value := Regval_vector (size, is_inc, List.map regval_of (list_of_vec xs))."; + "Definition regval_of_vector {a size} (regval_of : a -> register_value) (xs : vec a size) : register_value := Regval_vector (List.map regval_of (list_of_vec xs))."; ""; "Definition list_of_regval {a} (of_regval : register_value -> option a) (rv : register_value) : option (list a) := match rv with"; " | Regval_list v => just_list (List.map of_regval v)"; @@ -504,14 +538,20 @@ let generate_regstate_defs mwords defs = let regtyps = register_base_types mwords (List.map fst registers) in let option_typ = if is_defined defs "option" then [] else - ["union option ('a : Type) = {None : unit, Some : 'a}"] + [defs_of_string "union option ('a : Type) = {None : unit, Some : 'a}"] in let regval_typ = if is_defined defs "register_value" then [] else generate_regval_typ regtyps in - let regstate_typ = if is_defined defs "regstate" then [] else generate_regstate registers in - let initregstate = if is_defined defs "initial_regstate" then [] else generate_initial_regstate defs in + let regstate_typ = if is_defined defs "regstate" then [] else [generate_regstate registers] in + let initregstate = + (* Don't create initial regstate if it is already defined or if we generated + a regstate record with registers grouped per type; the latter would + require record fields storing functions, which is not supported in + Sail. *) + if is_defined defs "initial_regstate" || !opt_type_grouped_regstate then [] else + generate_initial_regstate defs + in let defs = option_typ @ regval_typ @ regstate_typ @ initregstate - |> List.map defs_of_string |> concat_ast |> Bindings.fold add_regval_conv regtyps in diff --git a/src/type_check.ml b/src/type_check.ml index af4a7f65..73ad5362 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -79,6 +79,9 @@ let opt_smt_linearize = ref false (* Allow use of div and mod when rewriting nexps *) let opt_smt_div = ref false +(* Use new bitfield syntax, more compatible with ASL *) +let opt_new_bitfields = ref false + let depth = ref 0 let rec indent n = match n with @@ -112,6 +115,7 @@ type env = union_ids : (typquant * typ) Bindings.t; registers : (effect * effect * typ) Bindings.t; variants : (typquant * type_union list) Bindings.t; + scattered_variant_envs : env Bindings.t; mappings : (typquant * typ * typ) Bindings.t; typ_vars : (Ast.l * kind_aux) KBindings.t; shadow_vars : int KBindings.t; @@ -130,6 +134,7 @@ type env = poly_undefineds : bool; prove : (env -> n_constraint -> bool) option; allow_unknowns : bool; + bitfields : (Big_int.num * Big_int.num) Bindings.t Bindings.t; } exception Type_error of env * l * type_error;; @@ -233,7 +238,7 @@ and strip_typ_aux : typ_aux -> typ_aux = function | Typ_id id -> Typ_id (strip_id id) | Typ_var kid -> Typ_var (strip_kid kid) | Typ_fn (arg_typs, ret_typ, effect) -> Typ_fn (List.map strip_typ arg_typs, strip_typ ret_typ, strip_effect effect) - | Typ_bidir (typ1, typ2) -> Typ_bidir (strip_typ typ1, strip_typ typ2) + | Typ_bidir (typ1, typ2, effect) -> Typ_bidir (strip_typ typ1, strip_typ typ2, strip_effect effect) | Typ_tup typs -> Typ_tup (List.map strip_typ typs) | Typ_exist (kopts, constr, typ) -> Typ_exist ((List.map strip_kinded_id kopts), strip_n_constraint constr, strip_typ typ) @@ -267,7 +272,7 @@ let rec typ_constraints (Typ_aux (typ_aux, l)) = | Typ_exist (kids, nc, typ) -> typ_constraints typ | Typ_fn (arg_typs, ret_typ, _) -> List.concat (List.map typ_constraints arg_typs) @ typ_constraints ret_typ - | Typ_bidir (typ1, typ2) -> + | Typ_bidir (typ1, typ2, _) -> typ_constraints typ1 @ typ_constraints typ2 and typ_arg_nexps (A_aux (typ_arg_aux, l)) = match typ_arg_aux with @@ -286,7 +291,7 @@ let rec typ_nexps (Typ_aux (typ_aux, l)) = | Typ_exist (kids, nc, typ) -> typ_nexps typ | Typ_fn (arg_typs, ret_typ, _) -> List.concat (List.map typ_nexps arg_typs) @ typ_nexps ret_typ - | Typ_bidir (typ1, typ2) -> + | Typ_bidir (typ1, typ2, _) -> typ_nexps typ1 @ typ_nexps typ2 and typ_arg_nexps (A_aux (typ_arg_aux, l)) = match typ_arg_aux with @@ -421,7 +426,8 @@ module Env : sig val add_scattered_variant : id -> typquant -> t -> t val add_variant_clause : id -> type_union -> t -> t val get_variant : id -> t -> typquant * type_union list - val add_mapping : id -> typquant * typ * typ -> t -> t + val get_scattered_variant_env : id -> t -> t + val add_mapping : id -> typquant * typ * typ * effect -> t -> t val add_union_id : id -> typquant * typ -> t -> t val get_union_id : id -> t -> typquant * typ val is_register : id -> t -> bool @@ -434,6 +440,7 @@ module Env : sig val get_typ_var_loc : kid -> t -> Ast.l val get_typ_vars : t -> kind_aux KBindings.t val get_typ_var_locs : t -> Ast.l KBindings.t + val shadows : kid -> t -> int val add_typ_var_shadow : l -> kinded_id -> t -> t * kid option val add_typ_var : l -> kinded_id -> t -> t val get_ret_typ : t -> typ option @@ -467,6 +474,8 @@ module Env : sig val base_typ_of : t -> typ -> typ val allow_unknowns : t -> bool val set_allow_unknowns : bool -> t -> t + val add_bitfield : id -> (Big_int.num * Big_int.num) Bindings.t -> t -> t + val get_bitfield_range : l -> id -> id -> t -> (Big_int.num * Big_int.num) val no_bindings : t -> t @@ -499,6 +508,7 @@ end = struct union_ids = Bindings.empty; registers = Bindings.empty; variants = Bindings.empty; + scattered_variant_envs = Bindings.empty; mappings = Bindings.empty; typ_vars = KBindings.empty; shadow_vars = KBindings.empty; @@ -517,6 +527,7 @@ end = struct poly_undefineds = false; prove = None; allow_unknowns = false; + bitfields = Bindings.empty; } let set_prover f env = { env with prove = f } @@ -563,8 +574,8 @@ end = struct let builtin_mappings = List.fold_left (fun m (name, typ) -> Bindings.add (mk_id name) typ m) Bindings.empty [ - ("int", Typ_bidir(int_typ, string_typ)); - ("nat", Typ_bidir(nat_typ, string_typ)); + ("int", Typ_bidir(int_typ, string_typ, no_effect)); + ("nat", Typ_bidir(nat_typ, string_typ, no_effect)); ] let bound_typ_id env id = @@ -715,7 +726,7 @@ end = struct | Typ_internal_unknown -> Typ_aux (Typ_internal_unknown, l) | Typ_tup typs -> Typ_aux (Typ_tup (List.map (expand_synonyms env) typs), l) | Typ_fn (arg_typs, ret_typ, effs) -> Typ_aux (Typ_fn (List.map (expand_synonyms env) arg_typs, expand_synonyms env ret_typ, effs), l) - | Typ_bidir (typ1, typ2) -> Typ_aux (Typ_bidir (expand_synonyms env typ1, expand_synonyms env typ2), l) + | Typ_bidir (typ1, typ2, effs) -> Typ_aux (Typ_bidir (expand_synonyms env typ1, expand_synonyms env typ2, effs), l) | Typ_app (id, args) -> (try begin match get_typ_synonym id env l env args with @@ -776,7 +787,7 @@ end = struct | Typ_internal_unknown | Typ_id _ | Typ_var _ -> typ | Typ_fn (arg_typs, ret_typ, effect) -> Typ_aux (Typ_fn (List.map (map_nexps f) arg_typs, map_nexps f ret_typ, effect), l) - | Typ_bidir (typ1, typ2) -> Typ_aux (Typ_bidir (map_nexps f typ1, map_nexps f typ2), l) + | Typ_bidir (typ1, typ2, effect) -> Typ_aux (Typ_bidir (map_nexps f typ1, map_nexps f typ2, effect), l) | Typ_tup typs -> Typ_aux (Typ_tup (List.map (map_nexps f) typs), l) | Typ_exist (kids, nc, typ) -> Typ_aux (Typ_exist (kids, nc, map_nexps f typ), l) | Typ_app (id, args) -> Typ_aux (Typ_app (id, List.map (map_nexps_arg f) args), l) @@ -803,15 +814,15 @@ end = struct | Typ_var kid -> begin match KBindings.find kid env.typ_vars with | (_, K_type) -> () - | (_, k) -> typ_error env l ("Kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ + | (_, k) -> typ_error env l ("Type variable " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ ^ " is " ^ string_of_kind_aux k ^ " rather than Type") | exception Not_found -> - typ_error env l ("Unbound kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ) + typ_error env l ("Unbound type variable " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ) end | Typ_fn (arg_typs, ret_typ, effs) -> List.iter (wf_typ ~exs:exs env) arg_typs; wf_typ ~exs:exs env ret_typ - | Typ_bidir (typ1, typ2) when strip_typ typ1 = strip_typ typ2 -> + | Typ_bidir (typ1, typ2, _) when strip_typ typ1 = strip_typ typ2 -> typ_error env l "Bidirectional types cannot be the same on both sides" - | Typ_bidir (typ1, typ2) -> wf_typ ~exs:exs env typ1; wf_typ ~exs:exs env typ2 + | Typ_bidir (typ1, typ2, _) -> wf_typ ~exs:exs env typ1; wf_typ ~exs:exs env typ2 | Typ_tup typs -> List.iter (wf_typ ~exs:exs env) typs | Typ_app (id, [A_aux (A_nexp _, _) as arg]) when string_of_id id = "implicit" -> wf_typ_arg ~exs:exs env arg @@ -969,8 +980,8 @@ end = struct typ_print (lazy (adding ^ "val " ^ string_of_id id ^ " : " ^ string_of_bind (typq, typ))); { env with top_val_specs = Bindings.add id (typq, typ) env.top_val_specs } - | Typ_aux (Typ_bidir (typ1, typ2), l) -> - let env = add_mapping id (typq, typ1, typ2) env in + | Typ_aux (Typ_bidir (typ1, typ2, effect), l) -> + let env = add_mapping id (typq, typ1, typ2, effect) env in typ_print (lazy (adding ^ "mapping " ^ string_of_id id ^ " : " ^ string_of_bind (typq, typ))); { env with top_val_specs = Bindings.add id (typq, typ) env.top_val_specs } @@ -992,16 +1003,16 @@ end = struct env *) - and add_mapping id (typq, typ1, typ2) env = + and add_mapping id (typq, typ1, typ2, effect) env = typ_print (lazy (adding ^ "mapping " ^ string_of_id id)); let forwards_id = mk_id (string_of_id id ^ "_forwards") in let forwards_matches_id = mk_id (string_of_id id ^ "_forwards_matches") in let backwards_id = mk_id (string_of_id id ^ "_backwards") in let backwards_matches_id = mk_id (string_of_id id ^ "_backwards_matches") in - let forwards_typ = Typ_aux (Typ_fn ([typ1], typ2, no_effect), Parse_ast.Unknown) in - let forwards_matches_typ = Typ_aux (Typ_fn ([typ1], bool_typ, no_effect), Parse_ast.Unknown) in - let backwards_typ = Typ_aux (Typ_fn ([typ2], typ1, no_effect), Parse_ast.Unknown) in - let backwards_matches_typ = Typ_aux (Typ_fn ([typ2], bool_typ, no_effect), Parse_ast.Unknown) in + let forwards_typ = Typ_aux (Typ_fn ([typ1], typ2, effect), Parse_ast.Unknown) in + let forwards_matches_typ = Typ_aux (Typ_fn ([typ1], bool_typ, effect), Parse_ast.Unknown) in + let backwards_typ = Typ_aux (Typ_fn ([typ2], typ1, effect), Parse_ast.Unknown) in + let backwards_matches_typ = Typ_aux (Typ_fn ([typ2], bool_typ, effect), Parse_ast.Unknown) in let env = { env with mappings = Bindings.add id (typq, typ1, typ2) env.mappings } |> add_val_spec forwards_id (typq, forwards_typ) @@ -1059,7 +1070,7 @@ end = struct | Not_found -> typ_error env (id_loc id) ("Enumeration " ^ string_of_id id ^ " does not exist") let is_enum id env = Bindings.mem id env.enums - + let is_record id env = Bindings.mem id env.records let get_record id env = Bindings.find id env.records @@ -1140,7 +1151,10 @@ end = struct let add_scattered_variant id typq env = typ_print (lazy (adding ^ "scattered variant " ^ string_of_id id)); - { env with variants = Bindings.add id (typq, []) env.variants } + { env with + variants = Bindings.add id (typq, []) env.variants; + scattered_variant_envs = Bindings.add id env env.scattered_variant_envs + } let add_variant_clause id tu env = match Bindings.find_opt id env.variants with @@ -1152,6 +1166,11 @@ end = struct | Some (typq, tus) -> typq, tus | None -> typ_error env (id_loc id) ("union " ^ string_of_id id ^ " not found") + let get_scattered_variant_env id env = + match Bindings.find_opt id env.scattered_variant_envs with + | Some env' -> env' + | None -> typ_error env (id_loc id) ("scattered union " ^ string_of_id id ^ " has not been declared") + let is_register id env = Bindings.mem id env.registers @@ -1206,6 +1225,8 @@ end = struct with | Not_found -> Unbound + let shadows v env = match KBindings.find_opt v env.shadow_vars with Some n -> n | None -> 0 + let add_typ_var_shadow l (KOpt_aux (KOpt_kind (K_aux (k, _), v), _)) env = if KBindings.mem v env.typ_vars then begin let n = match KBindings.find_opt v env.shadow_vars with Some n -> n | None -> 0 in @@ -1308,6 +1329,18 @@ end = struct | targ -> rewrap targ in aux (expand_synonyms env typ) + let get_bitfield_range l id field env = + match Bindings.find_opt id env.bitfields with + | Some ranges -> + begin match Bindings.find_opt field ranges with + | Some range -> range + | None -> typ_error env l (Printf.sprintf "Field %s does not exist in the bitfield %s" (string_of_id field) (string_of_id id)) + end + | None -> typ_error env l (Printf.sprintf "%s is not a bitfield" (string_of_id id)) + + let add_bitfield id ranges env = + { env with bitfields = Bindings.add id ranges env.bitfields } + let allow_polymorphic_undefineds env = { env with poly_undefineds = true } @@ -1335,10 +1368,12 @@ let add_typquant l (quant : typquant) (env : Env.t) : Env.t = let expand_bind_synonyms l env (typq, typ) = typq, Env.expand_synonyms (add_typquant l typq env) typ -let wf_typschm env (TypSchm_aux (TypSchm_ts (typq, typ), l)) = +let wf_binding l env (typq, typ) = let env = add_typquant l typq env in Env.wf_typ env typ +let wf_typschm env (TypSchm_aux (TypSchm_ts (typq, typ), l)) = wf_binding l env (typq, typ) + (* Create vectors with the default order from the environment *) let default_order_error_string = @@ -1367,6 +1402,16 @@ let bind_numeric l typ env = nexp, add_existential l (List.map (mk_kopt K_int) kids) nc env | None -> typ_error env l ("Expected " ^ string_of_typ typ ^ " to be numeric") +let rec check_shadow_leaks l inner_env outer_env typ = + let vars = tyvars_of_typ typ in + List.iter (fun var -> + if Env.shadows var inner_env > Env.shadows var outer_env then + typ_error outer_env l + ("Type variable " ^ string_of_kid var ^ " would leak into a scope where it is shadowed") + else ()) + (KidSet.elements vars); + typ + (** Pull an (potentially)-existentially qualified type into the global typing environment **) let bind_existential l name typ env = @@ -1419,7 +1464,7 @@ let rec is_typ_monomorphic (Typ_aux (typ, l)) = | Typ_tup typs -> List.for_all is_typ_monomorphic typs | Typ_app (id, args) -> List.for_all is_typ_arg_monomorphic args | Typ_fn (arg_typs, ret_typ, _) -> List.for_all is_typ_monomorphic arg_typs && is_typ_monomorphic ret_typ - | Typ_bidir (typ1, typ2) -> is_typ_monomorphic typ1 && is_typ_monomorphic typ2 + | Typ_bidir (typ1, typ2, _) -> is_typ_monomorphic typ1 && is_typ_monomorphic typ2 | Typ_exist _ | Typ_var _ -> false | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and is_typ_arg_monomorphic (A_aux (arg, _)) = @@ -1618,9 +1663,10 @@ and typ_identical (Typ_aux (typ1, _)) (Typ_aux (typ2, _)) = List.for_all2 typ_identical arg_typs1 arg_typs2 && typ_identical ret_typ1 ret_typ2 && strip_effect eff1 = strip_effect eff2 - | Typ_bidir (typ1, typ2), Typ_bidir (typ3, typ4) -> + | Typ_bidir (typ1, typ2, eff1), Typ_bidir (typ3, typ4, eff2) -> typ_identical typ1 typ3 && typ_identical typ2 typ4 + && strip_effect eff1 = strip_effect eff2 | Typ_tup typs1, Typ_tup typs2 -> begin try List.for_all2 typ_identical typs1 typs2 with @@ -2018,7 +2064,7 @@ let rec alpha_equivalent env typ1 typ2 = | Typ_internal_unknown -> Typ_internal_unknown | Typ_id _ | Typ_var _ -> aux | Typ_fn (arg_typs, ret_typ, eff) -> Typ_fn (List.map relabel arg_typs, relabel ret_typ, eff) - | Typ_bidir (typ1, typ2) -> Typ_bidir (relabel typ1, relabel typ2) + | Typ_bidir (typ1, typ2, eff) -> Typ_bidir (relabel typ1, relabel typ2, eff) | Typ_tup typs -> Typ_tup (List.map relabel typs) | Typ_exist (kopts, nc, typ) -> let kind_map = List.fold_left (fun m kopt -> KBindings.add (kopt_kid kopt) (kopt_kind kopt) m) KBindings.empty kopts in @@ -2812,12 +2858,14 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | LB_val (P_aux (P_typ (ptyp, _), _) as pat, bind) -> Env.wf_typ env ptyp; let checked_bind = crule check_exp env bind ptyp in - let tpat, env = bind_pat_no_guard env pat ptyp in - annot_exp (E_let (LB_aux (LB_val (tpat, checked_bind), (let_loc, None)), crule check_exp env exp typ)) typ + let tpat, inner_env = bind_pat_no_guard env pat ptyp in + annot_exp (E_let (LB_aux (LB_val (tpat, checked_bind), (let_loc, None)), crule check_exp inner_env exp typ)) + (check_shadow_leaks l inner_env env typ) | LB_val (pat, bind) -> let inferred_bind = irule infer_exp env bind in - let tpat, env = bind_pat_no_guard env pat (typ_of inferred_bind) in - annot_exp (E_let (LB_aux (LB_val (tpat, inferred_bind), (let_loc, None)), crule check_exp env exp typ)) typ + let tpat, inner_env = bind_pat_no_guard env pat (typ_of inferred_bind) in + annot_exp (E_let (LB_aux (LB_val (tpat, inferred_bind), (let_loc, None)), crule check_exp inner_env exp typ)) + (check_shadow_leaks l inner_env env typ) end | E_app_infix (x, op, y), _ -> check_exp env (E_aux (E_app (deinfix op, [x; y]), (l, ()))) typ @@ -3278,7 +3326,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) | _ -> [typ] in match Env.expand_synonyms env mapping_typ with - | Typ_aux (Typ_bidir (typ1, typ2), _) -> + | Typ_aux (Typ_bidir (typ1, typ2, _), _) -> begin try typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ)); @@ -3372,7 +3420,7 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = begin let (typq, mapping_typ) = Env.get_val_spec f env in match Env.expand_synonyms env mapping_typ with - | Typ_aux (Typ_bidir (typ1, typ2), _) -> + | Typ_aux (Typ_bidir (typ1, typ2, _), _) -> begin try bind_pat env pat typ2 @@ -3484,46 +3532,6 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as | _ -> false in match lexp_aux with - | LEXP_field (LEXP_aux (flexp, _), field) -> - begin - let infer_flexp = function - | LEXP_id v -> - begin match Env.lookup_id v env with - | Register (_, _, typ) -> typ, LEXP_id v, true - | Local (Mutable, typ) -> typ, LEXP_id v, false - | _ -> typ_error env l "l-expression field is not a register or a local mutable type" - end - | LEXP_vector (LEXP_aux (LEXP_id v, _), exp) -> - begin - (* Check: is this ok if the vector is immutable? *) - let is_immutable, vtyp, is_register = match Env.lookup_id v env with - | Unbound -> typ_error env l "Cannot assign to element of unbound vector" - | Enum _ -> typ_error env l "Cannot vector assign to enumeration element" - | Local (Immutable, vtyp) -> true, vtyp, false - | Local (Mutable, vtyp) -> false, vtyp, false - | Register (_, _, vtyp) -> false, vtyp, true - in - let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_access", [E_aux (E_id v, (l, ())); exp]), (l, ()))) in - let inferred_exp = match access with - | E_aux (E_app (_, [_; inferred_exp]), _) -> inferred_exp - | _ -> assert false - in - typ_of access, LEXP_vector (annot_lexp (LEXP_id v) vtyp, inferred_exp), is_register - end - | _ -> typ_error env l "Field l-expression must be either a vector or an identifier" - in - let regtyp, inferred_flexp, is_register = infer_flexp flexp in - typ_debug (lazy ("REGTYP: " ^ string_of_typ regtyp ^ " / " ^ string_of_typ (Env.expand_synonyms env regtyp))); - match Env.expand_synonyms env regtyp with - | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> - let eff = if is_register then mk_effect [BE_wreg] else no_effect in - let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in - let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q regtyp with Unification_error (l, m) -> typ_error env l ("Unification error: " ^ m) in - let field_typ' = subst_unifiers unifiers field_typ in - let checked_exp = crule check_exp env exp field_typ' in - annot_assign (annot_lexp (LEXP_field (annot_lexp_effect inferred_flexp regtyp eff, field)) field_typ') checked_exp, env - | _ -> typ_error env l "Field l-expression has invalid type" - end | LEXP_memory (f, xs) -> check_exp env (E_aux (E_app (f, xs @ [exp]), (l, ()))) unit_typ, env | LEXP_cast (typ_annot, v) -> @@ -3661,7 +3669,16 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = annot_lexp (LEXP_vector (inferred_v_lexp, inferred_exp)) bit_typ else typ_error env l ("Vector assignment not provably in bounds " ^ string_of_lexp lexp) - | _ -> typ_error env l "Cannot assign vector element of non vector type" + | Typ_id id when !opt_new_bitfields -> + begin match exp with + | E_aux (E_id field, _) -> + let (hi, lo) = Env.get_bitfield_range l id field env in + let hi, lo = mk_exp ~loc:l (E_lit (L_aux (L_num hi, l))), mk_exp ~loc:l (E_lit (L_aux (L_num lo, l))) in + infer_lexp env (LEXP_aux (LEXP_vector_range (LEXP_aux (LEXP_field (v_lexp, Id_aux (Id "bits", l)), (l, ())), hi, lo), (l, ()))) + | _ -> + typ_error env l (string_of_exp exp ^ " is not a bitfield accessor") + end + | _ -> typ_error env l "Cannot assign vector element of non vector or bitfield type" end | LEXP_vector_concat [] -> typ_error env l "Cannot have empty vector concatenation l-expression" | LEXP_vector_concat (v_lexp :: v_lexps) -> @@ -3696,15 +3713,17 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = annot_lexp (LEXP_vector_concat (inferred_v_lexp :: inferred_v_lexps)) (bitvector_typ (nexp_simp len) ord) | _ -> typ_error env l ("Vector concatentation l-expression must only contain bitvector or vector types, found " ^ string_of_typ v_typ) end - | LEXP_field (LEXP_aux (LEXP_id v, _), fid) -> - (* FIXME: will only work for ASL *) - let rec_id, weff = - match Env.lookup_id v env with - | Register (_, weff, Typ_aux (Typ_id rec_id, _)) -> rec_id, weff - | _ -> typ_error env l (string_of_lexp lexp ^ " must be a record register here") - in - let typq, _, ret_typ, _ = Env.get_accessor rec_id fid env in - annot_lexp_effect (LEXP_field (annot_lexp (LEXP_id v) (mk_id_typ rec_id), fid)) ret_typ weff + | LEXP_field ((LEXP_aux (_, (l, ())) as lexp), field_id) -> + let inferred_lexp = infer_lexp env lexp in + let rectyp = lexp_typ_of inferred_lexp in + begin match lexp_typ_of inferred_lexp with + | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> + let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field_id env in + let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q rectyp with Unification_error (l, m) -> typ_error env l ("Unification error: " ^ m) in + let field_typ' = subst_unifiers unifiers field_typ in + annot_lexp (LEXP_field (inferred_lexp, field_id)) field_typ' + | _ -> typ_error env l "Field l-expression has invalid type" + end | LEXP_deref exp -> let inferred_exp = infer_exp env exp in begin match typ_of inferred_exp with @@ -3880,7 +3899,25 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = annot_exp (E_if (cond', then_branch', else_branch')) (typ_of then_branch') end end - | E_vector_access (v, n) -> infer_exp env (E_aux (E_app (mk_id "vector_access", [v; n]), (l, ()))) + | E_vector_access (v, n) -> + begin + try infer_exp env (E_aux (E_app (mk_id "vector_access", [v; n]), (l, ()))) with + | Type_error (err_env, err_l, err) when !opt_new_bitfields -> + (try ( + let inferred_v = infer_exp env v in + begin match typ_of inferred_v, n with + | Typ_aux (Typ_id id, _), E_aux (E_id field, (f_l, _)) -> + let (hi, lo) = Env.get_bitfield_range f_l id field env in + let hi, lo = mk_exp ~loc:l (E_lit (L_aux (L_num hi, l))), mk_exp ~loc:l (E_lit (L_aux (L_num lo, l))) in + infer_exp env (E_aux (E_vector_subrange (E_aux (E_field (v, Id_aux (Id "bits", f_l)), (l, ())), hi, lo), (l, ()))) + | _, _ -> + typ_error env l "Vector access could not be interpreted as a bitfield access" + end + ) with + | Type_error (_, err_l', err') -> + typ_raise err_env err_l (Err_because (err, err_l', err'))) + | exn -> raise exn + end | E_vector_update (v, n, exp) -> infer_exp env (E_aux (E_app (mk_id "vector_update", [v; n; exp]), (l, ()))) | E_vector_update_subrange (v, n, m, exp) -> infer_exp env (E_aux (E_app (mk_id "vector_update_subrange", [v; n; m; exp]), (l, ()))) | E_vector_append (v1, E_aux (E_vector [], _)) -> infer_exp env v1 @@ -3938,9 +3975,10 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | LB_val (pat, bind) -> let inferred_bind = irule infer_exp env bind in inferred_bind, pat, typ_of inferred_bind in - let tpat, env = bind_pat_no_guard env pat ptyp in - let inferred_exp = irule infer_exp env exp in - annot_exp (E_let (LB_aux (LB_val (tpat, bind_exp), (let_loc, None)), inferred_exp)) (typ_of inferred_exp) + let tpat, inner_env = bind_pat_no_guard env pat ptyp in + let inferred_exp = irule infer_exp inner_env exp in + annot_exp (E_let (LB_aux (LB_val (tpat, bind_exp), (let_loc, None)), inferred_exp)) + (check_shadow_leaks l inner_env env (typ_of inferred_exp)) | E_ref id when Env.is_register id env -> let _, _, typ = Env.get_register id env in annot_exp (E_ref id) (register_typ typ) @@ -4221,7 +4259,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( | _ -> [typ] in match Env.expand_synonyms env mapping_typ with - | Typ_aux (Typ_bidir (typ1, typ2), _) -> + | Typ_aux (Typ_bidir (typ1, typ2, _), _) -> begin try typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for mapping-pattern " ^ string_of_typ typ)); @@ -4320,7 +4358,7 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) begin let (typq, mapping_typ) = Env.get_val_spec f env in match Env.expand_synonyms env mapping_typ with - | Typ_aux (Typ_bidir (typ1, typ2), _) -> + | Typ_aux (Typ_bidir (typ1, typ2, _), _) -> begin try bind_mpat allow_unknown other_env env mpat typ2 @@ -4814,7 +4852,7 @@ let check_funcl env (FCL_aux (FCL_Funcl (id, pexp), (l, _))) typ = let check_mapcl : 'a. Env.t -> 'a mapcl -> typ -> tannot mapcl = fun env (MCL_aux (cl, (l, _))) typ -> match typ with - | Typ_aux (Typ_bidir (typ1, typ2), _) -> begin + | Typ_aux (Typ_bidir (typ1, typ2, _), _) -> begin match cl with | MCL_bidir (mpexp1, mpexp2) -> begin let testing_env = Env.set_allow_unknowns true env in @@ -4979,7 +5017,7 @@ let check_mapdef env (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, _)) as md raise err in let vtyp1, vtyp2, vl = match typ with - | Typ_aux (Typ_bidir (vtyp1, vtyp2), vl) -> vtyp1, vtyp2, vl + | Typ_aux (Typ_bidir (vtyp1, vtyp2, _), vl) -> vtyp1, vtyp2, vl | _ -> typ_error env l "Mapping val spec was not a mapping type" in begin match tannot_opt with @@ -5072,55 +5110,108 @@ let fold_union_quant quants (QI_aux (qi, l)) = | QI_id kind_id -> quants @ [kinded_id_arg kind_id] | _ -> quants -let check_type_union env variant typq (Tu_aux (tu, l)) = +(* We wrap this around wf_binding checks that aim to forbid recursive + types to explain any error messages raised if the well-formedness + check fails. *) +let forbid_recursive_types type_l f = + try f () with + | Type_error (env, l, err) -> + let msg = "Types are not well-formed within this type definition. Note that recursive types are forbidden." in + raise (Type_error (env, l, Err_because (err, type_l, Err_other msg))) + +let check_type_union u_l non_rec_env env variant typq (Tu_aux (tu, l)) = let ret_typ = app_typ variant (List.fold_left fold_union_quant [] (quant_items typq)) in match tu with | Tu_ty_id (Typ_aux (Typ_fn (arg_typ, ret_typ, _), _) as typ, v) -> let typq = mk_typquant (List.map (mk_qi_id K_type) (KidSet.elements (tyvars_of_typ typ))) in + wf_binding l env (typq, typ); + forbid_recursive_types u_l (fun () -> wf_binding l non_rec_env (typq, tuple_typ arg_typ)); env |> Env.add_union_id v (typq, typ) |> Env.add_val_spec v (typq, typ) | Tu_ty_id (arg_typ, v) -> let typ' = mk_typ (Typ_fn ([arg_typ], ret_typ, no_effect)) in + forbid_recursive_types u_l (fun () -> wf_binding l non_rec_env (typq, arg_typ)); + wf_binding l env (typq, typ'); env |> Env.add_union_id v (typq, typ') |> Env.add_val_spec v (typq, typ') -(* FIXME: This code is duplicated with general kind-checking code in environment, can they be merged? *) - let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t = fun env (TD_aux (tdef, (l, _))) -> let td_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented Typedef") in match tdef with | TD_abbrev (id, typq, typ_arg) -> + begin match typ_arg with + | A_aux (A_typ typ, a_l) -> + forbid_recursive_types l (fun () -> wf_binding a_l env (typq, typ)); + | _ -> () + end; [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id typq typ_arg env | TD_record (id, typq, fields, _) -> + forbid_recursive_types l (fun () -> List.iter (fun (Typ_aux (_, l) as field, _) -> wf_binding l env (typq, field)) fields); [DEF_type (TD_aux (tdef, (l, None)))], Env.add_record id typq fields env | TD_variant (id, typq, arms, _) -> + let rec_env = Env.add_variant id (typq, arms) env in + (* register_value is a special type used by theorem prover + backends that we allow to be recursive. *) + let non_rec_env = if string_of_id id = "register_value" then rec_env else env in let env = - env - |> Env.add_variant id (typq, arms) - |> (fun env -> List.fold_left (fun env tu -> check_type_union env id typq tu) env arms) + rec_env + |> (fun env -> List.fold_left (fun env tu -> check_type_union l non_rec_env env id typq tu) env arms) in [DEF_type (TD_aux (tdef, (l, None)))], env | TD_enum (id, ids, _) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_enum id ids env + | TD_bitfield (id, typ, ranges) when !opt_new_bitfields -> + let typ = Env.expand_synonyms env typ in + begin match typ with + (* The type of a bitfield must be a constant-width bitvector *) + | Typ_aux (Typ_app (v, [A_aux (A_nexp (Nexp_aux (Nexp_constant size, _)), _); + A_aux (A_order order, _)]), _) + when string_of_id v = "bitvector" -> + let size = Big_int.to_int size in + let eval_index_nexp l nexp = + match int_of_nexp_opt (nexp_simp (Env.expand_nexp_synonyms env nexp)) with + | Some i -> i + | None -> typ_error env l ("This numeric expression must evaluate to a constant: " ^ string_of_nexp nexp) + in + let record_tdef = TD_record (id, mk_typquant [], [(typ, mk_id "bits")], false) in + let ranges = + List.fold_left (fun ranges (field, range) -> + match range with + | BF_aux (BF_single nexp, l) -> + let n = eval_index_nexp l nexp in + Bindings.add field (n, n) ranges + | BF_aux (BF_range (hi, lo), l) -> + let hi, lo = eval_index_nexp l hi, eval_index_nexp l lo in + Bindings.add field (hi, lo) ranges + | BF_aux (BF_concat _, _) -> + typ_error env l "Bitfield concatenation ranges are not supported" + ) Bindings.empty ranges + in + [DEF_type (TD_aux (record_tdef, (l, None)))], + env + |> Env.add_record id (mk_typquant []) [(typ, mk_id "bits")] + |> Env.add_bitfield id ranges + | _ -> + typ_error env l "Underlying bitfield type must be a constant-width bitvector" + end | TD_bitfield (id, typ, ranges) -> let typ = Env.expand_synonyms env typ in - begin - match typ with - (* The type of a bitfield must be a constant-width bitvector *) - | Typ_aux (Typ_app (v, [A_aux (A_nexp (Nexp_aux (Nexp_constant size, _)), _); - A_aux (A_order order, _)]), _) - when string_of_id v = "bitvector" -> - let size = Big_int.to_int size in - let eval_index_nexp env nexp = - int_of_nexp_opt (nexp_simp (Env.expand_nexp_synonyms env nexp)) in - let (Defs defs), env = - check env (Bitfield.macro (eval_index_nexp env, (typ_error env)) id size order ranges) in - defs, env - | _ -> - typ_error env l "Bad bitfield type" + begin match typ with + (* The type of a bitfield must be a constant-width bitvector *) + | Typ_aux (Typ_app (v, [A_aux (A_nexp (Nexp_aux (Nexp_constant size, _)), _); + A_aux (A_order order, _)]), _) + when string_of_id v = "bitvector" -> + let size = Big_int.to_int size in + let eval_index_nexp env nexp = + int_of_nexp_opt (nexp_simp (Env.expand_nexp_synonyms env nexp)) in + let (Defs defs), env = + check env (Bitfield.macro (eval_index_nexp env, (typ_error env)) id size order ranges) in + defs, env + | _ -> + typ_error env l "Underlying bitfield type must be a constant-width bitvector" end and check_scattered : 'a. Env.t -> 'a scattered_def -> (tannot def) list * Env.t = @@ -5133,7 +5224,13 @@ and check_scattered : 'a. Env.t -> 'a scattered_def -> (tannot def) list * Env.t [DEF_scattered (SD_aux (SD_unioncl (id, tu), (l, None)))], let env = Env.add_variant_clause id tu env in let typq, _ = Env.get_variant id env in - check_type_union env id typq tu + let definition_env = Env.get_scattered_variant_env id env in + (try check_type_union l definition_env env id typq tu with + | Type_error (env, l', err) -> + let msg = "As this is a scattered union clause, this could \ + also be caused by using a type defined after the \ + 'scattered union' declaration" in + raise (Type_error (env, l', Err_because (err, id_loc id, Err_other msg)))) | SD_funcl (FCL_aux (FCL_Funcl (id, _), (l, _)) as funcl) -> let typq, typ = Env.get_val_spec id env in let funcl_env = add_typquant l typq env in diff --git a/src/type_check.mli b/src/type_check.mli index 711f2411..76b38557 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -80,6 +80,9 @@ val opt_smt_linearize : bool ref (** Allow use of div and mod when rewriting nexps *) val opt_smt_div : bool ref +(** Use new bitfield syntax, more compatible with ASL *) +val opt_new_bitfields : bool ref + (** {2 Type errors} *) type type_error = diff --git a/src/type_error.ml b/src/type_error.ml index eed1379a..6205302e 100644 --- a/src/type_error.ml +++ b/src/type_error.ml @@ -107,7 +107,7 @@ let message_of_type_error = let rec msg = function | Err_because (err, l', err') -> Seq [msg err; - Line "This error occured because of a previous error:"; + Line "This error was caused by:"; Location (l', msg err')] | Err_other str -> Line str diff --git a/src/util.ml b/src/util.ml index 2745631c..99f1111f 100644 --- a/src/util.ml +++ b/src/util.ml @@ -143,6 +143,22 @@ let remove_dups compare eq l = in aux [] l' +let lex_ord_list comparison xs ys = + let rec lex_lists xs ys = + match xs, ys with + | x :: xs, y :: ys -> + let c = comparison x y in + if c = 0 then lex_lists xs ys else c + | [], [] -> 0 + | _, _ -> assert false + in + if List.length xs = List.length ys then + lex_lists xs ys + else if List.length xs < List.length ys then + -1 + else + 1 + let rec power i tothe = if tothe <= 0 then 1 @@ -228,7 +244,7 @@ let option_bind f = function | None -> None | Some(o) -> f o -let rec option_binop f x y = match x, y with +let option_binop f x y = match x, y with | Some x, Some y -> Some (f x y) | _ -> None @@ -418,6 +434,7 @@ let termcode n = else "" let bold str = termcode 1 ^ str +let dim str = termcode 2 ^ str let darkgray str = termcode 90 ^ str let red str = termcode 91 ^ str diff --git a/src/util.mli b/src/util.mli index 9c57e360..3d83a1a4 100644 --- a/src/util.mli +++ b/src/util.mli @@ -73,6 +73,9 @@ val remove_duplicates : 'a list -> 'a list (** [remove_dups compare eq l] as remove_duplicates but with parameterised comparison and equality *) val remove_dups : ('a -> 'a -> int) -> ('a -> 'a -> bool) -> 'a list -> 'a list +(** Lift a comparison order to the lexical order on lists *) +val lex_ord_list : ('a -> 'a -> int) -> 'a list -> 'a list -> int + (** [assoc_equal_opt] and [assoc_compare_opt] are like List.assoc_opt but take equality/comparison functions as arguments, rather than relying on OCaml's built in equality *) @@ -237,6 +240,7 @@ val split_on_char : char -> string -> string list val termcode : int -> string val bold : string -> string +val dim : string -> string val darkgray : string -> string val green : string -> string val red : string -> string diff --git a/src/value.ml b/src/value.ml index 71d9ffe6..3a9a071f 100644 --- a/src/value.ml +++ b/src/value.ml @@ -369,6 +369,14 @@ let value_mult = function | [v1; v2] -> V_int (Sail_lib.mult (coerce_int v1, coerce_int v2)) | _ -> failwith "value mult" +let value_tdiv_int = function + | [v1; v2] -> V_int (Sail_lib.tdiv_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value tdiv_int" + +let value_tmod_int = function + | [v1; v2] -> V_int (Sail_lib.tmod_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value tmod_int" + let value_quotient = function | [v1; v2] -> V_int (Sail_lib.quotient (coerce_int v1, coerce_int v2)) | _ -> failwith "value quotient" @@ -486,7 +494,7 @@ let value_undefined_vector = function let value_undefined_bitvector = function | [v] -> V_vector (Sail_lib.undefined_vector (coerce_int v, V_bit (Sail_lib.B0))) | _ -> failwith "value undefined_bitvector" - + let value_read_ram = function | [v1; v2; v3; v4] -> mk_vector (Sail_lib.read_ram (coerce_int v1, coerce_int v2, coerce_bv v3, coerce_bv v4)) | _ -> failwith "value read_ram" @@ -620,131 +628,136 @@ let value_decimal_string_of_bits = function | [v] -> V_string (Sail_lib.decimal_string_of_bits (coerce_bv v)) | _ -> failwith "value decimal_string_of_bits" -let primops = - List.fold_left - (fun r (x, y) -> StringMap.add x y r) - StringMap.empty - [ ("and_bool", and_bool); - ("or_bool", or_bool); - ("print", value_print); - ("prerr", fun vs -> (prerr_string (string_of_value (List.hd vs)); V_unit)); - ("dec_str", fun _ -> V_string "X"); - ("print_endline", value_print_endline); - ("prerr_endline", fun vs -> (prerr_endline (string_of_value (List.hd vs)); V_unit)); - ("putchar", value_putchar); - ("string_of_int", fun vs -> V_string (string_of_value (List.hd vs))); - ("string_of_bits", fun vs -> V_string (string_of_value (List.hd vs))); - ("decimal_string_of_bits", value_decimal_string_of_bits); - ("print_bits", value_print_bits); - ("print_int", value_print_int); - ("print_string", value_print_string); - ("prerr_bits", value_print_bits); - ("prerr_int", value_print_int); - ("prerr_string", value_prerr_string); - ("concat_str", value_concat_str); - ("eq_int", value_eq_int); - ("lteq", value_lteq); - ("gteq", value_gteq); - ("lt", value_lt); - ("gt", value_gt); - ("eq_list", value_eq_list); - ("eq_bool", value_eq_bool); - ("eq_string", value_eq_string); - ("string_startswith", value_string_startswith); - ("string_drop", value_string_drop); - ("string_take", value_string_take); - ("string_length", value_string_length); - ("eq_bit", value_eq_bit); - ("eq_anything", value_eq_anything); - ("length", value_length); - ("subrange", value_subrange); - ("access", value_access); - ("update", value_update); - ("update_subrange", value_update_subrange); - ("slice", value_slice); - ("append", value_append); - ("append_list", value_append_list); - ("not", value_not); - ("not_vec", value_not_vec); - ("and_vec", value_and_vec); - ("or_vec", value_or_vec); - ("xor_vec", value_xor_vec); - ("uint", value_uint); - ("sint", value_sint); - ("get_slice_int", value_get_slice_int); - ("set_slice_int", value_set_slice_int); - ("set_slice", value_set_slice); - ("hex_slice", value_hex_slice); - ("zero_extend", value_zero_extend); - ("sign_extend", value_sign_extend); - ("zeros", value_zeros); - ("ones", value_ones); - ("shiftr", value_shiftr); - ("shiftl", value_shiftl); - ("shift_bits_left", value_shift_bits_left); - ("shift_bits_right", value_shift_bits_right); - ("add_int", value_add_int); - ("sub_int", value_sub_int); - ("sub_nat", value_sub_nat); - ("div_int", value_quotient); - ("mult_int", value_mult); - ("mult", value_mult); - ("quotient", value_quotient); - ("modulus", value_modulus); - ("negate", value_negate); - ("pow2", value_pow2); - ("int_power", value_int_power); - ("shr_int", value_shr_int); - ("shl_int", value_shl_int); - ("max_int", value_max_int); - ("min_int", value_min_int); - ("abs_int", value_abs_int); - ("add_vec_int", value_add_vec_int); - ("sub_vec_int", value_sub_vec_int); - ("add_vec", value_add_vec); - ("sub_vec", value_sub_vec); - ("vector_truncate", value_vector_truncate); - ("vector_truncateLSB", value_vector_truncateLSB); - ("read_ram", value_read_ram); - ("write_ram", value_write_ram); - ("trace_memory_read", fun _ -> V_unit); - ("trace_memory_write", fun _ -> V_unit); - ("get_time_ns", fun _ -> V_int (Sail_lib.get_time_ns())); - ("load_raw", value_load_raw); - ("to_real", value_to_real); - ("eq_real", value_eq_real); - ("lt_real", value_lt_real); - ("gt_real", value_gt_real); - ("lteq_real", value_lteq_real); - ("gteq_real", value_gteq_real); - ("add_real", value_add_real); - ("sub_real", value_sub_real); - ("mult_real", value_mult_real); - ("round_up", value_round_up); - ("round_down", value_round_down); - ("quot_round_zero", value_quot_round_zero); - ("rem_round_zero", value_rem_round_zero); - ("quotient_real", value_quotient_real); - ("abs_real", value_abs_real); - ("div_real", value_div_real); - ("sqrt_real", value_sqrt_real); - ("print_real", value_print_real); - ("random_real", value_random_real); - ("undefined_unit", fun _ -> V_unit); - ("undefined_bit", fun _ -> V_bit Sail_lib.B0); - ("undefined_int", fun _ -> V_int Big_int.zero); - ("undefined_nat", fun _ -> V_int Big_int.zero); - ("undefined_bool", fun _ -> V_bool false); - ("undefined_bitvector", value_undefined_bitvector); - ("undefined_vector", value_undefined_vector); - ("undefined_string", fun _ -> V_string ""); - ("internal_pick", value_internal_pick); - ("replicate_bits", value_replicate_bits); - ("Elf_loader.elf_entry", fun _ -> V_int (!Elf_loader.opt_elf_entry)); - ("Elf_loader.elf_tohost", fun _ -> V_int (!Elf_loader.opt_elf_tohost)); - ("string_append", value_string_append); - ("string_length", value_string_length); - ("string_startswith", value_string_startswith); - ("string_drop", value_string_drop); - ("skip", fun _ -> V_unit); - ] +let primops = ref + (List.fold_left + (fun r (x, y) -> StringMap.add x y r) + StringMap.empty + [ ("and_bool", and_bool); + ("or_bool", or_bool); + ("print", value_print); + ("prerr", fun vs -> (prerr_string (string_of_value (List.hd vs)); V_unit)); + ("dec_str", fun _ -> V_string "X"); + ("print_endline", value_print_endline); + ("prerr_endline", fun vs -> (prerr_endline (string_of_value (List.hd vs)); V_unit)); + ("putchar", value_putchar); + ("string_of_int", fun vs -> V_string (string_of_value (List.hd vs))); + ("string_of_bits", fun vs -> V_string (string_of_value (List.hd vs))); + ("decimal_string_of_bits", value_decimal_string_of_bits); + ("print_bits", value_print_bits); + ("print_int", value_print_int); + ("print_string", value_print_string); + ("prerr_bits", value_print_bits); + ("prerr_int", value_print_int); + ("prerr_string", value_prerr_string); + ("concat_str", value_concat_str); + ("eq_int", value_eq_int); + ("lteq", value_lteq); + ("gteq", value_gteq); + ("lt", value_lt); + ("gt", value_gt); + ("eq_list", value_eq_list); + ("eq_bool", value_eq_bool); + ("eq_string", value_eq_string); + ("string_startswith", value_string_startswith); + ("string_drop", value_string_drop); + ("string_take", value_string_take); + ("string_length", value_string_length); + ("eq_bit", value_eq_bit); + ("eq_anything", value_eq_anything); + ("length", value_length); + ("subrange", value_subrange); + ("access", value_access); + ("update", value_update); + ("update_subrange", value_update_subrange); + ("slice", value_slice); + ("append", value_append); + ("append_list", value_append_list); + ("not", value_not); + ("not_vec", value_not_vec); + ("and_vec", value_and_vec); + ("or_vec", value_or_vec); + ("xor_vec", value_xor_vec); + ("uint", value_uint); + ("sint", value_sint); + ("get_slice_int", value_get_slice_int); + ("set_slice_int", value_set_slice_int); + ("set_slice", value_set_slice); + ("hex_slice", value_hex_slice); + ("zero_extend", value_zero_extend); + ("sign_extend", value_sign_extend); + ("zeros", value_zeros); + ("ones", value_ones); + ("shiftr", value_shiftr); + ("shiftl", value_shiftl); + ("shift_bits_left", value_shift_bits_left); + ("shift_bits_right", value_shift_bits_right); + ("add_int", value_add_int); + ("sub_int", value_sub_int); + ("sub_nat", value_sub_nat); + ("div_int", value_quotient); + ("tdiv_int", value_tdiv_int); + ("tmod_int", value_tmod_int); + ("mult_int", value_mult); + ("mult", value_mult); + ("quotient", value_quotient); + ("modulus", value_modulus); + ("negate", value_negate); + ("pow2", value_pow2); + ("int_power", value_int_power); + ("shr_int", value_shr_int); + ("shl_int", value_shl_int); + ("max_int", value_max_int); + ("min_int", value_min_int); + ("abs_int", value_abs_int); + ("add_vec_int", value_add_vec_int); + ("sub_vec_int", value_sub_vec_int); + ("add_vec", value_add_vec); + ("sub_vec", value_sub_vec); + ("vector_truncate", value_vector_truncate); + ("vector_truncateLSB", value_vector_truncateLSB); + ("read_ram", value_read_ram); + ("write_ram", value_write_ram); + ("trace_memory_read", fun _ -> V_unit); + ("trace_memory_write", fun _ -> V_unit); + ("get_time_ns", fun _ -> V_int (Sail_lib.get_time_ns())); + ("load_raw", value_load_raw); + ("to_real", value_to_real); + ("eq_real", value_eq_real); + ("lt_real", value_lt_real); + ("gt_real", value_gt_real); + ("lteq_real", value_lteq_real); + ("gteq_real", value_gteq_real); + ("add_real", value_add_real); + ("sub_real", value_sub_real); + ("mult_real", value_mult_real); + ("round_up", value_round_up); + ("round_down", value_round_down); + ("quot_round_zero", value_quot_round_zero); + ("rem_round_zero", value_rem_round_zero); + ("quotient_real", value_quotient_real); + ("abs_real", value_abs_real); + ("div_real", value_div_real); + ("sqrt_real", value_sqrt_real); + ("print_real", value_print_real); + ("random_real", value_random_real); + ("undefined_unit", fun _ -> V_unit); + ("undefined_bit", fun _ -> V_bit Sail_lib.B0); + ("undefined_int", fun _ -> V_int Big_int.zero); + ("undefined_nat", fun _ -> V_int Big_int.zero); + ("undefined_bool", fun _ -> V_bool false); + ("undefined_bitvector", value_undefined_bitvector); + ("undefined_vector", value_undefined_vector); + ("undefined_string", fun _ -> V_string ""); + ("internal_pick", value_internal_pick); + ("replicate_bits", value_replicate_bits); + ("Elf_loader.elf_entry", fun _ -> V_int (!Elf_loader.opt_elf_entry)); + ("Elf_loader.elf_tohost", fun _ -> V_int (!Elf_loader.opt_elf_tohost)); + ("string_append", value_string_append); + ("string_length", value_string_length); + ("string_startswith", value_string_startswith); + ("string_drop", value_string_drop); + ("skip", fun _ -> V_unit); + ]) + +let add_primop name impl = + primops := StringMap.add name impl !primops diff --git a/src/value2.lem b/src/value2.lem index 0afaa2d1..1c525f80 100644 --- a/src/value2.lem +++ b/src/value2.lem @@ -60,4 +60,7 @@ type vl = | VL_int of integer | VL_string of string | VL_real of string - | VL_null (* Used for unitialized values and null pointers in C compilation *) + | VL_empty_list + | VL_enum of string + | VL_ref of string + | VL_undefined diff --git a/test/c/bitvector_update.expect b/test/c/bitvector_update.expect new file mode 100644 index 00000000..9766475a --- /dev/null +++ b/test/c/bitvector_update.expect @@ -0,0 +1 @@ +ok diff --git a/test/c/bitvector_update.sail b/test/c/bitvector_update.sail new file mode 100644 index 00000000..6f506e23 --- /dev/null +++ b/test/c/bitvector_update.sail @@ -0,0 +1,13 @@ +default Order dec +$include <prelude.sail> + +val "print_endline" : string -> unit + +function main() -> unit = { + let x = bitzero; + let y = bitone; + let z = bitzero; + let bv = [x, y, z]; + assert(bv == 0b010); + print_endline("ok") +}
\ No newline at end of file diff --git a/test/c/bitvector_update2.expect b/test/c/bitvector_update2.expect new file mode 100644 index 00000000..9766475a --- /dev/null +++ b/test/c/bitvector_update2.expect @@ -0,0 +1 @@ +ok diff --git a/test/c/bitvector_update2.sail b/test/c/bitvector_update2.sail new file mode 100644 index 00000000..8e5e9918 --- /dev/null +++ b/test/c/bitvector_update2.sail @@ -0,0 +1,14 @@ +default Order dec +$include <prelude.sail> + +val "print_endline" : string -> unit + +function main() -> unit = { + var bv = 0b101; + let x = bitzero; + let y = bitone; + let z = bitzero; + bv = [x, y, z]; + assert(bv == 0b010); + print_endline("ok") +} diff --git a/test/c/nested_fields.expect b/test/c/nested_fields.expect new file mode 100644 index 00000000..0cfbf088 --- /dev/null +++ b/test/c/nested_fields.expect @@ -0,0 +1 @@ +2 diff --git a/test/c/nested_fields.sail b/test/c/nested_fields.sail new file mode 100644 index 00000000..1e26dac9 --- /dev/null +++ b/test/c/nested_fields.sail @@ -0,0 +1,20 @@ +default Order dec + +$include <prelude.sail> + +struct B = { + f3: int, + f4: int, +} + +struct A = { + f1: B, + f2: int, +} + +register R : A + +function main() -> unit = { + R.f1.f3 = 2; + print_int("", R.f1.f3) +}
\ No newline at end of file diff --git a/test/c/scattered_mapping.expect b/test/c/scattered_mapping.expect new file mode 100644 index 00000000..6a452c18 --- /dev/null +++ b/test/c/scattered_mapping.expect @@ -0,0 +1 @@ +() diff --git a/test/c/scattered_mapping.sail b/test/c/scattered_mapping.sail new file mode 100644 index 00000000..4f523e45 --- /dev/null +++ b/test/c/scattered_mapping.sail @@ -0,0 +1,17 @@ +default Order dec + +$include <prelude.sail> +$include <string.sail> +$include <mapping.sail> + +val "print_endline" : string -> unit + +val unit_str_map : unit <-> string +scattered mapping unit_str_map +val unit_str : unit -> string +function unit_str () = unit_str_map_forwards(()) +mapping clause unit_str_map = () <-> "()" + +function main () : unit -> unit = { + print_endline(unit_str()) +} diff --git a/test/c/undefined_union.expect b/test/c/undefined_union.expect new file mode 100644 index 00000000..9766475a --- /dev/null +++ b/test/c/undefined_union.expect @@ -0,0 +1 @@ +ok diff --git a/test/c/undefined_union.sail b/test/c/undefined_union.sail new file mode 100644 index 00000000..9b652b34 --- /dev/null +++ b/test/c/undefined_union.sail @@ -0,0 +1,11 @@ + +union Test = { + Ctor1 : int, + Ctor2 : (int, int) +} + +val "print_endline" : string -> unit + +function main() -> unit = { + print_endline("ok") +} diff --git a/test/coq/pass/booltyparam.sail b/test/coq/pass/booltyparam.sail new file mode 100644 index 00000000..423c2720 --- /dev/null +++ b/test/coq/pass/booltyparam.sail @@ -0,0 +1,11 @@ +/* Test a boolean type parameter. Not sure that this is terribly useful, + but it fills a gap in coverage... */ + +$include <prelude.sail> + +union perhaps('b : Bool) = {No : unit, Yes : {'n, 'b. atom('n)}} + +val foo : forall 'n. atom('n) -> perhaps('n >= 0) + +function foo(n) = + if n >= 0 then Yes(n) else No() diff --git a/test/mono/castreq.sail b/test/mono/castreq.sail index b1df7010..75791bfd 100644 --- a/test/mono/castreq.sail +++ b/test/mono/castreq.sail @@ -93,6 +93,33 @@ function assign3(x) = { y } +/* Test that matching on a variable which happens to fix a bitvector variable's + size updates the environment properly. */ + +val assign4 : forall 'm, 'm in {1,2}. (implicit('m),bits(8*'m)) -> bits(8*'m) + +function assign4(m,x) = { + y : bits(8*'m) = x; + match m { + 1 => y = y + 0x01, + 2 => y[7..0] = 0x89 + }; + y +} + +/* The same as assign4, except with a distinct type variable. */ + +val assign5 : forall 'm 'n, 'm in {1,2} & 'n == 8 * 'm. (implicit('m),bits('n)) -> bits('n) + +function assign5(m,x) = { + y : bits('n) = x; + match m { + 1 => y = y + 0x01, + 2 => y[7..0] = 0x89 + }; + y +} + /* Adding casts for top-level pattern matches */ val foo2 : forall 'm 'n, 'm in {8,16} & 'n in {32,64}. (atom('n), bits('m)) -> bits('n) effect pure @@ -140,6 +167,10 @@ function run () = { assert(assign2(0x1234) == 0x00001234); assert(assign3(0x12) == 0x13); assert(assign3(0x1234) == 0x1289); + assert(assign4(0x12) == 0x13); + assert(assign4(0x1234) == 0x1289); + assert(assign5(0x12) == 0x13); + assert(assign5(0x1234) == 0x1289); assert(foo2(32,0x12) == 0x00120012); assert(foo2(64,0x12) == 0x0012001200120012); assert(foo3(4,0x12) == 0x00120012); diff --git a/test/mono/nonlinearpat.sail b/test/mono/nonlinearpat.sail new file mode 100644 index 00000000..e0aaeff3 --- /dev/null +++ b/test/mono/nonlinearpat.sail @@ -0,0 +1,17 @@ +default Order dec +$include <prelude.sail> + +val test : forall 'n, 'n in {8,16}. (int('n),int('n),bits(1)) -> bits(64) effect pure + +function test(x,y,b) = { + let 'z = x + y in + let v : bits('z) = sail_zero_extend(b,z) in + sail_zero_extend(v,64) +} + +val run : unit -> unit effect {escape} + +function run () = { + assert(test(8,8,0b0) == 0x0000000000000000); + assert(test(16,16,0b1) == 0x0000000000000001); +} diff --git a/test/mono/pass/nonlinearpat b/test/mono/pass/nonlinearpat new file mode 100644 index 00000000..3f235d60 --- /dev/null +++ b/test/mono/pass/nonlinearpat @@ -0,0 +1 @@ +nonlinearpat.sail -auto_mono diff --git a/test/mono/pass/union_split b/test/mono/pass/union_split new file mode 100644 index 00000000..cdd2763d --- /dev/null +++ b/test/mono/pass/union_split @@ -0,0 +1 @@ +union_split.sail -auto_mono diff --git a/test/mono/run_tests.sh b/test/mono/run_tests.sh index d2023229..f95dc7d5 100755 --- a/test/mono/run_tests.sh +++ b/test/mono/run_tests.sh @@ -72,7 +72,7 @@ do "$SAILDIR/src/gen_lib/sail2_values.lem" \ "$SAILDIR/src/gen_lib/sail2_operators.lem" \ "$SAILDIR/src/gen_lib/sail2_operators_mwords.lem" \ - "$SAILDIR/src/lem_interp/sail2_instr_kinds.lem" \ + "$SAILDIR/src/gen_lib/sail2_instr_kinds.lem" \ "$SAILDIR/src/gen_lib/sail2_prompt.lem" \ "$SAILDIR/src/gen_lib/sail2_state_monad.lem" \ "$SAILDIR/src/gen_lib/sail2_state.lem" \ diff --git a/test/mono/union_split.sail b/test/mono/union_split.sail new file mode 100644 index 00000000..2403e644 --- /dev/null +++ b/test/mono/union_split.sail @@ -0,0 +1,23 @@ +default Order dec +$include <prelude.sail> + +/* Simple case split example on a variant datatype */ + +union ast = { + SomeOp : {'n, 'n in {8,16}. (int('n),bits('n))} +} + +val execute : ast -> bits(32) + +function execute(SomeOp(n as int('n),v)) = { + a : bits('n) = sail_zero_extend(0x12,n); + b : bits('n) = and_vec(v, a); + sail_zero_extend(b,32) +} + +val run : unit -> unit effect {escape} + +function run () = { + assert(execute(SomeOp(8,0x11)) == 0x00000010); + assert(execute(SomeOp(16,0x3333)) == 0x00000012); +} diff --git a/test/smt/revrev_endianness.sail b/test/smt/revrev_endianness.unsat.sail index f792871f..f792871f 100644 --- a/test/smt/revrev_endianness.sail +++ b/test/smt/revrev_endianness.unsat.sail diff --git a/test/smt/revrev_endianness2.sail b/test/smt/revrev_endianness2.unsat.sail index 33ba93a2..33ba93a2 100644 --- a/test/smt/revrev_endianness2.sail +++ b/test/smt/revrev_endianness2.unsat.sail diff --git a/test/typecheck/fail/scattered_union_rec.expect b/test/typecheck/fail/scattered_union_rec.expect new file mode 100644 index 00000000..cbc9f70a --- /dev/null +++ b/test/typecheck/fail/scattered_union_rec.expect @@ -0,0 +1,16 @@ +Type error: +[[96mscattered_union_rec.sail[0m]:6:24-25 +6[96m |[0munion clause U = Ctor : E + [91m |[0m [91m^[0m + [91m |[0m Undefined type E + [91m |[0m This error was caused by: + [91m |[0m [[96mscattered_union_rec.sail[0m]:6:0-25 + [91m |[0m 6[96m |[0munion clause U = Ctor : E + [91m |[0m [91m |[0m[91m^-----------------------^[0m + [91m |[0m [91m |[0m Types are not well-formed within this type definition. Note that recursive types are forbidden. + [91m |[0m This error was caused by: + [91m |[0m [[96mscattered_union_rec.sail[0m]:6:13-14 + [91m |[0m 6[96m |[0munion clause U = Ctor : E + [91m |[0m [91m |[0m [91m^[0m + [91m |[0m [91m |[0m As this is a scattered union clause, this could also be caused by using a type defined after the 'scattered union' declaration + [91m |[0m diff --git a/test/typecheck/fail/scattered_union_rec.sail b/test/typecheck/fail/scattered_union_rec.sail new file mode 100644 index 00000000..9f005f4e --- /dev/null +++ b/test/typecheck/fail/scattered_union_rec.sail @@ -0,0 +1,6 @@ + +scattered union U + +enum E = A | B | C + +union clause U = Ctor : E diff --git a/test/typecheck/fail/shadow_leak_check.expect b/test/typecheck/fail/shadow_leak_check.expect new file mode 100644 index 00000000..a92e0078 --- /dev/null +++ b/test/typecheck/fail/shadow_leak_check.expect @@ -0,0 +1,8 @@ +Type error: +[[96mshadow_leak_check.sail[0m]:17:5-18:6 +17[96m |[0m let 'x = some_other_int(); + [91m |[0m [91m^-------------------------[0m +18[96m |[0m x + [91m |[0m[91m-----^[0m + [91m |[0m Type variable 'x would leak into a scope where it is shadowed + [91m |[0m diff --git a/test/typecheck/fail/shadow_leak_check.sail b/test/typecheck/fail/shadow_leak_check.sail new file mode 100644 index 00000000..266a0469 --- /dev/null +++ b/test/typecheck/fail/shadow_leak_check.sail @@ -0,0 +1,24 @@ +default Order dec + +function some_int() -> int = { + 4 +} + +function some_other_int() -> int = { + 5 +} + +val test : forall 'n 'm, 'n == 'm. (int('n), int('m)) -> unit + +function main() -> unit = { + let 'x = some_int(); + + let 'y: int('x) = { + let 'x = some_other_int(); + x + }; + + _prove(constraint('x == 'y)); + + test(x, y) +} diff --git a/test/typecheck/fail/shadow_leak_infer.expect b/test/typecheck/fail/shadow_leak_infer.expect new file mode 100644 index 00000000..63aba5d7 --- /dev/null +++ b/test/typecheck/fail/shadow_leak_infer.expect @@ -0,0 +1,8 @@ +Type error: +[[96mshadow_leak_infer.sail[0m]:17:5-18:6 +17[96m |[0m let 'x = some_other_int(); + [91m |[0m [91m^-------------------------[0m +18[96m |[0m x + [91m |[0m[91m-----^[0m + [91m |[0m Type variable '_x would leak into a scope where it is shadowed + [91m |[0m diff --git a/test/typecheck/fail/shadow_leak_infer.sail b/test/typecheck/fail/shadow_leak_infer.sail new file mode 100644 index 00000000..cb122cf9 --- /dev/null +++ b/test/typecheck/fail/shadow_leak_infer.sail @@ -0,0 +1,24 @@ +default Order dec + +function some_int() -> int = { + 4 +} + +function some_other_int() -> int = { + 5 +} + +val test : forall 'n 'm, 'n == 'm. (int('n), int('m)) -> unit + +function main() -> unit = { + let 'x = some_int(); + + let 'y = { + let 'x = some_other_int(); + x + }; + + _prove(constraint('x == 'y)); + + test(x, y) +} diff --git a/test/typecheck/fail/struct_rec.expect b/test/typecheck/fail/struct_rec.expect new file mode 100644 index 00000000..2b5b1852 --- /dev/null +++ b/test/typecheck/fail/struct_rec.expect @@ -0,0 +1,13 @@ +Type error: +[[96mstruct_rec.sail[0m]:3:10-11 +3[96m |[0m field : S + [91m |[0m [91m^[0m + [91m |[0m Undefined type S + [91m |[0m This error was caused by: + [91m |[0m [[96mstruct_rec.sail[0m]:2:0-4:1 + [91m |[0m 2[96m |[0mstruct S = { + [91m |[0m [91m |[0m[91m^-----------[0m + [91m |[0m 4[96m |[0m} + [91m |[0m [91m |[0m[91m^[0m + [91m |[0m [91m |[0m Types are not well-formed within this type definition. Note that recursive types are forbidden. + [91m |[0m diff --git a/test/typecheck/fail/struct_rec.sail b/test/typecheck/fail/struct_rec.sail new file mode 100644 index 00000000..01c29d6d --- /dev/null +++ b/test/typecheck/fail/struct_rec.sail @@ -0,0 +1,4 @@ + +struct S = { + field : S +} diff --git a/test/typecheck/fail/synonym_rec.expect b/test/typecheck/fail/synonym_rec.expect new file mode 100644 index 00000000..3d482f40 --- /dev/null +++ b/test/typecheck/fail/synonym_rec.expect @@ -0,0 +1,11 @@ +Type error: +[[96msynonym_rec.sail[0m]:2:9-10 +2[96m |[0mtype T = T + [91m |[0m [91m^[0m + [91m |[0m Undefined type T + [91m |[0m This error was caused by: + [91m |[0m [[96msynonym_rec.sail[0m]:2:0-10 + [91m |[0m 2[96m |[0mtype T = T + [91m |[0m [91m |[0m[91m^--------^[0m + [91m |[0m [91m |[0m Types are not well-formed within this type definition. Note that recursive types are forbidden. + [91m |[0m diff --git a/test/typecheck/fail/synonym_rec.sail b/test/typecheck/fail/synonym_rec.sail new file mode 100644 index 00000000..54906418 --- /dev/null +++ b/test/typecheck/fail/synonym_rec.sail @@ -0,0 +1,2 @@ + +type T = T diff --git a/test/typecheck/fail/union_rec.expect b/test/typecheck/fail/union_rec.expect new file mode 100644 index 00000000..7fd07169 --- /dev/null +++ b/test/typecheck/fail/union_rec.expect @@ -0,0 +1,13 @@ +Type error: +[[96munion_rec.sail[0m]:3:9-10 +3[96m |[0m Ctor : U + [91m |[0m [91m^[0m + [91m |[0m Undefined type U + [91m |[0m This error was caused by: + [91m |[0m [[96munion_rec.sail[0m]:2:0-4:1 + [91m |[0m 2[96m |[0munion U = { + [91m |[0m [91m |[0m[91m^----------[0m + [91m |[0m 4[96m |[0m} + [91m |[0m [91m |[0m[91m^[0m + [91m |[0m [91m |[0m Types are not well-formed within this type definition. Note that recursive types are forbidden. + [91m |[0m diff --git a/test/typecheck/fail/union_rec.sail b/test/typecheck/fail/union_rec.sail new file mode 100644 index 00000000..7ca7b8e9 --- /dev/null +++ b/test/typecheck/fail/union_rec.sail @@ -0,0 +1,4 @@ + +union U = { + Ctor : U +} diff --git a/test/typecheck/fail/union_recf.expect b/test/typecheck/fail/union_recf.expect new file mode 100644 index 00000000..ec610ae6 --- /dev/null +++ b/test/typecheck/fail/union_recf.expect @@ -0,0 +1,13 @@ +Type error: +[[96munion_recf.sail[0m]:3:9-10 +3[96m |[0m Ctor : U -> U + [91m |[0m [91m^[0m + [91m |[0m Undefined type U + [91m |[0m This error was caused by: + [91m |[0m [[96munion_recf.sail[0m]:2:0-4:1 + [91m |[0m 2[96m |[0munion U = { + [91m |[0m [91m |[0m[91m^----------[0m + [91m |[0m 4[96m |[0m} + [91m |[0m [91m |[0m[91m^[0m + [91m |[0m [91m |[0m Types are not well-formed within this type definition. Note that recursive types are forbidden. + [91m |[0m diff --git a/test/typecheck/fail/union_recf.sail b/test/typecheck/fail/union_recf.sail new file mode 100644 index 00000000..f64ca675 --- /dev/null +++ b/test/typecheck/fail/union_recf.sail @@ -0,0 +1,4 @@ + +union U = { + Ctor : U -> U +} diff --git a/test/typecheck/pass/constrained_struct/v1.expect b/test/typecheck/pass/constrained_struct/v1.expect index 8c95193d..0b0dda29 100644 --- a/test/typecheck/pass/constrained_struct/v1.expect +++ b/test/typecheck/pass/constrained_struct/v1.expect @@ -3,4 +3,9 @@ Type error: 10[96m |[0mtype MyStruct64 = MyStruct(65) [91m |[0m [91m^------^[0m [91m |[0m Could not prove (65 == 32 | 65 == 64) for type constructor MyStruct + [91m |[0m This error was caused by: + [91m |[0m [[96mconstrained_struct/v1.sail[0m]:10:0-30 + [91m |[0m 10[96m |[0mtype MyStruct64 = MyStruct(65) + [91m |[0m [91m |[0m[91m^----------------------------^[0m + [91m |[0m [91m |[0m Types are not well-formed within this type definition. Note that recursive types are forbidden. [91m |[0m diff --git a/test/typecheck/pass/existential_ast/v3.expect b/test/typecheck/pass/existential_ast/v3.expect index e2823692..8d061933 100644 --- a/test/typecheck/pass/existential_ast/v3.expect +++ b/test/typecheck/pass/existential_ast/v3.expect @@ -3,5 +3,5 @@ Type error: 26[96m |[0m Some(Ctor1(a, x, c)) [91m |[0m [91m^------------^[0m [91m |[0m Could not resolve quantifiers for Ctor1 - [91m |[0m [94m*[0m datasize('ex270#) + [91m |[0m [94m*[0m datasize('ex276#) [91m |[0m diff --git a/test/typecheck/pass/mapping_rreg.sail b/test/typecheck/pass/mapping_rreg.sail new file mode 100644 index 00000000..1f3e1212 --- /dev/null +++ b/test/typecheck/pass/mapping_rreg.sail @@ -0,0 +1,17 @@ +default Order dec + +$include <prelude.sail> + +register enabled : bits(1) + +union ast = { + I: bits(1) +} + +val encdec : ast <-> bits(2) effect {rreg} + +scattered mapping encdec + +mapping clause encdec = I(imm) if enabled == 0b0 <-> 0b0 @ imm if enabled == 0b0 + +end encdec diff --git a/test/typecheck/pass/new_bitfields.sail b/test/typecheck/pass/new_bitfields.sail new file mode 100644 index 00000000..fdb17576 --- /dev/null +++ b/test/typecheck/pass/new_bitfields.sail @@ -0,0 +1,16 @@ +default Order dec + +$include <prelude.sail> + +$option -new_bitfields + +bitfield B : bits(32) = { + Field: 7..0 +} + +register R : B + +function main() -> unit = { + R[Field] = 0xFF; + assert(R[Field] == 0xFF) +}
\ No newline at end of file diff --git a/test/typecheck/pass/reg_32_64/v2.expect b/test/typecheck/pass/reg_32_64/v2.expect index 24439bed..90166904 100644 --- a/test/typecheck/pass/reg_32_64/v2.expect +++ b/test/typecheck/pass/reg_32_64/v2.expect @@ -5,7 +5,7 @@ Type error: [91m |[0m Tried performing type coercion from bitvector('d, dec) to bitvector((('d - 0) + 1), dec) on data [91m |[0m Coercion failed because: [91m |[0m Mismatched argument types in subtype check - [91m |[0m This error occured because of a previous error: + [91m |[0m This error was caused by: [91m |[0m [[96mreg_32_64/v2.sail[0m]:21:2-15 [91m |[0m 21[96m |[0m (*R)['d .. 0] = data [91m |[0m [91m |[0m [91m^-----------^[0m diff --git a/test/typecheck/pass/union_recf_ok.sail b/test/typecheck/pass/union_recf_ok.sail new file mode 100644 index 00000000..0f415601 --- /dev/null +++ b/test/typecheck/pass/union_recf_ok.sail @@ -0,0 +1,4 @@ + +union U = { + Ctor : int -> U +}
\ No newline at end of file diff --git a/test/typecheck/run_tests.sh b/test/typecheck/run_tests.sh index e5650646..adc30c42 100755 --- a/test/typecheck/run_tests.sh +++ b/test/typecheck/run_tests.sh @@ -87,6 +87,24 @@ do done done +for file in $DIR/fail/*.sail; +do + pushd $DIR/fail > /dev/null; + if $SAILDIR/sail -no_memo_z3 $(basename $file) 2> result + then + red "Expected failure, but $i $(basename $file) passed" "fail" + else + if diff ${file%.sail}.expect result; + then + green "failing $i $(basename $file)" "pass" + else + yellow "failing $i $(basename $file)" "unexpected error" + fi + fi; + rm -f result; + popd > /dev/null +done + finish_suite "Typechecking tests" printf "</testsuites>\n" >> $DIR/tests.xml diff --git a/test/typecheck/update_errors.sh b/test/typecheck/update_errors.sh index ba436daf..1d174797 100755 --- a/test/typecheck/update_errors.sh +++ b/test/typecheck/update_errors.sh @@ -10,8 +10,15 @@ do shopt -s nullglob; for file in $DIR/pass/${i%.sail}/*.sail; do - pushd $DIR/pass > /dev/null; - $SAILDIR/sail ${i%.sail}/$(basename $file) 2> ${file%.sail}.expect || true; - popd > /dev/null + pushd $DIR/pass > /dev/null; + $SAILDIR/sail -no_memo_z3 ${i%.sail}/$(basename $file) 2> ${file%.sail}.expect || true; + popd > /dev/null done done + +for file in $DIR/fail/*.sail; +do + pushd $DIR/fail > /dev/null; + $SAILDIR/sail -no_memo_z3 $(basename $file) 2> ${file%.sail}.expect || true; + popd > /dev/null +done |